diff --git a/Make.inc.in b/Make.inc.in index f03f68974..62851d15b 100755 --- a/Make.inc.in +++ b/Make.inc.in @@ -35,6 +35,7 @@ LIBS=@LIBS@ BLAS=@BLAS_LIBS@ BLACS=@BLACS_LIBS@ METIS_LIB=@METIS_LIBS@ +LAPACK=@LAPACK_LIBS@ PSBFDEFINES=@FDEFINES@ PSBCDEFINES=@CDEFINES@ diff --git a/README b/README index 607145437..37559da7e 100644 --- a/README +++ b/README @@ -84,8 +84,8 @@ We offer an experimental configure script: if everything works well, it will generate a Make.inc file suitable for building the library. The script is capable of recognizing the needed libraries with their default names; if they are in unusual places consider adding the paths -with --with-lib, or explicitly specifying the names in --with-blas and -friends. +with --with-lib, or explicitly specifying the names in --with-blas, +--with-blacs etc. Please note that a common way for the configure script to fail is to specify inconsistent MPI vs. plain compilers, either directly or indirectly via environment variables; e.g. specifying the Intel @@ -100,6 +100,16 @@ of mpich in use is the one compiled with the gnu42 compilers. After the configure script has completed you can always tweak the Make.inc file yourself. +An annoying problem exists with some versions of MPICH: the configure +script will set -DMPI_MOD, which is to say, the MPI call interfaces +will be resolved by using the MPI Fortran module. However usage of the +module may cause compilation to fail if coupled with the debugging +option -ggdb, because the compiler complains that it cannot find any +matching interface. +The solution: either take out the -ggdb option, or, if you really need +to debug, force -DMPI_H in place of -DMPI_MOD. + + As a backup alternative, you can always choose a Make.inc.XXX file in directory Make that fits your compilers, modify the paths to libraries to match your installation and copy it to Make.inc in the top diff --git a/base/comm/Makefile b/base/comm/Makefile index a97ebccda..8d50528d6 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -1,7 +1,9 @@ include ../../Make.inc OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ + psb_sgather.o psb_shalo.o psb_sovrl.o \ psb_igather.o psb_ihalo.o psb_iovrl.o \ + psb_cgather.o psb_chalo.o psb_covrl.o \ psb_zgather.o psb_zhalo.o psb_zovrl.o MPFOBJS=psb_dscatter.o psb_zscatter.o psb_iscatter.o diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 new file mode 100644 index 000000000..850f4f0c3 --- /dev/null +++ b/base/comm/psb_cgather.f90 @@ -0,0 +1,333 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cgather.f90 +! +! Subroutine: psb_cgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - cplx,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - cplx,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: locx(:,:) + complex(psb_spk_), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: iroot + + + ! locals + integer :: int_err(5), ictxt, np, me, & + & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx + + character(len=20) :: name, ch_err + + name='psb_cgatherm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + lda_globx = size(globx,1) + lda_locx = size(locx, 1) + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + lock=size(locx,2)-jlocx+1 + globk=size(globx,2)-jglobx+1 + maxk=min(lock,globk) + + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + if (info == 0) & + & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=0.d0 + + do j=1,k + do i=1,psb_cd_get_local_rows(desc_a) + idx = desc_a%loc_to_glob(i) + globx(idx,jglobx+j-1) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx,jglobx+j-1) = zzero + end if + end do + end do + call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root) + + 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_cgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_cgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - cplx,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - cplx,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: locx(:) + complex(psb_spk_), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: iroot + + + ! locals + integer :: int_err(5), ictxt, np, me, & + & err_act, n, root, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + lda_globx = size(globx) + lda_locx = size(locx) + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + if (info == 0) & + & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=0.d0 + + do i=1,psb_cd_get_local_rows(desc_a) + idx = desc_a%loc_to_glob(i) + globx(idx) = locx(i) + end do + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx) = dzero + end if + end do + call psb_sum(ictxt,globx(1:m),root=root) + + + 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_cgatherv diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 new file mode 100644 index 000000000..60a3a2a4e --- /dev/null +++ b/base/comm/psb_chalo.f90 @@ -0,0 +1,435 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_chalo.f90 +! +! Subroutine: psb_chalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - real,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! alpha - complex(optional). Scale factor. +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_realloc_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional :: alpha + complex(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_ + complex(psb_spk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_chalom' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + if(present(alpha)) then + if(alpha /= 1.d0) then + do i=0, k-1 + call zscal(nrow,alpha,x(1,jjx+i),1) + end do + end if + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,czero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,cone,xp,& + &desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= 0) then + ch_err='PSI_zswapdata' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_chalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_chalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! alpha - complex(optional). Scale factor. +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_realloc_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional :: alpha + complex(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer :: ictxt, np, me, err_act, & + & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ + complex(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_chalov' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + ijx = 1 + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + if(present(alpha)) then + if(alpha /= 1.d0) then + call zscal(nrow,alpha,x,ione) + end if + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,czero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,cone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= 0) then + ch_err='PSI_dSwap...' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_chalov + + + diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 new file mode 100644 index 000000000..8c20789c2 --- /dev/null +++ b/base/comm/psb_covrl.f90 @@ -0,0 +1,398 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_covrl.f90 +! +! Subroutine: psb_covrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - complex The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork + complex(psb_spk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_covrlm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:size(x,1),jjx:jjx+k-1) + call psi_swapdata(mode_,k,cone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_covrlm +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_covrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - complex The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_covrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + use psi_mod + use psb_const_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: update,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& + & mode_, err, liwork + complex(psb_spk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_covrlv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + ijx = 1 + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,cone,x(:),& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_covrlv diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 new file mode 100644 index 000000000..c9f6b66d8 --- /dev/null +++ b/base/comm/psb_sgather.f90 @@ -0,0 +1,329 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sgather.f90 +! +! Subroutine: psb_sgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - real,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - real,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! Default: -1. +! +subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: locx(:,:) + real(psb_spk_), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: iroot + + + ! locals + integer :: int_err(5), ictxt, np, me,& + & err_act, n, root, iiroot, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx + character(len=20) :: name, ch_err + + name='psb_sgatherm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else + root = -1 + end if + if (root==-1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + lda_globx = size(globx,1) + lda_locx = size(locx, 1) + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + lock=size(locx,2)-jlocx+1 + globk=size(globx,2)-jglobx+1 + maxk=min(lock,globk) + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) + call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=0.d0 + + do j=1,k + do i=1,psb_cd_get_local_rows(desc_a) + idx = desc_a%loc_to_glob(i) + globx(idx,jglobx+j-1) = locx(i,jlx+j-1) + end do + end do + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx,jglobx+j-1) = szero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root) + + 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_sgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - real,dimension(:). The local vector into which gather the +! distributed pieces. +! locx - real,dimension(:). The local piece of the ditributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! root - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: locx(:) + real(psb_spk_), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: iroot + + + ! locals + integer :: int_err(5), ictxt, np, me, & + & err_act, n, root, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + + character(len=20) :: name, ch_err + + name='psb_sgatherv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=30 + int_err(1:2)=(/5,root/) + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + lda_globx = size(globx) + lda_locx = size(locx) + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) + call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= 0) then + info=4010 + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=0.d0 + + do i=1,psb_cd_get_local_rows(desc_a) + idx = desc_a%loc_to_glob(i) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + idx = desc_a%loc_to_glob(idx) + globx(idx) = szero + end if + end do + call psb_sum(ictxt,globx(1:m),root=root) + + 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_sgatherv diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 new file mode 100644 index 000000000..47dcee890 --- /dev/null +++ b/base/comm/psb_shalo.f90 @@ -0,0 +1,433 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_shalo.f90 +! +! Subroutine: psb_shalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - real,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! alpha - real(optional). Scale factor. +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_realloc_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional :: alpha + real(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& + & err, liwork,data_ + real(psb_spk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_shalom' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + if(present(alpha)) then + if(alpha /= 1.d0) then + do i=0, k-1 + call dscal(nrow,alpha,x(1,jjx+i),1) + end do + end if + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. +!!$ write(0,*) 'halom ',liwork + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,szero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,sone,xp,& + &desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= 0) then + ch_err='PSI_dSwapdata' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + + 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_shalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_shalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! alpha - real(optional). Scale factor. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_realloc_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional :: alpha + real(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + real(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_shalov' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + ijx = 1 + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + if(present(alpha)) then + if(alpha /= 1.d0) then + call dscal(nrow,alpha,x,ione) + end if + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,szero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,sone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= 0) then + ch_err='PSI_swapdata' + call psb_errpush(4010,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + + 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_shalov + + + diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 new file mode 100644 index 000000000..063ceddfc --- /dev/null +++ b/base/comm/psb_sovrl.f90 @@ -0,0 +1,400 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sovrl.f90 +! +! Subroutine: psb_sovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - real The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + use psb_const_mod + use psi_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork + real(psb_spk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sovrlm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:size(x,1),jjx:jjx+k-1) + call psi_swapdata(mode_,k,sone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_sovrlm + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - real The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! +subroutine psb_sovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + use psi_mod + use psb_const_mod + use psb_realloc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), optional, target :: work(:) + integer, intent(in), optional :: update,mode + + ! locals + integer :: ictxt, np, me, & + & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& + & mode_, err, liwork + real(psb_spk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sovrlv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(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 + + ix = 1 + ijx = 1 + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,sone,x(:),& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + 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_sovrlv diff --git a/base/internals/Makefile b/base/internals/Makefile index 62ea18bf7..021be0c32 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -8,9 +8,12 @@ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o #COBJS = avltree.o srcht.o -MPFOBJS = psi_dswapdata.o psi_dswaptran.o psi_iswapdata.o \ - psi_iswaptran.o psi_desc_index.o \ - psi_zswapdata.o psi_zswaptran.o psi_extrct_dl.o +MPFOBJS = psi_dswapdata.o psi_dswaptran.o\ + psi_sswapdata.o psi_sswaptran.o \ + psi_iswapdata.o psi_iswaptran.o \ + psi_cswapdata.o psi_cswaptran.o \ + psi_zswapdata.o psi_zswaptran.o \ + psi_desc_index.o psi_extrct_dl.o LIBDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG). diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 new file mode 100644 index 000000000..4caf8e31b --- /dev/null +++ b/base/internals/psi_cswapdata.F90 @@ -0,0 +1,1000 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: psi_cswapdata.F90 +! +! Subroutine: psi_cswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswapdatam + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer, pointer :: d_idx(:) + character(len=20) :: name + + info = 0 + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_cswapdatam + +subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_cswapidxm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag,n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_ + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_data' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_complex,rcvbuf,rvsz,& + & brvidx,mpi_complex,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & mpi_complex,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag=ksendid(ictxt,proc_to_comm,me) + if ((nesd>0).and.(proc_to_comm/=me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + if (do_recv) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_cswapidxm + +! +! +! Subroutine: psi_cswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswapdatav + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer, pointer :: d_idx(:) + character(len=20) :: name + + info = 0 + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + icomm = psb_cd_get_mpic(desc_a) + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_cswapdatav + + +subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_cswapidxv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, totsnd_, totrcv_,& + & idx_pt, snd_pt, rcv_pt, n, pnti, data_ + + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_datav' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_complex,rcvbuf,rvsz,& + & brvidx,mpi_complex,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & mpi_complex,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_cswapidxv diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 new file mode 100644 index 000000000..4bb821a4d --- /dev/null +++ b/base/internals/psi_cswaptran.F90 @@ -0,0 +1,1011 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: psi_cswaptran.F90 +! +! Subroutine: psi_cswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswaptranm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer, pointer :: d_idx(:) + integer :: int_err(5) + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_cswaptranm + +subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ctranidxm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag,n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_ + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_ctranidxm +! +! +! Subroutine: psi_cswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswaptranv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer, pointer :: d_idx(:) + integer :: int_err(5) + character(len=20) :: name + + info = 0 + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_cswaptranv + + + +subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ctranidxv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_, n + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(sndbuf(snd_pt),nesd,& + & mpi_complex,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & mpi_complex,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & mpi_complex,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + end if + + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_ctranidxv diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 new file mode 100644 index 000000000..fbefada03 --- /dev/null +++ b/base/internals/psi_sswapdata.F90 @@ -0,0 +1,1000 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: psi_sswapdata.F90 +! +! Subroutine: psi_sswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +! +subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswapdatam + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer, pointer :: d_idx(:) + character(len=20) :: name + + info = 0 + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_sswapdatam + +subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_sswapidxm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag,n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_ + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_data' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_real,rcvbuf,rvsz,& + & brvidx,mpi_real,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & mpi_real,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag=ksendid(ictxt,proc_to_comm,me) + if ((nesd>0).and.(proc_to_comm/=me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + if (do_recv) then + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_sswapidxm + +! +! +! Subroutine: psi_sswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswapdatav + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer, pointer :: d_idx(:) + character(len=20) :: name + + info = 0 + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + icomm = psb_cd_get_mpic(desc_a) + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_sswapdatav + + +subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_sswapidxv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, totsnd_, totrcv_,& + & idx_pt, snd_pt, rcv_pt, n, pnti, data_ + + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_datav' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & mpi_real,rcvbuf,rvsz,& + & brvidx,mpi_real,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & mpi_real,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_sswapidxv diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 new file mode 100644 index 000000000..558796691 --- /dev/null +++ b/base/internals/psi_sswaptran.F90 @@ -0,0 +1,1008 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: psi_sswaptran.F90 +! +! Subroutine: psi_sswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswaptranm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer, pointer :: d_idx(:) + integer :: int_err(5) + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_sswaptranm + +subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_stranidxm + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag,n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_ + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_real,& + & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & mpi_real,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_stranidxm +! +! +! Subroutine: psi_sswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! D real(psb_spk_) +! Z complex(psb_spk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswaptranv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer, optional :: data + + ! locals + integer :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer, pointer :: d_idx(:) + integer :: int_err(5) + character(len=20) :: name + + info = 0 + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= 0) goto 9999 + + 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 psi_sswaptranv + + + +subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_stranidxv + use psb_error_mod + use psb_descriptor_type + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer :: np, me, nesd, nerv,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, data_, n + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + character(len=20) :: name + + info = 0 + name='psi_swap_tran' + call psb_erractionsave(err_act) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & mpi_real,& + & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm/=me)) then + p2ptag = krecvid(ictxt,proc_to_comm,me) + call mpi_irecv(sndbuf(snd_pt),nesd,& + & mpi_real,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm/=me)) then + p2ptag=ksendid(ictxt,proc_to_comm,me) + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & mpi_real,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & mpi_real,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(0,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + end if + + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + 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 psi_stranidxv diff --git a/base/modules/Makefile b/base/modules/Makefile index b98dfdc64..d56af5854 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -2,7 +2,7 @@ include ../../Make.inc MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \ psb_desc_type.o psb_spsb_mod.o psb_sort_mod.o\ - psb_serial_mod.o psb_tools_mod.o psb_avl_mod.o\ + psb_serial_mod.o psb_tools_mod.o psb_blacs_mod.o psb_avl_mod.o\ psb_error_mod.o psb_const_mod.o psb_inter_desc_type.o \ psb_comm_mod.o psb_psblas_mod.o psi_serial_mod.o psi_mod.o \ psb_check_mod.o psb_gps_mod.o @@ -26,7 +26,8 @@ lib: mpfobjs $(MODULES) $(OBJS) $(LIBMOD) psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_error_mod.o: psb_const_mod.o -psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o +psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o psb_blacs_mod.o +psb_blacs_mod.o: psb_const_mod.o psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_avl_mod.o diff --git a/base/modules/psb_blacs_mod.f90 b/base/modules/psb_blacs_mod.f90 new file mode 100644 index 000000000..d41db62d9 --- /dev/null +++ b/base/modules/psb_blacs_mod.f90 @@ -0,0 +1,4689 @@ +module psb_blacs_mod + use psb_const_mod + + interface gebs2d + module procedure igebs2ds, igebs2dv, igebs2dm,& + & dgebs2ds, dgebs2dv, dgebs2dm,& + & zgebs2ds, zgebs2dv, zgebs2dm,& + & sgebs2ds, sgebs2dv, sgebs2dm,& + & cgebs2ds, cgebs2dv, cgebs2dm + end interface + + interface gebr2d + module procedure igebr2ds, igebr2dv, igebr2dm,& + & dgebr2ds, dgebr2dv, dgebr2dm,& + & zgebr2ds, zgebr2dv, zgebr2dm,& + & sgebr2ds, sgebr2dv, sgebr2dm,& + & cgebr2ds, cgebr2dv, cgebr2dm + + end interface + + interface gesd2d + module procedure igesd2ds, igesd2dv, igesd2dm,& + & dgesd2ds, dgesd2dv, dgesd2dm,& + & zgesd2ds, zgesd2dv, zgesd2dm,& + & sgesd2ds, sgesd2dv, sgesd2dm,& + & cgesd2ds, cgesd2dv, cgesd2dm + end interface + + interface gerv2d + module procedure igerv2ds, igerv2dv, igerv2dm,& + & dgerv2ds, dgerv2dv, dgerv2dm,& + & zgerv2ds, zgerv2dv, zgerv2dm,& + & sgerv2ds, sgerv2dv, sgerv2dm,& + & cgerv2ds, cgerv2dv, cgerv2dm + end interface + + interface gsum2d + module procedure igsum2ds, igsum2dv, igsum2dm,& + & dgsum2ds, dgsum2dv, dgsum2dm,& + & zgsum2ds, zgsum2dv, zgsum2dm,& + & sgsum2ds, sgsum2dv, sgsum2dm,& + & cgsum2ds, cgsum2dv, cgsum2dm + end interface + + interface gamx2d + module procedure igamx2ds, igamx2dv, igamx2dm,& + & dgamx2ds, dgamx2dv, dgamx2dm,& + & zgamx2ds, zgamx2dv, zgamx2dm,& + & sgamx2ds, sgamx2dv, sgamx2dm,& + & cgamx2ds, cgamx2dv, cgamx2dm + end interface + + + interface gamn2d + module procedure igamn2ds, igamn2dv, igamn2dm,& + & dgamn2ds, dgamn2dv, dgamn2dm,& + & zgamn2ds, zgamn2dv, zgamn2dm,& + & sgamn2ds, sgamn2dv, sgamn2dm,& + & cgamn2ds, cgamn2dv, cgamn2dm + end interface +contains + + + + subroutine igebs2ds(ictxt,scope,dat,top) + integer, intent(in) :: ictxt,dat + character, intent(in) :: scope + character, intent(in), optional :: top + + character :: top_ + + interface + subroutine igebs2d(ictxt,scope,top,m,n,v,ld) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v + character, intent(in) :: scope, top + end subroutine igebs2d + end interface + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call igebs2d(ictxt,scope,top_,1,1,dat,1) + + end subroutine igebs2ds + + subroutine igebs2dv(ictxt,scope,dat,top) + integer, intent(in) :: ictxt,dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + + + interface + subroutine igebs2d(ictxt,scope,top,m,n,v,ld) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v(*) + character, intent(in) :: scope, top + end subroutine igebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call igebs2d(ictxt,scope,top_,size(dat,1),1,dat,size(dat,1)) + + end subroutine igebs2dv + + subroutine igebs2dm(ictxt,scope,dat,top) + integer, intent(in) :: ictxt,dat(:,:) + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine igebs2d(ictxt,scope,top,m,n,v,ld) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v(ld,*) + character, intent(in) :: scope, top + end subroutine igebs2d + end interface + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call igebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) + + end subroutine igebs2dm + + + + subroutine dgebs2ds(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v + character, intent(in) :: scope, top + end subroutine dgebs2d + end interface + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call dgebs2d(ictxt,scope,top_,1,1,dat,1) + + end subroutine dgebs2ds + + subroutine dgebs2dv(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v(*) + character, intent(in) :: scope, top + end subroutine dgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call dgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) + + end subroutine dgebs2dv + + subroutine dgebs2dm(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v(ld,*) + character, intent(in) :: scope, top + end subroutine dgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call dgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) + + end subroutine dgebs2dm + + + subroutine sgebs2ds(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v + character, intent(in) :: scope, top + end subroutine sgebs2d + end interface + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call sgebs2d(ictxt,scope,top_,1,1,dat,1) + + end subroutine sgebs2ds + + subroutine sgebs2dv(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v(*) + character, intent(in) :: scope, top + end subroutine sgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call sgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) + + end subroutine sgebs2dv + + subroutine sgebs2dm(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v(ld,*) + character, intent(in) :: scope, top + end subroutine sgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call sgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) + + end subroutine sgebs2dm + + + subroutine zgebs2ds(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v + character, intent(in) :: scope, top + end subroutine zgebs2d + end interface + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call zgebs2d(ictxt,scope,top_,1,1,dat,1) + + end subroutine zgebs2ds + + subroutine zgebs2dv(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v(*) + character, intent(in) :: scope, top + end subroutine zgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call zgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) + + end subroutine zgebs2dv + + subroutine zgebs2dm(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v(ld,*) + character, intent(in) :: scope, top + end subroutine zgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call zgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) + + end subroutine zgebs2dm + + subroutine cgebs2ds(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v + character, intent(in) :: scope, top + end subroutine cgebs2d + end interface + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call cgebs2d(ictxt,scope,top_,1,1,dat,1) + + end subroutine cgebs2ds + + subroutine cgebs2dv(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v(*) + character, intent(in) :: scope, top + end subroutine cgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call cgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) + + end subroutine cgebs2dv + + subroutine cgebs2dm(ictxt,scope,dat,top) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + + interface + subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v(ld,*) + character, intent(in) :: scope, top + end subroutine cgebs2d + end interface + + character :: top_ + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + + call cgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) + + end subroutine cgebs2dm + + + + + + subroutine dgebr2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgebr2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine dgebr2ds + + subroutine dgebr2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine dgebr2dv + + subroutine dgebr2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine dgebr2dm + + + subroutine sgebr2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgebr2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine sgebr2ds + + subroutine sgebr2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine sgebr2dv + + subroutine sgebr2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine sgebr2dm + + + subroutine zgebr2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgebr2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine zgebr2ds + + subroutine zgebr2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine zgebr2dv + + subroutine zgebr2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine zgebr2dm + + subroutine cgebr2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgebr2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine cgebr2ds + + subroutine cgebr2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine cgebr2dv + + subroutine cgebr2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine cgebr2dm + + + + subroutine igebr2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igebr2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine igebr2ds + + subroutine igebr2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine igebr2dv + + subroutine igebr2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igebr2d + end interface + + character :: top_ + integer :: nrows,ncols,myrow,mycol + integer :: rrt_, crt_ + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = 0 + case('C','c') + rrt_ = 0 + crt_ = mycol + case('A','a') + rrt_ = 0 + crt_ = 0 + case default + rrt_ = 0 + crt_ = 0 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine igebr2dm + + + + subroutine sgesd2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v + integer, intent(in) :: rd,cd + end subroutine sgesd2d + end interface + + call sgesd2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine sgesd2ds + + + subroutine sgesd2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v(*) + integer, intent(in) :: rd,cd + end subroutine sgesd2d + end interface + + call sgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine sgesd2dv + + subroutine sgesd2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + interface + subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(in) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine sgesd2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call sgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine sgesd2dm + + + subroutine dgesd2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v + integer, intent(in) :: rd,cd + end subroutine dgesd2d + end interface + + call dgesd2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine dgesd2ds + + + subroutine dgesd2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v(*) + integer, intent(in) :: rd,cd + end subroutine dgesd2d + end interface + + call dgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine dgesd2dv + + subroutine dgesd2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + interface + subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(in) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine dgesd2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call dgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine dgesd2dm + + + subroutine igesd2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + integer, intent(in) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v + integer, intent(in) :: rd,cd + end subroutine igesd2d + end interface + + call igesd2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine igesd2ds + + + subroutine igesd2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + integer, intent(in) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v(*) + integer, intent(in) :: rd,cd + end subroutine igesd2d + end interface + + call igesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine igesd2dv + + subroutine igesd2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + integer, intent(in) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(in) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine igesd2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call igesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine igesd2dm + + + + subroutine cgesd2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v + integer, intent(in) :: rd,cd + end subroutine cgesd2d + end interface + + call cgesd2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine cgesd2ds + + + subroutine cgesd2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v(*) + integer, intent(in) :: rd,cd + end subroutine cgesd2d + end interface + + call cgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine cgesd2dv + + subroutine cgesd2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(in) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine cgesd2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call cgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine cgesd2dm + + + subroutine zgesd2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v + integer, intent(in) :: rd,cd + end subroutine zgesd2d + end interface + + call zgesd2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine zgesd2ds + + + subroutine zgesd2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v(*) + integer, intent(in) :: rd,cd + end subroutine zgesd2d + end interface + + call zgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine zgesd2dv + + subroutine zgesd2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(in) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine zgesd2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call zgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine zgesd2dm + + + + subroutine sgerv2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v + integer, intent(in) :: rd,cd + end subroutine sgerv2d + end interface + + call sgerv2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine sgerv2ds + + + subroutine sgerv2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(*) + integer, intent(in) :: rd,cd + end subroutine sgerv2d + end interface + + call sgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine sgerv2dv + + subroutine sgerv2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine sgerv2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call sgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine sgerv2dm + + subroutine dgerv2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v + integer, intent(in) :: rd,cd + end subroutine dgerv2d + end interface + + call dgerv2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine dgerv2ds + + + subroutine dgerv2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(*) + integer, intent(in) :: rd,cd + end subroutine dgerv2d + end interface + + call dgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine dgerv2dv + + subroutine dgerv2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine dgerv2d + end interface + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call dgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine dgerv2dm + + + subroutine igerv2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v + integer, intent(in) :: rd,cd + end subroutine igerv2d + end interface + + call igerv2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine igerv2ds + + + subroutine igerv2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(*) + integer, intent(in) :: rd,cd + end subroutine igerv2d + end interface + + call igerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine igerv2dv + + subroutine igerv2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine igerv2d + end interface + + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call igerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine igerv2dm + + + + subroutine cgerv2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v + integer, intent(in) :: rd,cd + end subroutine cgerv2d + end interface + + call cgerv2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine cgerv2ds + + + subroutine cgerv2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(*) + integer, intent(in) :: rd,cd + end subroutine cgerv2d + end interface + + call cgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine cgerv2dv + + subroutine cgerv2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine cgerv2d + end interface + + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call cgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine cgerv2dm + + subroutine zgerv2ds(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer, intent(in) :: rdst,cdst + + interface + subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v + integer, intent(in) :: rd,cd + end subroutine zgerv2d + end interface + + call zgerv2d(ictxt,1,1,dat,1,rdst,cdst) + + end subroutine zgerv2ds + + + subroutine zgerv2dv(ictxt,dat,rdst,cdst) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in) :: rdst,cdst + + interface + subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(*) + integer, intent(in) :: rd,cd + end subroutine zgerv2d + end interface + + call zgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) + + end subroutine zgerv2dv + + subroutine zgerv2dm(ictxt,dat,rdst,cdst,m) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in) :: rdst,cdst + integer, intent(in), optional :: m + + integer :: m_ + + interface + subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(in) :: rd,cd + end subroutine zgerv2d + end interface + + + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + endif + + call zgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) + + end subroutine zgerv2dm + + + + subroutine sgsum2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgsum2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine sgsum2ds + + subroutine sgsum2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine sgsum2dv + + subroutine sgsum2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call sgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine sgsum2dm + + subroutine dgsum2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgsum2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine dgsum2ds + + subroutine dgsum2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine dgsum2dv + + subroutine dgsum2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call dgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine dgsum2dm + + + + subroutine igsum2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igsum2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine igsum2ds + + subroutine igsum2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine igsum2dv + + subroutine igsum2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call igsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine igsum2dm + + + subroutine cgsum2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgsum2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine cgsum2ds + + subroutine cgsum2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine cgsum2dv + + subroutine cgsum2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call cgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine cgsum2dm + + + subroutine zgsum2ds(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgsum2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) + + end subroutine zgsum2ds + + subroutine zgsum2dv(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) + + end subroutine zgsum2dv + + subroutine zgsum2dm(ictxt,scope,dat,top,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(ld,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgsum2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + call zgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) + + end subroutine zgsum2dm + + + subroutine sgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine sgamx2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call sgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call sgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine sgamx2ds + + + subroutine sgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine sgamx2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call sgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call sgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine sgamx2dv + + subroutine sgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + real(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgamx2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call sgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call sgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine sgamx2dm + + + subroutine dgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine dgamx2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine dgamx2ds + + + subroutine dgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine dgamx2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine dgamx2dv + + subroutine dgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + real(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgamx2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine dgamx2dm + + + + subroutine igamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine igamx2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine igamx2ds + + + subroutine igamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine igamx2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine igamx2dv + + subroutine igamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld,ldia + integer, intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igamx2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine igamx2dm + + + subroutine cgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine cgamx2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call cgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call cgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine cgamx2ds + + + subroutine cgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine cgamx2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call cgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call cgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine cgamx2dv + + subroutine cgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + complex(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgamx2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call cgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call cgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine cgamx2dm + + + subroutine zgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine zgamx2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine zgamx2ds + + + subroutine zgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine zgamx2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine zgamx2dv + + subroutine zgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + complex(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgamx2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine zgamx2dm + + + subroutine sgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine sgamn2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call sgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call sgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine sgamn2ds + + + subroutine sgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine sgamn2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call sgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call sgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine sgamn2dv + + subroutine sgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + real(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine sgamn2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call sgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call sgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine sgamn2dm + + subroutine dgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine dgamn2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine dgamn2ds + + + subroutine dgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + real(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine dgamn2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine dgamn2dv + + subroutine dgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + real(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine dgamn2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine dgamn2dm + + + subroutine igamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine igamn2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine igamn2ds + + + subroutine igamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld + integer, intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine igamn2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine igamn2dv + + subroutine igamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + integer, intent(in) :: ictxt,m,n,ld,ldia + integer, intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine igamn2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine igamn2dm + + + subroutine cgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine cgamn2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call cgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call cgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine cgamn2ds + + + subroutine cgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_spk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine cgamn2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call cgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call cgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine cgamn2dv + + subroutine cgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + complex(psb_spk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine cgamn2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call cgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call cgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine cgamn2dm + + subroutine zgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + integer, intent(inout), optional :: ria,cia + + interface + subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine zgamn2d + end interface + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1),cia_(1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).or.present(cia)) then + call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) + if (present(ria)) ria=ria_(1) + if (present(cia)) cia=cia_(1) + else + call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) + endif + end subroutine zgamn2ds + + + subroutine zgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + character, intent(in) :: scope + character, intent(in), optional :: top + integer, intent(inout), optional :: ria(:),cia(:) + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld + complex(psb_dpk_), intent(inout) :: v(*) + character, intent(in) :: scope, top + integer, intent(inout) :: ria(*),cia(*) + integer, intent(in) :: rrt,crt,ldia + end subroutine zgamn2d + end interface + + integer :: ldia_,ria_(1),cia_(1) + character :: top_ + integer :: rrt_, crt_ + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria,cia,min(size(ria),size(cia)),rrt_,crt_) + else + ldia_ = -1 + call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine zgamn2dv + + subroutine zgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + character, intent(in) :: scope + integer, intent(inout), optional :: ria(:,:),cia(:,:) + character, intent(in), optional :: top + integer, intent(in), optional :: rrt,crt + + interface + subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) + use psb_const_mod + integer, intent(in) :: ictxt,m,n,ld,ldia + complex(psb_dpk_), intent(inout) :: v(ld,*) + integer, intent(inout) :: ria(ldia,*),cia(ldia,*) + character, intent(in) :: scope, top + integer, intent(in) :: rrt,crt + end subroutine zgamn2d + end interface + + character :: top_ + integer :: rrt_, crt_ + integer :: ldia_,ria_(1,1),cia_(1,1) + integer :: nrows,ncols,myrow,mycol + + + call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) + select case(scope) + case('R','r') + rrt_ = myrow + crt_ = -1 + case('C','c') + rrt_ = -1 + crt_ = mycol + case('A','a') + rrt_ = -1 + crt_ = -1 + case default + rrt_ = -1 + crt_ = -1 + end select + + + if (present(top)) then + top_ = top + else + top_ = ' ' + endif + if (present(rrt)) then + rrt_ = rrt + endif + if (present(crt)) then + crt_ = crt + endif + + if (present(ria).and.present(cia)) then + call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) + else + ldia_ = -1 + call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& + & ria_,cia_,ldia_,rrt_,crt_) + end if + + end subroutine zgamn2dm + +end module psb_blacs_mod diff --git a/base/modules/psb_comm_mod.f90 b/base/modules/psb_comm_mod.f90 index 85300ae90..686c3794c 100644 --- a/base/modules/psb_comm_mod.f90 +++ b/base/modules/psb_comm_mod.f90 @@ -32,83 +32,135 @@ module psb_comm_mod interface psb_ovrl + subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + real(psb_spk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + end subroutine psb_sovrlm + subroutine psb_sovrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode + end subroutine psb_sovrlv subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) use psb_descriptor_type real(psb_dpk_), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info real(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,jx,ik,mode + integer, intent(in), optional :: update,jx,ik,mode end subroutine psb_dovrlm subroutine psb_dovrlv(x,desc_a,info,work,update,mode) use psb_descriptor_type real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info real(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,mode + integer, intent(in), optional :: update,mode end subroutine psb_dovrlv subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) use psb_descriptor_type - integer, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,jx,ik,mode + integer, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode end subroutine psb_iovrlm subroutine psb_iovrlv(x,desc_a,info,work,update,mode) use psb_descriptor_type - integer, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - real(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,mode + integer, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode end subroutine psb_iovrlv + subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_descriptor_type + complex(psb_spk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,jx,ik,mode + end subroutine psb_covrlm + subroutine psb_covrlv(x,desc_a,info,work,update,mode) + use psb_descriptor_type + complex(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(inout), optional :: work(:) + integer, intent(in), optional :: update,mode + end subroutine psb_covrlv subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) use psb_descriptor_type - complex(psb_dpk_), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + complex(psb_dpk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info complex(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,jx,ik,mode + integer, intent(in), optional :: update,jx,ik,mode end subroutine psb_zovrlm subroutine psb_zovrlv(x,desc_a,info,work,update,mode) use psb_descriptor_type - complex(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + complex(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info complex(psb_dpk_), intent(inout), optional :: work(:) - integer, intent(in), optional :: update,mode + integer, intent(in), optional :: update,mode end subroutine psb_zovrlv end interface interface psb_halo + subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + real(psb_spk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional :: alpha + real(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_shalom + subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional :: alpha + real(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_shalov subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_descriptor_type real(psb_dpk_), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info real(psb_dpk_), intent(in), optional :: alpha real(psb_dpk_), target, optional :: work(:) - integer, intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran end subroutine psb_dhalom subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) use psb_descriptor_type real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info real(psb_dpk_), intent(in), optional :: alpha - real(psb_dpk_), target, optional :: work(:) - integer, intent(in), optional :: mode,data - character, intent(in), optional :: tran + real(psb_dpk_), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_dhalov subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_descriptor_type integer, intent(inout) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - real(psb_dpk_), intent(in), optional :: alpha + real(psb_dpk_), intent(in), optional :: alpha integer, intent(inout), optional :: work(:) integer, intent(in), optional :: mode,jx,ik,data character, intent(in), optional :: tran @@ -118,30 +170,50 @@ module psb_comm_mod integer, intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - real(psb_dpk_), intent(in), optional :: alpha + real(psb_dpk_), intent(in), optional :: alpha integer, intent(inout), optional :: work(:) integer, intent(in), optional :: mode,data character, intent(in), optional :: tran end subroutine psb_ihalov + subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) + use psb_descriptor_type + complex(psb_spk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional :: alpha + complex(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_chalom + subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) + use psb_descriptor_type + complex(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional :: alpha + complex(psb_spk_), target, optional :: work(:) + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_chalov subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_descriptor_type complex(psb_dpk_), intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info complex(psb_dpk_), intent(in), optional :: alpha complex(psb_dpk_), target, optional :: work(:) - integer, intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran + integer, intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran end subroutine psb_zhalom subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) use psb_descriptor_type complex(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info complex(psb_dpk_), intent(in), optional :: alpha complex(psb_dpk_), target, optional :: work(:) - integer, intent(in), optional :: mode,data - character, intent(in), optional :: tran + integer, intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_zhalov end interface @@ -214,6 +286,22 @@ module psb_comm_mod integer, intent(out) :: info integer, intent(in), optional :: root end subroutine psb_igatherv + subroutine psb_sgatherm(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(psb_spk_), intent(in) :: locx(:,:) + real(psb_spk_), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_sgatherm + subroutine psb_sgatherv(globx, locx, desc_a, info, root) + use psb_descriptor_type + real(psb_spk_), intent(in) :: locx(:) + real(psb_spk_), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_sgatherv subroutine psb_dgatherm(globx, locx, desc_a, info, root) use psb_descriptor_type real(psb_dpk_), intent(in) :: locx(:,:) @@ -230,6 +318,22 @@ module psb_comm_mod integer, intent(out) :: info integer, intent(in), optional :: root end subroutine psb_dgatherv + subroutine psb_cgatherm(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(psb_spk_), intent(in) :: locx(:,:) + complex(psb_spk_), intent(out) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_cgatherm + subroutine psb_cgatherv(globx, locx, desc_a, info, root) + use psb_descriptor_type + complex(psb_spk_), intent(in) :: locx(:) + complex(psb_spk_), intent(out) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, intent(in), optional :: root + end subroutine psb_cgatherv subroutine psb_zgatherm(globx, locx, desc_a, info, root) use psb_descriptor_type complex(psb_dpk_), intent(in) :: locx(:,:) diff --git a/base/modules/psb_const_mod.f90 b/base/modules/psb_const_mod.f90 index dd46b98f7..65c1a54a0 100644 --- a/base/modules/psb_const_mod.f90 +++ b/base/modules/psb_const_mod.f90 @@ -32,20 +32,26 @@ module psb_const_mod ! - ! This must be the kind parameter corresponding to MPI_DOUBLE_PRECISION. + ! This must be the kind parameter corresponding to MPI_DOUBLE_PRECISION + ! and MPI_REAL ! integer, parameter :: psb_dpk_ = kind(1.d0) - integer :: psb_sizeof_dp, psb_sizeof_int + integer, parameter :: psb_spk_ = kind(1.e0) + integer :: psb_sizeof_dp, psb_sizeof_int, psb_sizeof_sp ! ! Handy & miscellaneous constants ! - integer, parameter :: izero=0, ione=1 - integer, parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0 - real(psb_dpk_), parameter :: dzero=0.d0, done=1.d0 - complex(psb_dpk_), parameter :: zzero=(0.d0,0.0d0) - complex(psb_dpk_), parameter :: zone=(1.d0,0.0d0) - real(psb_dpk_), parameter :: epstol=1.d-32, psb_percent_=0.7 - character, parameter :: psb_all_='A', psb_topdef_=' ' + integer, parameter :: izero=0, ione=1 + integer, parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0 + real(psb_spk_), parameter :: szero=0.e0, sone=1.e0 + real(psb_dpk_), parameter :: dzero=0.d0, done=1.d0 + complex(psb_spk_), parameter :: czero=(0.e0,0.0e0) + complex(psb_spk_), parameter :: cone=(1.e0,0.0e0) + complex(psb_dpk_), parameter :: zzero=(0.d0,0.0d0) + complex(psb_dpk_), parameter :: zone=(1.d0,0.0d0) + real(psb_dpk_), parameter :: epstol=1.d-32, psb_percent_=0.7 + real(psb_spk_), parameter :: s_epstol=1.e-16 ! How to choose this? + character, parameter :: psb_all_='A', psb_topdef_=' ' end module psb_const_mod diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index c4a0676ca..3c72938c2 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -276,6 +276,7 @@ contains call blacs_gridinfo(ictxt,nprow,npcol,me,mypcol) #endif + if(error_status > 0) then if(verbosity_level > 1) then diff --git a/base/modules/psb_inter_desc_type.f90 b/base/modules/psb_inter_desc_type.f90 index 73c681c47..ec0e82178 100644 --- a/base/modules/psb_inter_desc_type.f90 +++ b/base/modules/psb_inter_desc_type.f90 @@ -36,17 +36,20 @@ ! to different spaces. ! module psb_inter_descriptor_type - use psb_spmat_type, only : psb_dspmat_type, psb_zspmat_type + use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,& + & psb_cspmat_type, psb_zspmat_type use psb_descriptor_type, only : psb_desc_type ! Inter-descriptor mapping data structures. - integer, parameter :: psb_map_kind_ = 1 - integer, parameter :: psb_map_data_ = 2 - integer, parameter :: psb_map_integer_ = 1 - integer, parameter :: psb_map_double_ = 2 - integer, parameter :: psb_map_complex_ = 3 + integer, parameter :: psb_map_kind_ = 1 + integer, parameter :: psb_map_data_ = 2 + integer, parameter :: psb_map_integer_ = 1 + integer, parameter :: psb_map_single_ = 2 + integer, parameter :: psb_map_double_ = 3 + integer, parameter :: psb_map_complex_ = 4 + integer, parameter :: psb_map_double_complex_ = 5 integer, parameter :: psb_fw_tmp_kind_ = 5 integer, parameter :: psb_fw_tmp_sz_ = 6 @@ -55,9 +58,18 @@ module psb_inter_descriptor_type integer, parameter :: psb_itd_data_size_=20 + type psb_s_map_type + type(psb_sspmat_type) :: map_fw, map_bk + end type psb_s_map_type + type psb_d_map_type type(psb_dspmat_type) :: map_fw, map_bk end type psb_d_map_type + + type psb_c_map_type + type(psb_cspmat_type) :: map_fw, map_bk + end type psb_c_map_type + type psb_z_map_type type(psb_zspmat_type) :: map_fw, map_bk end type psb_z_map_type @@ -67,16 +79,20 @@ module psb_inter_descriptor_type type(psb_desc_type), pointer :: desc_1=>null(), desc_2=>null() integer, allocatable :: exch_fw_idx(:), exch_bk_idx(:) type(psb_desc_type) :: desc_fw, desc_bk + type(psb_s_map_type) :: smap type(psb_d_map_type) :: dmap + type(psb_c_map_type) :: cmap type(psb_z_map_type) :: zmap end type psb_inter_desc_type interface psb_forward_map - module procedure psb_d_forward_map, psb_z_forward_map + module procedure psb_s_forward_map, psb_c_forward_map, & + & psb_d_forward_map, psb_z_forward_map end interface interface psb_backward_map - module procedure psb_d_backward_map, psb_z_backward_map + module procedure psb_s_backward_map, psb_c_backward_map,& + & psb_d_backward_map, psb_z_backward_map end interface interface psb_is_ok_desc @@ -88,17 +104,21 @@ module psb_inter_descriptor_type end interface interface psb_inter_desc - module procedure psb_d_inter_desc, psb_d_inter_desc_noidx,& + module procedure psb_s_inter_desc, psb_s_inter_desc_noidx,& + & psb_d_inter_desc, psb_d_inter_desc_noidx,& + & psb_c_inter_desc, psb_c_inter_desc_noidx,& & psb_z_inter_desc, psb_z_inter_desc_noidx end interface interface psb_sizeof module procedure psb_itd_sizeof,& + & psb_s_map_sizeof, psb_c_map_sizeof,& & psb_d_map_sizeof, psb_z_map_sizeof end interface interface psb_linmap - module procedure psb_d_apply_linmap, psb_z_apply_linmap + module procedure psb_s_apply_linmap, psb_c_apply_linmap,& + & psb_d_apply_linmap, psb_z_apply_linmap end interface contains @@ -201,7 +221,8 @@ contains psb_is_ok_inter_desc = .false. if (.not.allocated(desc%itd_data)) return select case(desc%itd_data(psb_map_data_)) - case(psb_map_integer_, psb_map_double_, psb_map_complex_) + case(psb_map_integer_, psb_map_single_, psb_map_complex_,& + & psb_map_double_, psb_map_double_complex_) ! Ok go ahead case default ! Since it's false so far, simply return @@ -215,6 +236,20 @@ contains end function psb_is_ok_inter_desc + function psb_s_map_sizeof(map) + use psb_spmat_type + implicit none + type(psb_s_map_type), intent(in) :: map + Integer :: psb_s_map_sizeof + integer :: val + + val = 0 + + val = val + psb_sizeof(map%map_fw) + val = val + psb_sizeof(map%map_bk) + psb_s_map_sizeof = val + end function psb_s_map_sizeof + function psb_d_map_sizeof(map) use psb_spmat_type implicit none @@ -229,6 +264,20 @@ contains psb_d_map_sizeof = val end function psb_d_map_sizeof + function psb_c_map_sizeof(map) + use psb_spmat_type + implicit none + type(psb_c_map_type), intent(in) :: map + Integer :: psb_c_map_sizeof + integer :: val + + val = 0 + + val = val + psb_sizeof(map%map_fw) + val = val + psb_sizeof(map%map_bk) + psb_c_map_sizeof = val + end function psb_c_map_sizeof + function psb_z_map_sizeof(map) use psb_spmat_type implicit none @@ -263,6 +312,106 @@ contains psb_itd_sizeof = val end function psb_itd_sizeof + function psb_s_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk) + use psb_spmat_type + use psb_descriptor_type + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type) :: psb_s_inter_desc + type(psb_desc_type), target :: desc1, desc2 + type(psb_sspmat_type), intent(in) :: map_fw, map_bk + integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:) + ! + type(psb_inter_desc_type) :: this + integer :: info + character(len=20), parameter :: name='psb_inter_desc' + + info = 0 + if (psb_is_ok_desc(desc1)) then + this%desc_1=>desc1 + else + info = 2 + endif + if (psb_is_ok_desc(desc2)) then + this%desc_2=>desc2 + else + info = 3 + endif + + if (info == 0) call psb_sp_clone(map_fw,this%smap%map_fw,info) + if (info == 0) call psb_sp_clone(map_bk,this%smap%map_bk,info) + if (info == 0) call psb_safe_cpy(idx_fw,this%exch_fw_idx,info) + if (info == 0) call psb_safe_cpy(idx_bk,this%exch_bk_idx,info) + if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == 0) then + call psb_cd_set_map_kind(map_kind, this) + call psb_cd_set_map_data(psb_map_single_, this) +!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) +!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) + end if + if (info /= 0) then + write(0,*) trim(name),' Invalid descriptor input' + return + end if + + psb_s_inter_desc = this + + end function psb_s_inter_desc + + function psb_s_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk) + use psb_spmat_type + use psb_descriptor_type + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type) :: psb_s_inter_desc_noidx + type(psb_desc_type), target :: desc1, desc2 + type(psb_sspmat_type), intent(in) :: map_fw, map_bk + integer, intent(in) :: map_kind + ! + type(psb_inter_desc_type) :: this + integer :: info + character(len=20), parameter :: name='psb_inter_desc' + + info = 0 + select case(map_kind) + case (psb_map_aggr_) + ! OK + case default + write(0,*) 'Bad map kind into psb_inter_desc ',map_kind + info = 1 + end select + + if (psb_is_ok_desc(desc1)) then + this%desc_1=>desc1 + else + info = 2 + endif + if (psb_is_ok_desc(desc2)) then + this%desc_2=>desc2 + else + info = 3 + endif + + if (info == 0) call psb_sp_clone(map_fw,this%smap%map_fw,info) + if (info == 0) call psb_sp_clone(map_bk,this%smap%map_bk,info) + if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == 0) then + call psb_cd_set_map_kind(map_kind, this) + call psb_cd_set_map_data(psb_map_single_, this) +!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) +!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) + end if + if (info /= 0) then + write(0,*) trim(name),' Invalid descriptor input' + return + end if + + psb_s_inter_desc_noidx = this + + end function psb_s_inter_desc_noidx + function psb_d_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk) use psb_spmat_type use psb_descriptor_type @@ -363,6 +512,107 @@ contains end function psb_d_inter_desc_noidx + function psb_c_inter_desc(map_kind,desc1, desc2, map_fw, map_bk, idx_fw, idx_bk) + use psb_spmat_type + use psb_descriptor_type + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type) :: psb_c_inter_desc + type(psb_desc_type), target :: desc1, desc2 + type(psb_cspmat_type), intent(in) :: map_fw, map_bk + integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:) + ! + type(psb_inter_desc_type) :: this + integer :: info + character(len=20), parameter :: name='psb_inter_desc' + + info = 0 + if (psb_is_ok_desc(desc1)) then + this%desc_1=>desc1 + else + info = 2 + endif + if (psb_is_ok_desc(desc2)) then + this%desc_2=>desc2 + else + info = 3 + endif + + if (info == 0) call psb_sp_clone(map_fw,this%cmap%map_fw,info) + if (info == 0) call psb_sp_clone(map_bk,this%cmap%map_bk,info) + if (info == 0) call psb_safe_cpy(idx_fw,this%exch_fw_idx,info) + if (info == 0) call psb_safe_cpy(idx_bk,this%exch_bk_idx,info) + if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == 0) then + call psb_cd_set_map_kind(map_kind, this) + call psb_cd_set_map_data(psb_map_complex_, this) +!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) +!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) + end if + if (info /= 0) then + write(0,*) trim(name),' Invalid descriptor input' + return + end if + + psb_c_inter_desc = this + + end function psb_c_inter_desc + + function psb_c_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk) + use psb_spmat_type + use psb_descriptor_type + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type) :: psb_c_inter_desc_noidx + type(psb_desc_type), target :: desc1, desc2 + type(psb_cspmat_type), intent(in) :: map_fw, map_bk + integer, intent(in) :: map_kind + ! + type(psb_inter_desc_type) :: this + integer :: info + character(len=20), parameter :: name='psb_inter_desc' + + info = 0 + select case(map_kind) + case (psb_map_aggr_) + ! OK + case default + write(0,*) 'Bad map kind into psb_inter_desc ',map_kind + info = 1 + end select + + if (psb_is_ok_desc(desc1)) then + this%desc_1=>desc1 + else + info = 2 + endif + if (psb_is_ok_desc(desc2)) then + this%desc_2=>desc2 + else + info = 3 + endif + + if (info == 0) call psb_sp_clone(map_fw,this%cmap%map_fw,info) + if (info == 0) call psb_sp_clone(map_bk,this%cmap%map_bk,info) + if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == 0) then + call psb_cd_set_map_kind(map_kind, this) + call psb_cd_set_map_data(psb_map_complex_, this) +!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) +!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) + end if + if (info /= 0) then + write(0,*) trim(name),' Invalid descriptor input' + return + end if + + psb_c_inter_desc_noidx = this + + end function psb_c_inter_desc_noidx + + function psb_z_inter_desc(map_kind,desc1, desc2, map_fw, map_bk, idx_fw, idx_bk) use psb_spmat_type use psb_descriptor_type @@ -397,7 +647,7 @@ contains if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == 0) then call psb_cd_set_map_kind(map_kind, this) - call psb_cd_set_map_data(psb_map_complex_, this) + call psb_cd_set_map_data(psb_map_double_complex_, this) !!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) !!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) end if @@ -450,7 +700,7 @@ contains if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == 0) then call psb_cd_set_map_kind(map_kind, this) - call psb_cd_set_map_data(psb_map_complex_, this) + call psb_cd_set_map_data(psb_map_double_complex_, this) !!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this) !!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this) end if @@ -466,6 +716,151 @@ contains + ! + ! Takes a vector X from space desc%desc_1 and maps it onto + ! desc%desc_2 under desc%map_fw possibly with communication + ! due to exch_fw_idx + ! + subroutine psb_s_forward_map(alpha,x,beta,y,desc,info,work) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type), intent(in) :: desc + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) + + ! + real(psb_spk_), allocatable :: xt(:) + integer :: itsz, i, j,totxch,totsnd,totrcv,& + & map_kind, map_data + character(len=20), parameter :: name='psb_forward_map' + + info = 0 + if (.not.psb_is_asb_desc(desc)) then + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end if + + itsz = psb_cd_get_fw_tmp_sz(desc) + map_kind = psb_cd_get_map_kind(desc) + map_data = psb_cd_get_map_data(desc) + if (map_data /= psb_map_single_) then + write(0,*) trim(name),' Invalid descriptor inupt: map_data', & + & map_data,psb_map_single_ + info = 1 + return + endif + + select case(map_kind) + case(psb_map_aggr_) + ! Ok, we just need to call a halo update on the base desc + ! and a matrix-vector product. + call psb_halo(x,desc%desc_1,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%smap%map_fw,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + case(psb_map_gen_linear_) + + call psb_linmap(alpha,x,beta,y,desc%smap%map_fw,& + & desc%desc_fw,desc%desc_1,desc%desc_2) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + + case default + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end select + + end subroutine psb_s_forward_map + + + ! + ! Takes a vector X from space desc%desc_2 and maps it onto + ! desc%desc_1 under desc%map_bk possibly with communication + ! due to exch_bk_idx + ! + subroutine psb_s_backward_map(alpha,x,beta,y,desc,info,work) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type), intent(in) :: desc + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) + + ! + real(psb_spk_), allocatable :: xt(:) + integer :: itsz, i, j,totxch,totsnd,totrcv,& + & map_kind, map_data + character(len=20), parameter :: name='psb_backward_map' + + info = 0 + if (.not.psb_is_asb_desc(desc)) then + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end if + + itsz = psb_cd_get_bk_tmp_sz(desc) + map_kind = psb_cd_get_map_kind(desc) + map_data = psb_cd_get_map_data(desc) + if (map_data /= psb_map_single_) then + write(0,*) trim(name),' Invalid descriptor inupt: map_data',& + & map_data,psb_map_single_ + info = 1 + return + endif + + select case(map_kind) + case(psb_map_aggr_) + ! Ok, we just need to call a halo update and a matrix-vector product. + call psb_halo(x,desc%desc_2,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%smap%map_bk,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + + case(psb_map_gen_linear_) + call psb_linmap(alpha,x,beta,y,desc%smap%map_bk,& + & desc%desc_bk,desc%desc_2,desc%desc_1) + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + case default + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end select + + end subroutine psb_s_backward_map + + ! ! Takes a vector X from space desc%desc_1 and maps it onto ! desc%desc_2 under desc%map_fw possibly with communication @@ -611,6 +1006,149 @@ contains end subroutine psb_d_backward_map + ! + ! Takes a vector X from space desc%desc_1 and maps it onto + ! desc%desc_2 under desc%map_fw possibly with communication + ! due to exch_fw_idx + ! + subroutine psb_c_forward_map(alpha,x,beta,y,desc,info,work) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type), intent(in) :: desc + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_spk_), optional :: work(:) + + ! + complex(psb_spk_), allocatable :: xt(:) + integer :: itsz, i, j,totxch,totsnd,totrcv,& + & map_kind, map_data + character(len=20), parameter :: name='psb_forward_map' + + info = 0 + if (.not.psb_is_asb_desc(desc)) then + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end if + + itsz = psb_cd_get_fw_tmp_sz(desc) + map_kind = psb_cd_get_map_kind(desc) + map_data = psb_cd_get_map_data(desc) + if (map_data /= psb_map_complex_) then + write(0,*) trim(name),' Invalid descriptor inupt: map_data',& + & map_data,psb_map_complex_ + info = 1 + return + endif + + select case(map_kind) + case(psb_map_aggr_) + ! Ok, we just need to call a halo update and a matrix-vector product. + call psb_halo(x,desc%desc_1,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%cmap%map_fw,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + case(psb_map_gen_linear_) + call psb_linmap(alpha,x,beta,y,desc%cmap%map_fw,& + & desc%desc_fw,desc%desc_1,desc%desc_2) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + case default + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end select + + end subroutine psb_c_forward_map + + + ! + ! Takes a vector X from space desc%desc_2 and maps it onto + ! desc%desc_1 under desc%map_bk possibly with communication + ! due to exch_bk_idx + ! + subroutine psb_c_backward_map(alpha,x,beta,y,desc,info,work) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + type(psb_inter_desc_type), intent(in) :: desc + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_spk_), optional :: work(:) + + ! + complex(psb_spk_), allocatable :: xt(:) + integer :: itsz, i, j,totxch,totsnd,totrcv,& + & map_kind, map_data + character(len=20), parameter :: name='psb_backward_map' + + info = 0 + if (.not.psb_is_asb_desc(desc)) then + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end if + + itsz = psb_cd_get_bk_tmp_sz(desc) + map_kind = psb_cd_get_map_kind(desc) + map_data = psb_cd_get_map_data(desc) + if (map_data /= psb_map_complex_) then + write(0,*) trim(name),' Invalid descriptor inupt: map_data',& + & map_data,psb_map_complex_ + info = 1 + return + endif + + select case(map_kind) + case(psb_map_aggr_) + ! Ok, we just need to call a halo update and a matrix-vector product. + call psb_halo(x,desc%desc_2,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%cmap%map_bk,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + + case(psb_map_gen_linear_) + call psb_linmap(alpha,x,beta,y,desc%cmap%map_bk,& + & desc%desc_bk,desc%desc_1,desc%desc_2) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if + + case default + write(0,*) trim(name),' Invalid descriptor inupt' + info = 1 + return + end select + + end subroutine psb_c_backward_map + + ! ! Takes a vector X from space desc%desc_1 and maps it onto ! desc%desc_2 under desc%map_fw possibly with communication @@ -646,9 +1184,9 @@ contains itsz = psb_cd_get_fw_tmp_sz(desc) map_kind = psb_cd_get_map_kind(desc) map_data = psb_cd_get_map_data(desc) - if (map_data /= psb_map_complex_) then + if (map_data /= psb_map_double_complex_) then write(0,*) trim(name),' Invalid descriptor inupt: map_data',& - & map_data,psb_map_complex_ + & map_data,psb_map_double_complex_ info = 1 return endif @@ -717,9 +1255,9 @@ contains itsz = psb_cd_get_bk_tmp_sz(desc) map_kind = psb_cd_get_map_kind(desc) map_data = psb_cd_get_map_data(desc) - if (map_data /= psb_map_complex_) then + if (map_data /= psb_map_double_complex_) then write(0,*) trim(name),' Invalid descriptor inupt: map_data',& - & map_data,psb_map_complex_ + & map_data,psb_map_double_complex_ info = 1 return endif @@ -755,6 +1293,34 @@ contains + subroutine psb_s_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(inout) :: x(:),y(:) + type(psb_sspmat_type), intent(in) :: a_map + type(psb_desc_type), intent(in) :: cd_xt,descin, descout + + integer :: nrt, nct, info + real(psb_spk_), allocatable :: tmp(:) + + nrt = psb_cd_get_local_rows(cd_xt) + nct = psb_cd_get_local_cols(cd_xt) + allocate(tmp(nct),stat=info) + if (info == 0) tmp(1:nrt) = x(1:nrt) + if (info == 0) call psb_halo(tmp,cd_xt,info) + if (info == 0) call psb_csmm(alpha,a_map,tmp,beta,y,info) + if (info /= 0) then + write(0,*) 'Error in apply_map' + endif + + end subroutine psb_s_apply_linmap + + subroutine psb_d_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout) use psb_spmat_type use psb_descriptor_type @@ -762,13 +1328,13 @@ contains use psb_serial_mod use psi_mod implicit none - real(kind(1.d0)), intent(in) :: alpha,beta - real(kind(1.d0)), intent(inout) :: x(:),y(:) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(inout) :: x(:),y(:) type(psb_dspmat_type), intent(in) :: a_map type(psb_desc_type), intent(in) :: cd_xt,descin, descout integer :: nrt, nct, info - real(kind(1.d0)), allocatable :: tmp(:) + real(psb_dpk_), allocatable :: tmp(:) nrt = psb_cd_get_local_rows(cd_xt) nct = psb_cd_get_local_cols(cd_xt) @@ -783,6 +1349,33 @@ contains end subroutine psb_d_apply_linmap + subroutine psb_c_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout) + use psb_spmat_type + use psb_descriptor_type + use psb_comm_mod + use psb_serial_mod + use psi_mod + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:),y(:) + type(psb_cspmat_type), intent(in) :: a_map + type(psb_desc_type), intent(in) :: cd_xt,descin, descout + + integer :: nrt, nct, info + complex(psb_spk_), allocatable :: tmp(:) + + nrt = psb_cd_get_local_rows(cd_xt) + nct = psb_cd_get_local_cols(cd_xt) + allocate(tmp(nct),stat=info) + if (info == 0) tmp(1:nrt) = x(1:nrt) + if (info == 0) call psb_halo(tmp,cd_xt,info) + if (info == 0) call psb_csmm(alpha,a_map,tmp,beta,y,info) + if (info /= 0) then + write(0,*) 'Error in apply_map' + endif + + end subroutine psb_c_apply_linmap + subroutine psb_z_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout) use psb_spmat_type use psb_descriptor_type @@ -790,13 +1383,13 @@ contains use psb_serial_mod use psi_mod implicit none - complex(kind(1.d0)), intent(in) :: alpha,beta - complex(kind(1.d0)), intent(inout) :: x(:),y(:) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(inout) :: x(:),y(:) type(psb_zspmat_type), intent(in) :: a_map type(psb_desc_type), intent(in) :: cd_xt,descin, descout integer :: nrt, nct, info - complex(kind(1.d0)), allocatable :: tmp(:) + complex(psb_dpk_), allocatable :: tmp(:) nrt = psb_cd_get_local_rows(cd_xt) nct = psb_cd_get_local_cols(cd_xt) diff --git a/base/modules/psb_penv_mod.F90 b/base/modules/psb_penv_mod.F90 index a3f8fa34c..94dc27471 100644 --- a/base/modules/psb_penv_mod.F90 +++ b/base/modules/psb_penv_mod.F90 @@ -44,6 +44,7 @@ end module mpi module psb_penv_mod use psb_const_mod + use psb_blacs_mod interface psb_init module procedure psb_init @@ -73,12 +74,16 @@ module psb_penv_mod module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,& & psb_dbcasts, psb_dbcastv, psb_dbcastm,& & psb_zbcasts, psb_zbcastv, psb_zbcastm,& + & psb_sbcasts, psb_sbcastv, psb_sbcastm,& + & psb_cbcasts, psb_cbcastv, psb_cbcastm,& & psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv end interface interface psb_snd module procedure psb_isnds, psb_isndv, psb_isndm,& + & psb_ssnds, psb_ssndv, psb_ssndm,& + & psb_csnds, psb_csndv, psb_csndm,& & psb_dsnds, psb_dsndv, psb_dsndm,& & psb_zsnds, psb_zsndv, psb_zsndm,& & psb_hsnds, psb_lsnds @@ -86,6 +91,8 @@ module psb_penv_mod interface psb_rcv module procedure psb_ircvs, psb_ircvv, psb_ircvm,& + & psb_srcvs, psb_srcvv, psb_srcvm,& + & psb_crcvs, psb_crcvv, psb_crcvm,& & psb_drcvs, psb_drcvv, psb_drcvm,& & psb_zrcvs, psb_zrcvv, psb_zrcvm,& & psb_hrcvs, psb_lrcvs @@ -93,79 +100,42 @@ module psb_penv_mod interface psb_max module procedure psb_imaxs, psb_imaxv, psb_imaxm,& + & psb_smaxs, psb_smaxv, psb_smaxm,& & psb_dmaxs, psb_dmaxv, psb_dmaxm end interface interface psb_min module procedure psb_imins, psb_iminv, psb_iminm,& + & psb_smins, psb_sminv, psb_sminm,& & psb_dmins, psb_dminv, psb_dminm end interface interface psb_amx module procedure psb_iamxs, psb_iamxv, psb_iamxm,& + & psb_samxs, psb_samxv, psb_samxm,& + & psb_camxs, psb_camxv, psb_camxm,& & psb_damxs, psb_damxv, psb_damxm,& & psb_zamxs, psb_zamxv, psb_zamxm end interface interface psb_amn module procedure psb_iamns, psb_iamnv, psb_iamnm,& + & psb_samns, psb_samnv, psb_samnm,& + & psb_camns, psb_camnv, psb_camnm,& & psb_damns, psb_damnv, psb_damnm,& & psb_zamns, psb_zamnv, psb_zamnm end interface interface psb_sum module procedure psb_isums, psb_isumv, psb_isumm,& + & psb_ssums, psb_ssumv, psb_ssumm,& + & psb_csums, psb_csumv, psb_csumm,& & psb_dsums, psb_dsumv, psb_dsumm,& & psb_zsums, psb_zsumv, psb_zsumm end interface -#if !defined(SERIAL_MPI) - - interface gebs2d - module procedure igebs2ds, igebs2dv, igebs2dm,& - & dgebs2ds, dgebs2dv, dgebs2dm,& - & zgebs2ds, zgebs2dv, zgebs2dm - end interface - - interface gebr2d - module procedure igebr2ds, igebr2dv, igebr2dm,& - & dgebr2ds, dgebr2dv, dgebr2dm,& - & zgebr2ds, zgebr2dv, zgebr2dm - end interface - - interface gesd2d - module procedure igesd2ds, igesd2dv, igesd2dm,& - & dgesd2ds, dgesd2dv, dgesd2dm,& - & zgesd2ds, zgesd2dv, zgesd2dm - end interface - - interface gerv2d - module procedure igerv2ds, igerv2dv, igerv2dm,& - & dgerv2ds, dgerv2dv, dgerv2dm,& - & zgerv2ds, zgerv2dv, zgerv2dm - end interface - - interface gsum2d - module procedure igsum2ds, igsum2dv, igsum2dm,& - & dgsum2ds, dgsum2dv, dgsum2dm,& - & zgsum2ds, zgsum2dv, zgsum2dm - end interface - - interface gamx2d - module procedure igamx2ds, igamx2dv, igamx2dm,& - & dgamx2ds, dgamx2dv, dgamx2dm,& - & zgamx2ds, zgamx2dv, zgamx2dm - end interface - - - interface gamn2d - module procedure igamn2ds, igamn2dv, igamn2dm,& - & dgamn2ds, dgamn2dv, dgamn2dm,& - & zgamn2ds, zgamn2dv, zgamn2dm - end interface -#endif #if defined(SERIAL_MPI) integer, private, save :: nctxt=0 @@ -189,10 +159,12 @@ contains subroutine psi_get_sizes() use psb_const_mod - real(psb_dpk_) :: v(2) + real(psb_dpk_) :: dv(2) + real(psb_spk_) :: sv(2) integer :: iv(2) - call psi_c_diffadd(v(1),v(2),psb_sizeof_dp) + call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp) + call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp) call psi_c_diffadd(iv(1),iv(2),psb_sizeof_int) end subroutine psi_get_sizes @@ -378,6 +350,81 @@ contains end subroutine psb_ibcastm + subroutine psb_sbcasts(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_sbcasts + + + subroutine psb_sbcastv(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_sbcastv + + subroutine psb_sbcastm(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_sbcastm + + + subroutine psb_dbcasts(ictxt,dat,root) integer, intent(in) :: ictxt real(psb_dpk_), intent(inout) :: dat @@ -452,6 +499,78 @@ contains end subroutine psb_dbcastm + subroutine psb_cbcasts(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_cbcasts + + subroutine psb_cbcastv(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_cbcastv + + subroutine psb_cbcastm(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + + if (iam==root_) then + call gebs2d(ictxt,'A',dat) + else + call gebr2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_cbcastm + subroutine psb_zbcasts(ictxt,dat,root) integer, intent(in) :: ictxt complex(psb_dpk_), intent(inout) :: dat @@ -677,6 +796,7 @@ contains endif #endif end subroutine psb_imaxs + subroutine psb_imaxv(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -717,6 +837,7 @@ contains endif #endif end subroutine psb_imaxv + subroutine psb_imaxm(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -758,6 +879,124 @@ contains #endif end subroutine psb_imaxm + subroutine psb_smaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, icomm,info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_max,icomm,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_max,root_,icomm,info) + dat = dat_ + endif +#endif + end subroutine psb_smaxs + + subroutine psb_smaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, icomm, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info ==0) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) + else + if (iam==root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,icomm,info) + end if + endif +#endif + end subroutine psb_smaxv + + subroutine psb_smaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, icomm, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info ==0)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) + else + if (iam==root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,icomm,info) + end if + endif +#endif + end subroutine psb_smaxm + subroutine psb_dmaxs(ictxt,dat,root) #ifdef MPI_MOD use mpi @@ -832,6 +1071,7 @@ contains endif #endif end subroutine psb_dmaxv + subroutine psb_dmaxm(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -947,6 +1187,7 @@ contains endif #endif end subroutine psb_iminv + subroutine psb_iminm(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -988,6 +1229,125 @@ contains #endif end subroutine psb_iminm + subroutine psb_smins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, icomm,info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_min,icomm,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_min,root_,icomm,info) + dat = dat_ + endif +#endif + end subroutine psb_smins + + subroutine psb_sminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, icomm, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info ==0) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) + else + if (iam==root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,icomm,info) + end if + endif +#endif + end subroutine psb_sminv + + subroutine psb_sminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, icomm, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + call psb_get_mpicomm(ictxt,icomm) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info ==0) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) + else + if (iam==root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,icomm,info) + end if + endif +#endif + + end subroutine psb_sminm + subroutine psb_dmins(ictxt,dat,root) #ifdef MPI_MOD use mpi @@ -1021,6 +1381,7 @@ contains endif #endif end subroutine psb_dmins + subroutine psb_dminv(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -1062,6 +1423,7 @@ contains endif #endif end subroutine psb_dminv + subroutine psb_dminm(ictxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD @@ -1190,6 +1552,90 @@ contains #endif end subroutine psb_iamxm + subroutine psb_samxs(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia + + integer :: root_ + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samxs + + subroutine psb_samxv(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:) + + integer :: root_ + integer, allocatable :: cia(:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia))) + call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samxv + + subroutine psb_samxm(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:,:) + + integer :: root_ + integer, allocatable :: cia(:,:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia,1),size(ia,2))) + call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samxm subroutine psb_damxs(ictxt,dat,root,ia) integer, intent(in) :: ictxt @@ -1277,6 +1723,91 @@ contains end subroutine psb_damxm + subroutine psb_camxs(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia + + integer :: root_ + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camxs + + subroutine psb_camxv(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:) + + integer :: root_ + integer, allocatable :: cia(:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia))) + call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camxv + + subroutine psb_camxm(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:,:) + + integer :: root_ + integer, allocatable :: cia(:,:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia,1),size(ia,2))) + call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamx2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camxm + subroutine psb_zamxs(ictxt,dat,root,ia) integer, intent(in) :: ictxt complex(psb_dpk_), intent(inout) :: dat @@ -1363,7 +1894,6 @@ contains end subroutine psb_zamxm - subroutine psb_iamns(ictxt,dat,root,ia) integer, intent(in) :: ictxt integer, intent(inout) :: dat @@ -1450,6 +1980,91 @@ contains end subroutine psb_iamnm + subroutine psb_samns(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia + + integer :: root_ + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samns + + subroutine psb_samnv(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:) + + integer :: root_ + integer, allocatable :: cia(:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia))) + call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samnv + + subroutine psb_samnm(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:,:) + + integer :: root_ + integer, allocatable :: cia(:,:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia,1),size(ia,2))) + call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_samnm + subroutine psb_damns(ictxt,dat,root,ia) integer, intent(in) :: ictxt real(psb_dpk_), intent(inout) :: dat @@ -1536,6 +2151,91 @@ contains end subroutine psb_damnm + subroutine psb_camns(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia + + integer :: root_ + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camns + + subroutine psb_camnv(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:) + + integer :: root_ + integer, allocatable :: cia(:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia))) + call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camnv + + subroutine psb_camnm(ictxt,dat,root,ia) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer, intent(inout), optional :: ia(:,:) + + integer :: root_ + integer, allocatable :: cia(:,:) + + +#if defined(SERIAL_MPI) + if (present(ia)) then + ia = 0 + end if +#else + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (present(ia)) then + allocate(cia(size(ia,1),size(ia,2))) + call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_) + else + call gamn2d(ictxt,'A',dat,rrt=root_) + endif +#endif + end subroutine psb_camnm + subroutine psb_zamns(ictxt,dat,root,ia) integer, intent(in) :: ictxt complex(psb_dpk_), intent(inout) :: dat @@ -1681,6 +2381,63 @@ contains end subroutine psb_isumm + subroutine psb_ssums(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) +#endif + + end subroutine psb_ssums + + subroutine psb_ssumv(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) +#endif + + end subroutine psb_ssumv + + subroutine psb_ssumm(ictxt,dat,root) + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) + +#endif + end subroutine psb_ssumm + subroutine psb_dsums(ictxt,dat,root) integer, intent(in) :: ictxt real(psb_dpk_), intent(inout) :: dat @@ -1739,6 +2496,64 @@ contains end subroutine psb_dsumm + subroutine psb_csums(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) +#endif + + end subroutine psb_csums + + subroutine psb_csumv(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: root_ + integer, allocatable :: cia(:) + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) +#endif + + end subroutine psb_csumv + + subroutine psb_csumm(ictxt,dat,root) + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: root_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = -1 + endif + + call gsum2d(ictxt,'A',dat,rrt=root_) + +#endif + end subroutine psb_csumm + subroutine psb_zsums(ictxt,dat,root) integer, intent(in) :: ictxt complex(psb_dpk_), intent(inout) :: dat @@ -1798,7 +2613,6 @@ contains end subroutine psb_zsumm - subroutine psb_hsnds(ictxt,dat,dst,length) use psb_error_mod integer, intent(in) :: ictxt @@ -1950,6 +2764,57 @@ contains end subroutine psb_isndm + subroutine psb_ssnds(ictxt,dat,dst) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + integer, intent(in) :: dst + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + + call gesd2d(ictxt,dat,dst,0) +#endif + + end subroutine psb_ssnds + + subroutine psb_ssndv(ictxt,dat,dst) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: dst + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + call gesd2d(ictxt,dat,dst,0) +#endif + + end subroutine psb_ssndv + + subroutine psb_ssndm(ictxt,dat,dst,m) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + call gesd2d(ictxt,dat,dst,0,m) +#endif + + end subroutine psb_ssndm + subroutine psb_dsnds(ictxt,dat,dst) use psb_error_mod integer, intent(in) :: ictxt @@ -2002,6 +2867,57 @@ contains end subroutine psb_dsndm + subroutine psb_csnds(ictxt,dat,dst) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + integer, intent(in) :: dst + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + + call gesd2d(ictxt,dat,dst,0) +#endif + + end subroutine psb_csnds + + subroutine psb_csndv(ictxt,dat,dst) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: dst + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + call gesd2d(ictxt,dat,dst,0) +#endif + + end subroutine psb_csndv + + subroutine psb_csndm(ictxt,dat,dst,m) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >1) then + write(0,*) "Warning: process sending a message in serial mode (to itself)" + endif +#else + + call gesd2d(ictxt,dat,dst,0,m) +#endif + + end subroutine psb_csndm + subroutine psb_zsnds(ictxt,dat,dst) use psb_error_mod integer, intent(in) :: ictxt @@ -2109,6 +3025,60 @@ contains end subroutine psb_ircvm + subroutine psb_srcvs(ictxt,dat,src) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in) :: src + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + + call gerv2d(ictxt,dat,src,0) +#endif + + end subroutine psb_srcvs + + subroutine psb_srcvv(ictxt,dat,src) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in) :: src + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + call gerv2d(ictxt,dat,src,0) +#endif + + end subroutine psb_srcvv + + subroutine psb_srcvm(ictxt,dat,src,m) + use psb_error_mod + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + call gerv2d(ictxt,dat,src,0,m) +#endif + + end subroutine psb_srcvm + subroutine psb_drcvs(ictxt,dat,src) use psb_error_mod integer, intent(in) :: ictxt @@ -2164,6 +3134,58 @@ contains end subroutine psb_drcvm + subroutine psb_crcvs(ictxt,dat,src) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in) :: src + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + + call gerv2d(ictxt,dat,src,0) +#endif + + end subroutine psb_crcvs + + subroutine psb_crcvv(ictxt,dat,src) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in) :: src + +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + call gerv2d(ictxt,dat,src,0) +#endif + + end subroutine psb_crcvv + + subroutine psb_crcvm(ictxt,dat,src,m) + use psb_error_mod + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m +#if defined(SERIAL_MPI) + if (psb_get_errverbosity() >0) then + write(0,*) "Warning: process receiving a message in serial mode (to itself)" + endif + dat = 0 +#else + call gerv2d(ictxt,dat,src,0,m) +#endif + + end subroutine psb_crcvm + subroutine psb_zrcvs(ictxt,dat,src) use psb_error_mod integer, intent(in) :: ictxt @@ -2206,7 +3228,6 @@ contains integer, intent(in) :: src integer, intent(in), optional :: m - #if defined(SERIAL_MPI) if (psb_get_errverbosity() >0) then write(0,*) "Warning: process receiving a message in serial mode (to itself)" @@ -2219,2813 +3240,6 @@ contains end subroutine psb_zrcvm - - - - -#if !defined(SERIAL_MPI) - - subroutine igebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat - character, intent(in) :: scope - character, intent(in), optional :: top - - character :: top_ - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine igebs2ds - - subroutine igebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,size(dat,1),1,dat,size(dat,1)) - - end subroutine igebs2dv - - subroutine igebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat(:,:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine igebs2dm - - - - subroutine dgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine dgebs2ds - - subroutine dgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine dgebs2dv - - subroutine dgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine dgebs2dm - - - - subroutine zgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine zgebs2ds - - subroutine zgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine zgebs2dv - - subroutine zgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine zgebs2dm - - - - - - subroutine dgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine dgebr2ds - - subroutine dgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine dgebr2dv - - subroutine dgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine dgebr2dm - - - - - subroutine zgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine zgebr2ds - - subroutine zgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine zgebr2dv - - subroutine zgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine zgebr2dm - - - - subroutine igebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine igebr2ds - - subroutine igebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine igebr2dv - - subroutine igebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine igebr2dm - - - - subroutine dgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - call dgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine dgesd2ds - - - subroutine dgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - call dgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine dgesd2dv - - subroutine dgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call dgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine dgesd2dm - - - subroutine igesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - call igesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine igesd2ds - - - subroutine igesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - call igesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine igesd2dv - - subroutine igesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call igesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine igesd2dm - - - - subroutine zgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - call zgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine zgesd2ds - - - subroutine zgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - call zgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine zgesd2dv - - subroutine zgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call zgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine zgesd2dm - - - - subroutine dgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - call dgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine dgerv2ds - - - subroutine dgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - call dgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine dgerv2dv - - subroutine dgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call dgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine dgerv2dm - - - subroutine igerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - call igerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine igerv2ds - - - subroutine igerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - call igerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine igerv2dv - - subroutine igerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call igerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine igerv2dm - - - - subroutine zgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - call zgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine zgerv2ds - - - subroutine zgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - call zgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine zgerv2dv - - subroutine zgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call zgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine zgerv2dm - - - - subroutine dgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine dgsum2ds - - subroutine dgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine dgsum2dv - - subroutine dgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine dgsum2dm - - - - subroutine igsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine igsum2ds - - subroutine igsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine igsum2dv - - subroutine igsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine igsum2dm - - - - subroutine zgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine zgsum2ds - - subroutine zgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine zgsum2dv - - subroutine zgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine zgsum2dm - - - - - subroutine dgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine dgamx2ds - - - subroutine dgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamx2dv - - subroutine dgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamx2dm - - - - subroutine igamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine igamx2ds - - - subroutine igamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamx2dv - - subroutine igamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - integer, intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamx2dm - - - - subroutine zgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine zgamx2ds - - - subroutine zgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamx2dv - - subroutine zgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamx2dm - - - subroutine dgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine dgamn2ds - - - subroutine dgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamn2dv - - subroutine dgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamn2dm - - - - subroutine igamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine igamn2ds - - - subroutine igamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamn2dv - - subroutine igamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - integer, intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamn2dm - - - - subroutine zgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine zgamn2ds - - - subroutine zgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamn2dv - - subroutine zgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamn2dm -#endif - - subroutine psb_set_coher(ictxt,isvch) integer :: ictxt, isvch ! Ensure global repeatability for convergence checks. diff --git a/base/modules/psb_psblas_mod.f90 b/base/modules/psb_psblas_mod.f90 index 065454657..35c3ef8ca 100644 --- a/base/modules/psb_psblas_mod.f90 +++ b/base/modules/psb_psblas_mod.f90 @@ -32,6 +32,21 @@ module psb_psblas_mod interface psb_gedot + function psb_sdotv(x, y, desc_a,info) + use psb_descriptor_type + real(psb_spk_) :: psb_sdotv + real(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end function psb_sdotv + function psb_sdot(x, y, desc_a, info, jx, jy) + use psb_descriptor_type + real(psb_spk_) :: psb_sdot + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, optional, intent(in) :: jx, jy + integer, intent(out) :: info + end function psb_sdot function psb_ddotv(x, y, desc_a,info) use psb_descriptor_type real(psb_dpk_) :: psb_ddotv @@ -47,6 +62,21 @@ module psb_psblas_mod integer, optional, intent(in) :: jx, jy integer, intent(out) :: info end function psb_ddot + function psb_cdotv(x, y, desc_a,info) + use psb_descriptor_type + complex(psb_spk_) :: psb_cdotv + complex(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end function psb_cdotv + function psb_cdot(x, y, desc_a, info, jx, jy) + use psb_descriptor_type + complex(psb_spk_) :: psb_cdot + complex(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, optional, intent(in) :: jx, jy + integer, intent(out) :: info + end function psb_cdot function psb_zdotv(x, y, desc_a,info) use psb_descriptor_type complex(psb_dpk_) :: psb_zdotv @@ -62,9 +92,41 @@ module psb_psblas_mod integer, optional, intent(in) :: jx, jy integer, intent(out) :: info end function psb_zdot - end interface - + end interface + + interface psb_gexdot + function psb_sxdotv(x, y, desc_a,info) + use psb_descriptor_type + real(psb_dpk_) :: psb_sxdotv + real(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end function psb_sxdotv + function psb_sxdot(x, y, desc_a, info, jx, jy) + use psb_descriptor_type + real(psb_dpk_) :: psb_sxdot + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, optional, intent(in) :: jx, jy + integer, intent(out) :: info + end function psb_sxdot + end interface + interface psb_gedots + subroutine psb_sdotvs(res,x, y, desc_a, info) + use psb_descriptor_type + real(psb_spk_), intent(out) :: res + real(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_sdotvs + subroutine psb_smdots(res,x, y, desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent(out) :: res(:) + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_smdots subroutine psb_ddotvs(res,x, y, desc_a, info) use psb_descriptor_type real(psb_dpk_), intent(out) :: res @@ -79,6 +141,20 @@ module psb_psblas_mod type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info end subroutine psb_dmdots + subroutine psb_cdotvs(res,x, y, desc_a, info) + use psb_descriptor_type + complex(psb_spk_), intent(out) :: res + complex(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_cdotvs + subroutine psb_cmdots(res,x, y, desc_a,info) + use psb_descriptor_type + complex(psb_spk_), intent(out) :: res(:) + complex(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_cmdots subroutine psb_zdotvs(res,x, y, desc_a, info) use psb_descriptor_type complex(psb_dpk_), intent(out) :: res @@ -96,371 +172,707 @@ module psb_psblas_mod end interface interface psb_geaxpby - subroutine psb_daxpbyv(alpha, x, beta, y,& - & desc_a, info) - use psb_descriptor_type - real(psb_dpk_), intent (in) :: x(:) - real(psb_dpk_), intent (inout) :: y(:) - real(psb_dpk_), intent (in) :: alpha, beta - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_daxpbyv - subroutine psb_daxpby(alpha, x, beta, y,& - & desc_a, info, n, jx, jy) - use psb_descriptor_type - real(psb_dpk_), intent (in) :: x(:,:) - real(psb_dpk_), intent (inout) :: y(:,:) - real(psb_dpk_), intent (in) :: alpha, beta - type(psb_desc_type), intent (in) :: desc_a - integer, optional :: n, jx, jy - integer, intent(out) :: info - end subroutine psb_daxpby - subroutine psb_zaxpbyv(alpha, x, beta, y,& - & desc_a, info) - use psb_descriptor_type - complex(psb_dpk_), intent (in) :: x(:) - complex(psb_dpk_), intent (inout) :: y(:) - complex(psb_dpk_), intent (in) :: alpha, beta - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zaxpbyv - subroutine psb_zaxpby(alpha, x, beta, y,& - & desc_a, info, n, jx, jy) - use psb_descriptor_type - complex(psb_dpk_), intent (in) :: x(:,:) - complex(psb_dpk_), intent (inout) :: y(:,:) - complex(psb_dpk_), intent (in) :: alpha, beta - type(psb_desc_type), intent (in) :: desc_a - integer, optional :: n, jx, jy - integer, intent(out) :: info - end subroutine psb_zaxpby + subroutine psb_saxpbyv(alpha, x, beta, y,& + & desc_a, info) + use psb_descriptor_type + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (inout) :: y(:) + real(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_saxpbyv + subroutine psb_saxpby(alpha, x, beta, y,& + & desc_a, info, n, jx, jy) + use psb_descriptor_type + real(psb_spk_), intent (in) :: x(:,:) + real(psb_spk_), intent (inout) :: y(:,:) + real(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, optional :: n, jx, jy + integer, intent(out) :: info + end subroutine psb_saxpby + subroutine psb_daxpbyv(alpha, x, beta, y,& + & desc_a, info) + use psb_descriptor_type + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (inout) :: y(:) + real(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_daxpbyv + subroutine psb_daxpby(alpha, x, beta, y,& + & desc_a, info, n, jx, jy) + use psb_descriptor_type + real(psb_dpk_), intent (in) :: x(:,:) + real(psb_dpk_), intent (inout) :: y(:,:) + real(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, optional :: n, jx, jy + integer, intent(out) :: info + end subroutine psb_daxpby + subroutine psb_caxpbyv(alpha, x, beta, y,& + & desc_a, info) + use psb_descriptor_type + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (inout) :: y(:) + complex(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_caxpbyv + subroutine psb_caxpby(alpha, x, beta, y,& + & desc_a, info, n, jx, jy) + use psb_descriptor_type + complex(psb_spk_), intent (in) :: x(:,:) + complex(psb_spk_), intent (inout) :: y(:,:) + complex(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, optional :: n, jx, jy + integer, intent(out) :: info + end subroutine psb_caxpby + subroutine psb_zaxpbyv(alpha, x, beta, y,& + & desc_a, info) + use psb_descriptor_type + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (inout) :: y(:) + complex(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zaxpbyv + subroutine psb_zaxpby(alpha, x, beta, y,& + & desc_a, info, n, jx, jy) + use psb_descriptor_type + complex(psb_dpk_), intent (in) :: x(:,:) + complex(psb_dpk_), intent (inout) :: y(:,:) + complex(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer, optional :: n, jx, jy + integer, intent(out) :: info + end subroutine psb_zaxpby end interface interface psb_geamax - function psb_damax(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_damax - real(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_damax - function psb_damaxv(x, desc_a,info) - use psb_descriptor_type - real(psb_dpk_) psb_damaxv - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_damaxv - function psb_zamax(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_zamax - complex(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_zamax - function psb_zamaxv(x, desc_a,info) - use psb_descriptor_type - real(psb_dpk_) psb_zamaxv - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_zamaxv + function psb_samax(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_samax + real(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_samax + function psb_samaxv(x, desc_a,info) + use psb_descriptor_type + real(psb_spk_) psb_samaxv + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_samaxv + function psb_damax(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_damax + real(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_damax + function psb_damaxv(x, desc_a,info) + use psb_descriptor_type + real(psb_dpk_) psb_damaxv + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_damaxv + function psb_camax(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_camax + complex(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_camax + function psb_camaxv(x, desc_a,info) + use psb_descriptor_type + real(psb_spk_) psb_camaxv + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_camaxv + function psb_zamax(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_zamax + complex(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_zamax + function psb_zamaxv(x, desc_a,info) + use psb_descriptor_type + real(psb_dpk_) psb_zamaxv + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_zamaxv end interface interface psb_geamaxs - subroutine psb_damaxvs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_damaxvs - subroutine psb_dmamax(res,x,desc_a,info,jx) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res(:) - real(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - integer, optional :: jx - end subroutine psb_dmamax - subroutine psb_zamaxvs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zamaxvs - subroutine psb_zmamax(res,x,desc_a,info,jx) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res(:) - complex(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - integer, optional :: jx - end subroutine psb_zmamax + subroutine psb_samaxvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_samaxvs + subroutine psb_smamax(res,x,desc_a,info,jx) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res(:) + real(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + integer, optional :: jx + end subroutine psb_smamax + subroutine psb_damaxvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_damaxvs + subroutine psb_dmamax(res,x,desc_a,info,jx) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res(:) + real(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + integer, optional :: jx + end subroutine psb_dmamax + subroutine psb_camaxvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_camaxvs + subroutine psb_cmamax(res,x,desc_a,info,jx) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res(:) + complex(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + integer, optional :: jx + end subroutine psb_cmamax + subroutine psb_zamaxvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zamaxvs + subroutine psb_zmamax(res,x,desc_a,info,jx) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res(:) + complex(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + integer, optional :: jx + end subroutine psb_zmamax end interface interface psb_geasum - function psb_dasum(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_dasum - real(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_dasum - function psb_dasumv(x, desc_a, info) - use psb_descriptor_type - real(psb_dpk_) psb_dasumv - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_dasumv - function psb_zasum(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_zasum - complex(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_zasum - function psb_zasumv(x, desc_a, info) - use psb_descriptor_type - real(psb_dpk_) psb_zasumv - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_zasumv - end interface + function psb_sasum(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_sasum + real(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_sasum + function psb_sasumv(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_) psb_sasumv + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_sasumv + function psb_dasum(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_dasum + real(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_dasum + function psb_dasumv(x, desc_a, info) + use psb_descriptor_type + real(psb_dpk_) psb_dasumv + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_dasumv + function psb_casum(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_casum + complex(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_casum + function psb_casumv(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_) psb_casumv + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_casumv + function psb_zasum(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_zasum + complex(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_zasum + function psb_zasumv(x, desc_a, info) + use psb_descriptor_type + real(psb_dpk_) psb_zasumv + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_zasumv + end interface interface psb_geasums - subroutine psb_dasumvs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_dasumvs - subroutine psb_dmasum(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res(:) - real(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_dmasum - subroutine psb_zasumvs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zasumvs - subroutine psb_zmasum(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res(:) - complex(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zmasum + subroutine psb_sasumvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_sasumvs + subroutine psb_smasum(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res(:) + real(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_smasum + subroutine psb_dasumvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_dasumvs + subroutine psb_dmasum(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res(:) + real(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_dmasum + subroutine psb_casumvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_casumvs + subroutine psb_cmasum(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res(:) + complex(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_cmasum + subroutine psb_zasumvs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zasumvs + subroutine psb_zmasum(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res(:) + complex(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zmasum end interface interface psb_genrm2 - function psb_dnrm2(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_dnrm2 - real(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_dnrm2 - function psb_dnrm2v(x, desc_a, info) - use psb_descriptor_type - real(psb_dpk_) psb_dnrm2v - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_dnrm2v - function psb_znrm2(x, desc_a, info, jx) - use psb_descriptor_type - real(psb_dpk_) psb_znrm2 - complex(psb_dpk_), intent (in) :: x(:,:) - type(psb_desc_type), intent (in) :: desc_a - integer, optional, intent (in) :: jx - integer, intent(out) :: info - end function psb_znrm2 - function psb_znrm2v(x, desc_a, info) - use psb_descriptor_type - real(psb_dpk_) psb_znrm2v - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_znrm2v + function psb_snrm2(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_snrm2 + real(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_snrm2 + function psb_snrm2v(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_) psb_snrm2v + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_snrm2v + function psb_dnrm2(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_dnrm2 + real(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_dnrm2 + function psb_dnrm2v(x, desc_a, info) + use psb_descriptor_type + real(psb_dpk_) psb_dnrm2v + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_dnrm2v + function psb_cnrm2(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_spk_) psb_snrm2 + complex(psb_spk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_cnrm2 + function psb_cnrm2v(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_) psb_cnrm2v + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_cnrm2v + function psb_znrm2(x, desc_a, info, jx) + use psb_descriptor_type + real(psb_dpk_) psb_znrm2 + complex(psb_dpk_), intent (in) :: x(:,:) + type(psb_desc_type), intent (in) :: desc_a + integer, optional, intent (in) :: jx + integer, intent(out) :: info + end function psb_znrm2 + function psb_znrm2v(x, desc_a, info) + use psb_descriptor_type + real(psb_dpk_) psb_znrm2v + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_znrm2v end interface interface psb_genrm2s - subroutine psb_dnrm2vs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - real(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_dnrm2vs - subroutine psb_znrm2vs(res,x,desc_a,info) - use psb_descriptor_type - real(psb_dpk_), intent (out) :: res - complex(psb_dpk_), intent (in) :: x(:) - type(psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end subroutine psb_znrm2vs + subroutine psb_snrm2vs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + real(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_snrm2vs + subroutine psb_dnrm2vs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + real(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_dnrm2vs + subroutine psb_cnrm2vs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_spk_), intent (out) :: res + complex(psb_spk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_cnrm2vs + subroutine psb_znrm2vs(res,x,desc_a,info) + use psb_descriptor_type + real(psb_dpk_), intent (out) :: res + complex(psb_dpk_), intent (in) :: x(:) + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end subroutine psb_znrm2vs end interface - + interface psb_spnrmi - function psb_dnrmi(a, desc_a,info) - use psb_serial_mod - use psb_descriptor_type - real(psb_dpk_) :: psb_dnrmi - type (psb_dspmat_type), intent (in) :: a - type (psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_dnrmi - function psb_znrmi(a, desc_a,info) - use psb_serial_mod - use psb_descriptor_type - real(psb_dpk_) :: psb_znrmi - type (psb_zspmat_type), intent (in) :: a - type (psb_desc_type), intent (in) :: desc_a - integer, intent(out) :: info - end function psb_znrmi + function psb_snrmi(a, desc_a,info) + use psb_serial_mod + use psb_descriptor_type + real(psb_spk_) :: psb_snrmi + type(psb_sspmat_type), intent (in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_snrmi + function psb_dnrmi(a, desc_a,info) + use psb_serial_mod + use psb_descriptor_type + real(psb_dpk_) :: psb_dnrmi + type(psb_dspmat_type), intent (in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_dnrmi + function psb_cnrmi(a, desc_a,info) + use psb_serial_mod + use psb_descriptor_type + real(psb_spk_) :: psb_cnrmi + type(psb_cspmat_type), intent (in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_cnrmi + function psb_znrmi(a, desc_a,info) + use psb_serial_mod + use psb_descriptor_type + real(psb_dpk_) :: psb_znrmi + type(psb_zspmat_type), intent (in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer, intent(out) :: info + end function psb_znrmi end interface interface psb_spmm - subroutine psb_dspmm(alpha, a, x, beta, y, desc_a, info,& - &trans, k, jx, jy,work,doswap) - use psb_serial_mod - use psb_descriptor_type - type (psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans - real(psb_dpk_), optional, intent(inout),target :: work(:) - integer, optional, intent(in) :: k, jx, jy - logical, optional, intent(in) :: doswap - integer, intent(out) :: info - end subroutine psb_dspmm - subroutine psb_dspmv(alpha, a, x, beta, y,& - & desc_a, info, trans, work,doswap) - use psb_serial_mod - use psb_descriptor_type - type (psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), intent(inout) :: y(:) - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans - real(psb_dpk_), optional, intent(inout),target :: work(:) - logical, optional, intent(in) :: doswap - integer, intent(out) :: info - end subroutine psb_dspmv - subroutine psb_zspmm(alpha, a, x, beta, y, desc_a, info,& - &trans, k, jx, jy,work,doswap) - use psb_serial_mod - use psb_descriptor_type - type (psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans - complex(psb_dpk_), optional, intent(inout),target :: work(:) - integer, optional, intent(in) :: k, jx, jy - logical, optional, intent(in) :: doswap - integer, intent(out) :: info - end subroutine psb_zspmm - subroutine psb_zspmv(alpha, a, x, beta, y,& - & desc_a, info, trans, work,doswap) - use psb_serial_mod - use psb_descriptor_type - type (psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), intent(inout) :: y(:) - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans - complex(psb_dpk_), optional, intent(inout),target :: work(:) - logical, optional, intent(in) :: doswap - integer, intent(out) :: info - end subroutine psb_zspmv + subroutine psb_sspmm(alpha, a, x, beta, y, desc_a, info,& + &trans, k, jx, jy,work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + real(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + real(psb_spk_), optional, intent(inout),target :: work(:) + integer, optional, intent(in) :: k, jx, jy + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_sspmm + subroutine psb_sspmv(alpha, a, x, beta, y,& + & desc_a, info, trans, work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(inout) :: y(:) + real(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + real(psb_spk_), optional, intent(inout),target :: work(:) + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_sspmv + subroutine psb_dspmm(alpha, a, x, beta, y, desc_a, info,& + &trans, k, jx, jy,work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + real(psb_dpk_), optional, intent(inout),target :: work(:) + integer, optional, intent(in) :: k, jx, jy + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_dspmm + subroutine psb_dspmv(alpha, a, x, beta, y,& + & desc_a, info, trans, work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + real(psb_dpk_), optional, intent(inout),target :: work(:) + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_dspmv + subroutine psb_cspmm(alpha, a, x, beta, y, desc_a, info,& + &trans, k, jx, jy,work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + complex(psb_spk_), optional, intent(inout),target :: work(:) + integer, optional, intent(in) :: k, jx, jy + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_cspmm + subroutine psb_cspmv(alpha, a, x, beta, y,& + & desc_a, info, trans, work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(inout) :: y(:) + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + complex(psb_spk_), optional, intent(inout),target :: work(:) + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_cspmv + subroutine psb_zspmm(alpha, a, x, beta, y, desc_a, info,& + &trans, k, jx, jy,work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + complex(psb_dpk_), optional, intent(inout),target :: work(:) + integer, optional, intent(in) :: k, jx, jy + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_zspmm + subroutine psb_zspmv(alpha, a, x, beta, y,& + & desc_a, info, trans, work,doswap) + use psb_serial_mod + use psb_descriptor_type + type(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), intent(inout) :: y(:) + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + complex(psb_dpk_), optional, intent(inout),target :: work(:) + logical, optional, intent(in) :: doswap + integer, intent(out) :: info + end subroutine psb_zspmv end interface interface psb_spsm - subroutine psb_dspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, unit, choice,& - & diag, n, jx, jy, work) - use psb_serial_mod - use psb_descriptor_type - type (psb_dspmat_type), intent(in) :: t - real(psb_dpk_), intent(in) :: x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans, unit - integer, optional, intent(in) :: n, jx, jy - integer, optional, intent(in) :: choice - real(psb_dpk_), optional, intent(in),target :: work(:), diag(:) - integer, intent(out) :: info - end subroutine psb_dspsm - subroutine psb_dspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, unit, choice,& - & diag, work) - use psb_serial_mod - use psb_descriptor_type - type (psb_dspmat_type), intent(in) :: t - real(psb_dpk_), intent(in) :: x(:) - real(psb_dpk_), intent(inout) :: y(:) - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans, unit - integer, optional, intent(in) :: choice - real(psb_dpk_), optional, intent(in),target :: work(:), diag(:) - integer, intent(out) :: info - end subroutine psb_dspsv - subroutine psb_zspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, unit, choice,& - & diag, n, jx, jy, work) - use psb_serial_mod - use psb_descriptor_type - type (psb_zspmat_type), intent(in) :: t - complex(psb_dpk_), intent(in) :: x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans, unit - integer, optional, intent(in) :: n, jx, jy - integer, optional, intent(in) :: choice - complex(psb_dpk_), optional, intent(in),target :: work(:), diag(:) - integer, intent(out) :: info - end subroutine psb_zspsm - subroutine psb_zspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, unit, choice,& - & diag, work) - use psb_serial_mod - use psb_descriptor_type - type (psb_zspmat_type), intent(in) :: t - complex(psb_dpk_), intent(in) :: x(:) - complex(psb_dpk_), intent(inout) :: y(:) - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans, unit - integer, optional, intent(in) :: choice - complex(psb_dpk_), optional, intent(in),target :: work(:), diag(:) - integer, intent(out) :: info - end subroutine psb_zspsv + subroutine psb_sspsm(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, n, jx, jy, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_sspmat_type), intent(in) :: t + real(psb_spk_), intent(in) :: x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + real(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: n, jx, jy + integer, optional, intent(in) :: choice + real(psb_spk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_sspsm + subroutine psb_sspsv(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_sspmat_type), intent(in) :: t + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(inout) :: y(:) + real(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: choice + real(psb_spk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_sspsv + subroutine psb_dspsm(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, n, jx, jy, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_dspmat_type), intent(in) :: t + real(psb_dpk_), intent(in) :: x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: n, jx, jy + integer, optional, intent(in) :: choice + real(psb_dpk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_dspsm + subroutine psb_dspsv(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_dspmat_type), intent(in) :: t + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: choice + real(psb_dpk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_dspsv + subroutine psb_cspsm(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, n, jx, jy, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_cspmat_type), intent(in) :: t + complex(psb_spk_), intent(in) :: x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: n, jx, jy + integer, optional, intent(in) :: choice + complex(psb_spk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_cspsm + subroutine psb_cspsv(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_cspmat_type), intent(in) :: t + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(inout) :: y(:) + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: choice + complex(psb_spk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_cspsv + subroutine psb_zspsm(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, n, jx, jy, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_zspmat_type), intent(in) :: t + complex(psb_dpk_), intent(in) :: x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: n, jx, jy + integer, optional, intent(in) :: choice + complex(psb_dpk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_zspsm + subroutine psb_zspsv(alpha, t, x, beta, y,& + & desc_a, info, trans, unit, choice,& + & diag, work) + use psb_serial_mod + use psb_descriptor_type + type(psb_zspmat_type), intent(in) :: t + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(inout) :: y(:) + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans, unit + integer, optional, intent(in) :: choice + complex(psb_dpk_), optional, intent(in),target :: work(:), diag(:) + integer, intent(out) :: info + end subroutine psb_zspsv end interface end module psb_psblas_mod diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index fdd119c1b..63e2569e6 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -41,31 +41,47 @@ module psb_realloc_mod module procedure psb_dreallocate1i module procedure psb_dreallocate2i module procedure psb_dreallocate2i1d + module procedure psb_dreallocate2i1s module procedure psb_dreallocate1d + module procedure psb_dreallocate1s module procedure psb_dreallocated2 + module procedure psb_dreallocates2 module procedure psb_dreallocatei2 module procedure psb_dreallocate2i1z + module procedure psb_dreallocate2i1c module procedure psb_dreallocate1z + module procedure psb_dreallocate1c module procedure psb_dreallocatez2 + module procedure psb_dreallocatec2 end Interface interface psb_transfer + module procedure psb_stransfer1d + module procedure psb_stransfer2d module procedure psb_dtransfer1d module procedure psb_dtransfer2d module procedure psb_itransfer1d module procedure psb_itransfer2d + module procedure psb_ctransfer1d + module procedure psb_ctransfer2d module procedure psb_ztransfer1d module procedure psb_ztransfer2d end interface Interface psb_safe_ab_cpy module procedure psb_i_ab_cpy1d,psb_i_ab_cpy2d, & - & psb_d_ab_cpy1d, psb_d_ab_cpy2d, psb_z_ab_cpy1d, psb_z_ab_cpy2d + & psb_s_ab_cpy1d, psb_s_ab_cpy2d,& + & psb_c_ab_cpy1d, psb_c_ab_cpy2d,& + & psb_d_ab_cpy1d, psb_d_ab_cpy2d,& + & psb_z_ab_cpy1d, psb_z_ab_cpy2d end Interface Interface psb_safe_cpy module procedure psb_i_cpy1d,psb_i_cpy2d, & - & psb_d_cpy1d, psb_d_cpy2d, psb_z_cpy1d, psb_z_cpy2d + & psb_s_cpy1d, psb_s_cpy2d,& + & psb_c_cpy1d, psb_c_cpy2d,& + & psb_d_cpy1d, psb_d_cpy2d,& + & psb_z_cpy1d, psb_z_cpy2d end Interface ! @@ -74,11 +90,15 @@ module psb_realloc_mod ! value required, usually with some room to spare. ! interface psb_ensure_size - module procedure psb_icksz1d, psb_dcksz1d, psb_zcksz1d + module procedure psb_icksz1d,& + & psb_scksz1d, psb_ccksz1d, & + & psb_dcksz1d, psb_zcksz1d end Interface interface psb_size module procedure psb_isize1d, psb_isize2d,& + & psb_ssize1d, psb_ssize2d,& + & psb_csize1d, psb_csize2d,& & psb_dsize1d, psb_dsize2d,& & psb_zsize1d, psb_zsize2d end interface @@ -103,10 +123,11 @@ Contains call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then + if (psb_get_errstatus() /= 0) then info = 4010 goto 9999 end if + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) @@ -188,6 +209,108 @@ Contains end subroutine psb_i_ab_cpy2d + subroutine psb_s_ab_cpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_ab_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_s_ab_cpy1d + + subroutine psb_s_ab_cpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_ab_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_s_ab_cpy2d + subroutine psb_d_ab_cpy1d(vin,vout,info) use psb_error_mod @@ -204,11 +327,11 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 end if + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) @@ -254,11 +377,11 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 end if + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) @@ -290,6 +413,108 @@ Contains end subroutine psb_d_ab_cpy2d + subroutine psb_c_ab_cpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_ab_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_c_ab_cpy1d + + subroutine psb_c_ab_cpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_ab_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_c_ab_cpy2d + subroutine psb_z_ab_cpy1d(vin,vout,info) use psb_error_mod @@ -306,7 +531,6 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -356,7 +580,6 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -409,7 +632,6 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -457,11 +679,11 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 end if + isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) @@ -491,6 +713,104 @@ Contains end subroutine psb_i_cpy2d + subroutine psb_s_cpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_s_cpy1d + + subroutine psb_s_cpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_s_cpy2d + subroutine psb_d_cpy1d(vin,vout,info) use psb_error_mod @@ -507,7 +827,6 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -555,7 +874,6 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -590,6 +908,104 @@ Contains end subroutine psb_d_cpy2d + subroutine psb_c_cpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_c_cpy1d + + subroutine psb_c_cpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info = 0 + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + end subroutine psb_c_cpy2d + subroutine psb_z_cpy1d(vin,vout,info) use psb_error_mod @@ -606,7 +1022,6 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) info = 0 - if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -653,8 +1068,8 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = 0 if(psb_get_errstatus() /= 0) then info = 4010 goto 9999 @@ -717,6 +1132,36 @@ Contains end if end function psb_isize2d + function psb_ssize1d(vin) + integer :: psb_ssize1d + real(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + psb_ssize1d = 0 + else + psb_ssize1d = size(vin) + end if + end function psb_ssize1d + + function psb_ssize2d(vin,dim) + integer :: psb_ssize2d + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer, optional :: dim + integer :: dim_ + + + if (.not.allocated(vin)) then + psb_ssize2d = 0 + else + if (present(dim)) then + dim_= dim + psb_ssize2d = size(vin,dim=dim_) + else + psb_ssize2d = size(vin) + end if + end if + end function psb_ssize2d + function psb_dsize1d(vin) integer :: psb_dsize1d real(psb_dpk_), allocatable, intent(in) :: vin(:) @@ -727,6 +1172,7 @@ Contains psb_dsize1d = size(vin) end if end function psb_dsize1d + function psb_dsize2d(vin,dim) integer :: psb_dsize2d real(psb_dpk_), allocatable, intent(in) :: vin(:,:) @@ -747,6 +1193,35 @@ Contains end function psb_dsize2d + function psb_csize1d(vin) + integer :: psb_csize1d + complex(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + psb_csize1d = 0 + else + psb_csize1d = size(vin) + end if + end function psb_csize1d + + function psb_csize2d(vin,dim) + integer :: psb_csize2d + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer, optional :: dim + integer :: dim_ + + if (.not.allocated(vin)) then + psb_csize2d = 0 + else + if (present(dim)) then + dim_= dim + psb_csize2d = size(vin,dim=dim_) + else + psb_csize2d = size(vin) + end if + end if + end function psb_csize2d + function psb_zsize1d(vin) integer :: psb_zsize1d complex(psb_dpk_), allocatable, intent(in) :: vin(:) @@ -836,6 +1311,64 @@ Contains End Subroutine psb_icksz1d + Subroutine psb_scksz1d(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: v(:) + integer :: info + integer, optional, intent(in) :: addsz,newsz + real(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer :: isz, err_act + + name='psb_ensure_size' + call psb_erractionsave(err_act) + info=0 + + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + + End Subroutine psb_scksz1d + Subroutine psb_dcksz1d(len,v,info,pad,addsz,newsz) use psb_error_mod @@ -895,6 +1428,64 @@ Contains End Subroutine psb_dcksz1d + Subroutine psb_ccksz1d(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: v(:) + integer :: info + integer, optional, intent(in) :: addsz,newsz + complex(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer :: isz, err_act + + name='psb_ensure_size' + call psb_erractionsave(err_act) + info=0 + + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + call psb_realloc(isz,v,info,pad=pad) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + end if + end If + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + + End Subroutine psb_ccksz1d + + Subroutine psb_zcksz1d(len,v,info,pad,addsz,newsz) use psb_error_mod @@ -973,7 +1564,8 @@ Contains info=0 if (debug) write(0,*) 'reallocate I',len - if(psb_get_errstatus() /= 0) then + if (psb_get_errstatus() /= 0) then + if (debug) write(0,*) 'reallocate errstatus /= 0' info = 4010 goto 9999 end if @@ -989,7 +1581,7 @@ Contains goto 9999 end if ub_ = lb_+len-1 - + if (debug) write(0,*) 'reallocate : lb ub ',lb_, ub_ if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) @@ -1001,7 +1593,9 @@ Contains goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + if (debug) write(0,*) 'reallocate : calling transfer ' call psb_transfer(tmp,rrax,info) + if (debug) write(0,*) 'reallocate : from transfer ',info end if else dim = 0 @@ -1015,7 +1609,7 @@ Contains if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif - + if (debug) write(0,*) 'end reallocate : ',info call psb_erractionrestore(err_act) return @@ -1034,6 +1628,80 @@ Contains End Subroutine psb_dreallocate1i + Subroutine psb_dreallocate1s(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + Real(psb_spk_),allocatable, intent(inout) :: rrax(:) + integer :: info + real(psb_spk_), optional, intent(in) :: pad + integer, optional, intent(in) :: lb + + ! ...Local Variables + Real(psb_spk_),allocatable :: tmp(:) + Integer :: dim,err_act,err, lb_, lbi,ub_ + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_dreallocate1s' + call psb_erractionsave(err_act) + info = 0 + if (debug) write(0,*) 'reallocate S',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_transfer(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_dreallocate1s + Subroutine psb_dreallocate1d(len,rrax,info,pad,lb) use psb_error_mod @@ -1109,6 +1777,79 @@ Contains End Subroutine psb_dreallocate1d + Subroutine psb_dreallocate1c(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout):: rrax(:) + integer :: info + complex(psb_spk_), optional, intent(in) :: pad + integer, optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_spk_),allocatable :: tmp(:) + Integer :: dim,err_act,err,lb_,ub_,lbi + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_dreallocate1c' + call psb_erractionsave(err_act) + info = 0 + if (debug) write(0,*) 'reallocate C',len + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + ub_ = lb_+len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_transfer(tmp,rrax,info) + end if + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_dreallocate1c + Subroutine psb_dreallocate1z(len,rrax,info,pad,lb) use psb_error_mod @@ -1184,6 +1925,98 @@ Contains + Subroutine psb_dreallocates2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + Integer,Intent(in) :: len1,len2 + Real(psb_spk_),allocatable :: rrax(:,:) + integer :: info + real(psb_spk_), optional, intent(in) :: pad + Integer,Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + Real(psb_spk_),allocatable :: tmp(:,:) + Integer :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& + & lbi1, lbi2 + character(len=20) :: name + + name='psb_dreallocates2' + call psb_erractionsave(err_act) + info = 0 + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_transfer(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_dreallocates2 + + Subroutine psb_dreallocated2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments @@ -1276,6 +2109,97 @@ Contains End Subroutine psb_dreallocated2 + Subroutine psb_dreallocatec2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + Integer,Intent(in) :: len1,len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer :: info + complex(psb_spk_), optional, intent(in) :: pad + Integer,Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + Integer :: dim,err_act,err,dim2,lb1_, lb2_, ub1_, ub2_,& + & lbi1, lbi2 + character(len=20) :: name + + name='psb_dreallocatec2' + call psb_erractionsave(err_act) + info = 0 + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_transfer(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= 0) then + err=4025 + call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_dreallocatec2 Subroutine psb_dreallocatez2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod @@ -1510,6 +2434,55 @@ Contains + Subroutine psb_dreallocate2i1s(len,rrax,y,z,info) + use psb_error_mod + ! ...Subroutine Arguments + Integer,Intent(in) :: len + Integer,allocatable, intent(inout) :: rrax(:),y(:) + Real(psb_spk_),allocatable, intent(inout) :: z(:) + integer :: info + character(len=20) :: name + integer :: err_act, err + logical, parameter :: debug=.false. + + name='psb_dreallocate2i1s' + call psb_erractionsave(err_act) + + + info = 0 + call psb_realloc(len,rrax,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,z,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + End Subroutine psb_dreallocate2i1s + + Subroutine psb_dreallocate2i1d(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments @@ -1525,19 +2498,19 @@ Contains info = 0 - call psb_dreallocate1i(len,rrax,info) + call psb_realloc(len,rrax,info) if (info /= 0) then err=4000 call psb_errpush(err,name) goto 9999 end if - call psb_dreallocate1i(len,y,info) + call psb_realloc(len,y,info) if (info /= 0) then err=4000 call psb_errpush(err,name) goto 9999 end if - call psb_dreallocate1d(len,z,info) + call psb_realloc(len,z,info) if (info /= 0) then err=4000 call psb_errpush(err,name) @@ -1559,6 +2532,53 @@ Contains + Subroutine psb_dreallocate2i1c(len,rrax,y,z,info) + use psb_error_mod + ! ...Subroutine Arguments + Integer,Intent(in) :: len + Integer,allocatable, intent(inout) :: rrax(:),y(:) + complex(psb_spk_),allocatable, intent(inout) :: z(:) + integer :: info + character(len=20) :: name + integer :: err_act, err + + name='psb_dreallocate2i1c' + call psb_erractionsave(err_act) + + + info = 0 + call psb_realloc(len,rrax,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,z,info) + if (info /= 0) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + End Subroutine psb_dreallocate2i1c + Subroutine psb_dreallocate2i1z(len,rrax,y,z,info) use psb_error_mod ! ...Subroutine Arguments @@ -1569,24 +2589,23 @@ Contains character(len=20) :: name integer :: err_act, err - name='psb_dreallocate2i1d' + name='psb_dreallocate2i1z' call psb_erractionsave(err_act) info = 0 - - call psb_dreallocate1i(len,rrax,info) + call psb_realloc(len,rrax,info) if (info /= 0) then err=4000 call psb_errpush(err,name) goto 9999 end if - call psb_dreallocate1i(len,y,info) + call psb_realloc(len,y,info) if (info /= 0) then err=4000 call psb_errpush(err,name) goto 9999 end if - call psb_dreallocate1z(len,z,info) + call psb_realloc(len,z,info) if (info /= 0) then err=4000 call psb_errpush(err,name) @@ -1606,6 +2625,61 @@ Contains return End Subroutine psb_dreallocate2i1z + Subroutine psb_stransfer1d(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer, intent(out) :: info + ! + ! + info = 0 +#ifdef HAVE_MOVE_ALLOC + + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then +!!$ write(0,*) 'transfer: Clearing output' + deallocate(vout) + end if + +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= 0) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_stransfer1d + + Subroutine psb_stransfer2d(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer, intent(out) :: info + ! + ! + info = 0 +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= 0) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_stransfer2d + Subroutine psb_dtransfer1d(vin,vout,info) use psb_error_mod real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) @@ -1661,6 +2735,58 @@ Contains #endif end Subroutine psb_dtransfer2d + Subroutine psb_ctransfer1d(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer, intent(out) :: info + ! + ! + info = 0 +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= 0) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_ctransfer1d + + Subroutine psb_ctransfer2d(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer, intent(out) :: info + ! + ! + info = 0 +#ifdef HAVE_MOVE_ALLOC + if (allocated(vin)) then + call move_alloc(vin,vout) + else if (allocated(vout)) then + deallocate(vout) + end if +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= 0) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_ctransfer2d + Subroutine psb_ztransfer1d(vin,vout,info) use psb_error_mod complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index 587783275..7ab2414cb 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -39,8 +39,6 @@ module psb_serial_mod & psb_gth => psi_gth,& & psb_sct => psi_sct - - interface psb_csrws subroutine psb_dcsrws(rw,a,info,trans) use psb_spmat_type @@ -58,9 +56,23 @@ module psb_serial_mod end subroutine psb_zcsrws end interface - - interface psb_cssm + subroutine psb_scssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_sspmat_type) :: t + real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + real(psb_spk_), optional, target :: d(:) + end subroutine psb_scssm + subroutine psb_scssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_sspmat_type) :: t + real(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + real(psb_spk_), optional, target :: d(:) + end subroutine psb_scssv subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) use psb_spmat_type type(psb_dspmat_type) :: t @@ -77,6 +89,22 @@ module psb_serial_mod character, optional :: trans, unitd real(psb_dpk_), optional, target :: d(:) end subroutine psb_dcssv + subroutine psb_ccssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_cspmat_type) :: t + complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + complex(psb_spk_), optional, target :: d(:) + end subroutine psb_ccssm + subroutine psb_ccssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + type(psb_cspmat_type) :: t + complex(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + complex(psb_spk_), optional, target :: d(:) + end subroutine psb_ccssv subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) use psb_spmat_type type(psb_zspmat_type) :: t @@ -96,6 +124,20 @@ module psb_serial_mod end interface interface psb_csmm + subroutine psb_scsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_sspmat_type) :: a + real(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + end subroutine psb_scsmv + subroutine psb_scsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_sspmat_type) :: a + real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + end subroutine psb_scsmm subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) use psb_spmat_type type(psb_dspmat_type) :: a @@ -110,6 +152,20 @@ module psb_serial_mod integer :: info character, optional :: trans end subroutine psb_dcsmm + subroutine psb_ccsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_cspmat_type) :: a + complex(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + end subroutine psb_ccsmv + subroutine psb_ccsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + type(psb_cspmat_type) :: a + complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + end subroutine psb_ccsmm subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) use psb_spmat_type type(psb_zspmat_type) :: a @@ -135,6 +191,21 @@ module psb_serial_mod end interface interface psb_spcnv + subroutine psb_sspcnv2(ain, a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_sspmat_type), intent (in) :: ain + type(psb_sspmat_type), intent (out) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_sspcnv2 + subroutine psb_sspcnv1(a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_sspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_sspcnv1 subroutine psb_dspcnv2(ain, a, info, afmt, upd, dupl) use psb_spmat_type type(psb_dspmat_type), intent (in) :: ain @@ -150,6 +221,21 @@ module psb_serial_mod integer,optional, intent(in) :: dupl, upd character(len=*), optional, intent(in) :: afmt end subroutine psb_dspcnv1 + subroutine psb_cspcnv2(ain, a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_cspmat_type), intent (in) :: ain + type(psb_cspmat_type), intent (out) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_cspcnv2 + subroutine psb_cspcnv1(a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_cspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_cspcnv1 subroutine psb_zspcnv2(ain, a, info, afmt, upd, dupl) use psb_spmat_type type(psb_zspmat_type), intent (in) :: ain @@ -170,12 +256,24 @@ module psb_serial_mod interface psb_fixcoo + subroutine psb_sfixcoo(a,info,idir) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine psb_sfixcoo subroutine psb_dfixcoo(a,info,idir) use psb_spmat_type type(psb_dspmat_type), intent(inout) :: a integer, intent(out) :: info integer, intent(in), optional :: idir end subroutine psb_dfixcoo + subroutine psb_cfixcoo(a,info,idir) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine psb_cfixcoo subroutine psb_zfixcoo(a,info,idir) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -185,12 +283,24 @@ module psb_serial_mod end interface interface psb_ipcoo2csr + subroutine psb_sipcoo2csr(a,info,rwshr) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: rwshr + end subroutine psb_sipcoo2csr subroutine psb_dipcoo2csr(a,info,rwshr) use psb_spmat_type type(psb_dspmat_type), intent(inout) :: a integer, intent(out) :: info logical, optional :: rwshr end subroutine psb_dipcoo2csr + subroutine psb_cipcoo2csr(a,info,rwshr) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: rwshr + end subroutine psb_cipcoo2csr subroutine psb_zipcoo2csr(a,info,rwshr) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -200,12 +310,24 @@ module psb_serial_mod end interface interface psb_ipcoo2csc + subroutine psb_sipcoo2csc(a,info,clshr) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: clshr + end subroutine psb_sipcoo2csc subroutine psb_dipcoo2csc(a,info,clshr) use psb_spmat_type type(psb_dspmat_type), intent(inout) :: a integer, intent(out) :: info logical, optional :: clshr end subroutine psb_dipcoo2csc + subroutine psb_cipcoo2csc(a,info,clshr) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, optional :: clshr + end subroutine psb_cipcoo2csc subroutine psb_zipcoo2csc(a,info,clshr) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -215,11 +337,21 @@ module psb_serial_mod end interface interface psb_ipcsr2coo + subroutine psb_sipcsr2coo(a,info) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_sipcsr2coo subroutine psb_dipcsr2coo(a,info) use psb_spmat_type type(psb_dspmat_type), intent(inout) :: a integer, intent(out) :: info end subroutine psb_dipcsr2coo + subroutine psb_cipcsr2coo(a,info) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_cipcsr2coo subroutine psb_zipcsr2coo(a,info) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -228,6 +360,15 @@ module psb_serial_mod end interface interface psb_csprt + subroutine psb_scsprt(iout,a,iv,irs,ics,head,ivr,ivc) + use psb_spmat_type + integer, intent(in) :: iout + type(psb_sspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: irs,ics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:),ivc(:) + end subroutine psb_scsprt subroutine psb_dcsprt(iout,a,iv,irs,ics,head,ivr,ivc) use psb_spmat_type integer, intent(in) :: iout @@ -237,6 +378,15 @@ module psb_serial_mod character(len=*), optional :: head integer, intent(in), optional :: ivr(:),ivc(:) end subroutine psb_dcsprt + subroutine psb_ccsprt(iout,a,iv,irs,ics,head,ivr,ivc) + use psb_spmat_type + integer, intent(in) :: iout + type(psb_cspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: irs,ics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:),ivc(:) + end subroutine psb_ccsprt subroutine psb_zcsprt(iout,a,iv,irs,ics,head,ivr,ivc) use psb_spmat_type integer, intent(in) :: iout @@ -249,6 +399,15 @@ module psb_serial_mod end interface interface psb_neigh + subroutine psb_sneigh(a,idx,neigh,n,info,lev) + use psb_spmat_type + type(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_sneigh subroutine psb_dneigh(a,idx,neigh,n,info,lev) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a @@ -258,6 +417,15 @@ module psb_serial_mod integer, intent(out) :: info integer, optional, intent(in) :: lev end subroutine psb_dneigh + subroutine psb_cneigh(a,idx,neigh,n,info,lev) + use psb_spmat_type + type(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + end subroutine psb_cneigh subroutine psb_zneigh(a,idx,neigh,n,info,lev) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a @@ -270,6 +438,16 @@ module psb_serial_mod end interface interface psb_coins + subroutine psb_scoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + use psb_spmat_type + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, optional, intent(in) :: rebuild + end subroutine psb_scoins subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) use psb_spmat_type integer, intent(in) :: nz, imin,imax,jmin,jmax @@ -280,6 +458,16 @@ module psb_serial_mod integer, intent(in), optional :: gtl(:) logical, optional, intent(in) :: rebuild end subroutine psb_dcoins + subroutine psb_ccoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + use psb_spmat_type + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, optional, intent(in) :: rebuild + end subroutine psb_ccoins subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) use psb_spmat_type integer, intent(in) :: nz, imin,imax,jmin,jmax @@ -294,11 +482,21 @@ module psb_serial_mod interface psb_symbmm + subroutine psb_ssymbmm(a,b,c,info) + use psb_spmat_type + type(psb_sspmat_type) :: a,b,c + integer :: info + end subroutine psb_ssymbmm subroutine psb_dsymbmm(a,b,c,info) use psb_spmat_type type(psb_dspmat_type) :: a,b,c integer :: info end subroutine psb_dsymbmm + subroutine psb_csymbmm(a,b,c,info) + use psb_spmat_type + type(psb_cspmat_type) :: a,b,c + integer :: info + end subroutine psb_csymbmm subroutine psb_zsymbmm(a,b,c,info) use psb_spmat_type type(psb_zspmat_type) :: a,b,c @@ -307,10 +505,18 @@ module psb_serial_mod end interface interface psb_numbmm + subroutine psb_snumbmm(a,b,c) + use psb_spmat_type + type(psb_sspmat_type) :: a,b,c + end subroutine psb_snumbmm subroutine psb_dnumbmm(a,b,c) use psb_spmat_type type(psb_dspmat_type) :: a,b,c end subroutine psb_dnumbmm + subroutine psb_cnumbmm(a,b,c) + use psb_spmat_type + type(psb_cspmat_type) :: a,b,c + end subroutine psb_cnumbmm subroutine psb_znumbmm(a,b,c) use psb_spmat_type type(psb_zspmat_type) :: a,b,c @@ -318,12 +524,24 @@ module psb_serial_mod end interface interface psb_transp + subroutine psb_stransp(a,b,c,fmt) + use psb_spmat_type + type(psb_sspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_stransp subroutine psb_dtransp(a,b,c,fmt) use psb_spmat_type type(psb_dspmat_type) :: a,b integer, optional :: c character(len=*), optional :: fmt end subroutine psb_dtransp + subroutine psb_ctransp(a,b,c,fmt) + use psb_spmat_type + type(psb_cspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_ctransp subroutine psb_ztransp(a,b,c,fmt) use psb_spmat_type type(psb_zspmat_type) :: a,b @@ -333,6 +551,12 @@ module psb_serial_mod end interface interface psb_transc + subroutine psb_ctransc(a,b,c,fmt) + use psb_spmat_type + type(psb_cspmat_type) :: a,b + integer, optional :: c + character(len=*), optional :: fmt + end subroutine psb_ctransc subroutine psb_ztransc(a,b,c,fmt) use psb_spmat_type type(psb_zspmat_type) :: a,b @@ -342,6 +566,14 @@ module psb_serial_mod end interface interface psb_rwextd + subroutine psb_srwextd(nr,a,info,b,rowscale) + use psb_spmat_type + integer, intent(in) :: nr + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: b + logical, intent(in), optional :: rowscale + end subroutine psb_srwextd subroutine psb_drwextd(nr,a,info,b,rowscale) use psb_spmat_type integer, intent(in) :: nr @@ -350,6 +582,14 @@ module psb_serial_mod type(psb_dspmat_type), intent(in), optional :: b logical, intent(in), optional :: rowscale end subroutine psb_drwextd + subroutine psb_crwextd(nr,a,info,b,rowscale) + use psb_spmat_type + integer, intent(in) :: nr + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: b + logical, intent(in), optional :: rowscale + end subroutine psb_crwextd subroutine psb_zrwextd(nr,a,info,b,rowscale) use psb_spmat_type integer, intent(in) :: nr @@ -361,6 +601,13 @@ module psb_serial_mod end interface interface psb_csnmi + function psb_scsnmi(a,info,trans) + use psb_spmat_type + type(psb_sspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + real(psb_spk_) :: psb_scsnmi + end function psb_scsnmi function psb_dcsnmi(a,info,trans) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a @@ -368,6 +615,13 @@ module psb_serial_mod character, optional :: trans real(psb_dpk_) :: psb_dcsnmi end function psb_dcsnmi + function psb_ccsnmi(a,info,trans) + use psb_spmat_type + type(psb_cspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + real(psb_spk_) :: psb_ccsnmi + end function psb_ccsnmi function psb_zcsnmi(a,info,trans) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a @@ -378,6 +632,15 @@ module psb_serial_mod end interface interface psb_sp_clip + subroutine psb_sspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) + use psb_spmat_type + implicit none + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(out) :: b + integer, intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_sspclip subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) use psb_spmat_type implicit none @@ -387,6 +650,15 @@ module psb_serial_mod integer, intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale end subroutine psb_dspclip + subroutine psb_cspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) + use psb_spmat_type + implicit none + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(out) :: b + integer, intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_cspclip subroutine psb_zspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) use psb_spmat_type implicit none @@ -399,12 +671,24 @@ module psb_serial_mod end interface interface psb_sp_getdiag + subroutine psb_sspgtdiag(a,d,info) + use psb_spmat_type + type(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + end subroutine psb_sspgtdiag subroutine psb_dspgtdiag(a,d,info) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(inout) :: d(:) integer, intent(out) :: info end subroutine psb_dspgtdiag + subroutine psb_cspgtdiag(a,d,info) + use psb_spmat_type + type(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + end subroutine psb_cspgtdiag subroutine psb_zspgtdiag(a,d,info) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a @@ -414,6 +698,18 @@ module psb_serial_mod end interface interface psb_sp_scal + subroutine psb_sspscals(a,d,info) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_sspscals + subroutine psb_sspscal(a,d,info) + use psb_spmat_type + type(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_sspscal subroutine psb_dspscals(a,d,info) use psb_spmat_type type(psb_dspmat_type), intent(inout) :: a @@ -426,6 +722,18 @@ module psb_serial_mod real(psb_dpk_), intent(in) :: d(:) integer, intent(out) :: info end subroutine psb_dspscal + subroutine psb_cspscals(a,d,info) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_cspscals + subroutine psb_cspscal(a,d,info) + use psb_spmat_type + type(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + end subroutine psb_cspscal subroutine psb_zspscals(a,d,info) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -484,6 +792,17 @@ module psb_serial_mod end interface interface psb_sp_getblk + subroutine psb_sspgtblk(irw,a,b,info,append,iren,lrw,srt) + use psb_spmat_type + type(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_sspmat_type), intent(inout) :: b + integer, intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + logical, intent(in), optional :: srt + end subroutine psb_sspgtblk subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw,srt) use psb_spmat_type type(psb_dspmat_type), intent(in) :: a @@ -495,6 +814,17 @@ module psb_serial_mod integer, intent(in), optional :: lrw logical, intent(in), optional :: srt end subroutine psb_dspgtblk + subroutine psb_cspgtblk(irw,a,b,info,append,iren,lrw,srt) + use psb_spmat_type + type(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_cspmat_type), intent(inout) :: b + integer, intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + logical, intent(in), optional :: srt + end subroutine psb_cspgtblk subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw,srt) use psb_spmat_type type(psb_zspmat_type), intent(in) :: a @@ -509,6 +839,21 @@ module psb_serial_mod end interface interface psb_sp_getrow + subroutine psb_sspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) + ! Output is always in COO format + use psb_spmat_type + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: lrw, nzin + end subroutine psb_sspgetrow subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) ! Output is always in COO format use psb_spmat_type @@ -524,6 +869,21 @@ module psb_serial_mod integer, intent(in), optional :: iren(:) integer, intent(in), optional :: lrw, nzin end subroutine psb_dspgetrow + subroutine psb_cspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) + ! Output is always in COO format + use psb_spmat_type + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: lrw, nzin + end subroutine psb_cspgetrow subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) ! Output is always in COO format use psb_spmat_type @@ -561,6 +921,21 @@ module psb_serial_mod interface psb_gelp ! 2-D version + subroutine psb_sgelp(trans,iperm,x,info) + use psb_const_mod + real(psb_spk_), intent(inout) :: x(:,:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + end subroutine psb_sgelp + ! 1-D version + subroutine psb_sgelpv(trans,iperm,x,info) + use psb_const_mod + real(psb_spk_), intent(inout) :: x(:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + end subroutine psb_sgelpv subroutine psb_dgelp(trans,iperm,x,info) use psb_const_mod real(psb_dpk_), intent(inout) :: x(:,:) @@ -577,6 +952,22 @@ module psb_serial_mod character, intent(in) :: trans end subroutine psb_dgelpv ! 2-D version + subroutine psb_cgelp(trans,iperm,x,info) + use psb_const_mod + complex(psb_spk_), intent(inout) :: x(:,:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + end subroutine psb_cgelp + ! 1-D version + subroutine psb_cgelpv(trans,iperm,x,info) + use psb_const_mod + complex(psb_spk_), intent(inout) :: x(:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + end subroutine psb_cgelpv + ! 2-D version subroutine psb_zgelp(trans,iperm,x,info) use psb_const_mod complex(psb_dpk_), intent(inout) :: x(:,:) diff --git a/base/modules/psb_sort_mod.f90 b/base/modules/psb_sort_mod.f90 index 7838961b1..17f89f341 100644 --- a/base/modules/psb_sort_mod.f90 +++ b/base/modules/psb_sort_mod.f90 @@ -64,19 +64,29 @@ module psb_sort_mod integer, allocatable :: keys(:) integer, allocatable :: idxs(:) end type psb_int_idx_heap + type psb_real_idx_heap + integer :: last, dir + real(psb_spk_), allocatable :: keys(:) + integer, allocatable :: idxs(:) + end type psb_real_idx_heap type psb_double_idx_heap - integer :: last, dir + integer :: last, dir real(psb_dpk_), allocatable :: keys(:) - integer, allocatable :: idxs(:) + integer, allocatable :: idxs(:) end type psb_double_idx_heap + type psb_scomplex_idx_heap + integer :: last, dir + complex(psb_spk_), allocatable :: keys(:) + integer, allocatable :: idxs(:) + end type psb_scomplex_idx_heap type psb_dcomplex_idx_heap - integer :: last, dir + integer :: last, dir complex(psb_dpk_), allocatable :: keys(:) - integer, allocatable :: idxs(:) + integer, allocatable :: idxs(:) end type psb_dcomplex_idx_heap interface psb_msort - module procedure imsort, dmsort, zamsort + module procedure imsort, dmsort, zamsort, smsort, camsort end interface interface psb_msort_unique @@ -84,35 +94,40 @@ module psb_sort_mod end interface interface psb_qsort - module procedure iqsort, dqsort, zqsort + module procedure iqsort, sqsort, cqsort, dqsort, zqsort end interface interface psb_hsort - module procedure ihsort, dhsort, zhsort + module procedure ihsort, shsort, chsort, dhsort, zhsort end interface interface psb_init_heap module procedure psb_init_int_heap, psb_init_int_idx_heap,& - & psb_init_double_idx_heap, psb_init_dcomplex_idx_heap + & psb_init_double_idx_heap, psb_init_dcomplex_idx_heap, & + & psb_init_real_idx_heap, psb_init_scomplex_idx_heap end interface interface psb_dump_heap module procedure psb_dump_int_heap, psb_dump_int_idx_heap,& + & psb_dump_real_idx_heap, psb_dump_scomplex_idx_heap, & & psb_dump_double_idx_heap, psb_dump_dcomplex_idx_heap end interface interface psb_howmany_heap module procedure psb_howmany_int_heap, psb_howmany_int_idx_heap,& + & psb_howmany_real_idx_heap, psb_howmany_scomplex_idx_heap,& & psb_howmany_double_idx_heap, psb_howmany_dcomplex_idx_heap end interface interface psb_insert_heap module procedure psb_insert_int_heap, psb_insert_int_idx_heap,& + & psb_insert_real_idx_heap, psb_insert_scomplex_idx_heap,& & psb_insert_double_idx_heap, psb_insert_dcomplex_idx_heap end interface interface psb_heap_get_first module procedure psb_int_heap_get_first, psb_int_idx_heap_get_first,& + & psb_real_idx_heap_get_first, psb_scomplex_idx_heap_get_first,& & psb_double_idx_heap_get_first, psb_dcomplex_idx_heap_get_first end interface @@ -179,6 +194,65 @@ contains end subroutine imsort + subroutine smsort(x,ix,dir,flag) + use psb_error_mod + implicit none + real(psb_spk_), 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_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + 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 + end if + 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 + + call smsrx(n,x,ix,dir_,flag_) + else + call smsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine smsort + subroutine dmsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -238,6 +312,65 @@ contains end if end subroutine dmsort + subroutine camsort(x,ix,dir,flag) + use psb_error_mod + implicit none + complex(psb_spk_), 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_msort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_asort_up_ + end if + select case(dir_) + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + 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 + end if + 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 + + call camsrx(n,x,ix,dir_,flag_) + else + call camsr(n,x,dir_) + end if + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine camsort + subroutine zamsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -414,6 +547,81 @@ contains end subroutine iqsort + subroutine sqsort(x,ix,dir,flag) + use psb_error_mod + implicit none + real(psb_spk_), 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) + + 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 ssrx(n,x,ix,dir_,flag_) + else + call ssr(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 sasrx(n,x,ix,dir_,flag_) + else + call sasr(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 == psb_act_abort_) then + call psb_error() + return + end if + end subroutine sqsort + subroutine dqsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -490,6 +698,95 @@ contains end subroutine dqsort + subroutine cqsort(x,ix,dir,flag) + use psb_error_mod + implicit none + complex(psb_spk_), 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_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 clsrx(n,x,ix,dir_,flag_) + else + call clsr(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 calsrx(n,x,ix,dir_,flag_) + else + call calsr(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 casrx(n,x,ix,dir_,flag_) + else + call casr(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 == psb_act_abort_) then + call psb_error() + return + end if + end subroutine cqsort + + subroutine zqsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -689,6 +986,114 @@ contains end subroutine ihsort + subroutine shsort(x,ix,dir,flag) + use psb_error_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + real(psb_spk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + 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 + + select case(dir_) + case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + 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 + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_real_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_real_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_real_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_real_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine shsort + + subroutine dhsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -797,6 +1202,114 @@ contains end subroutine dhsort + subroutine chsort(x,ix,dir,flag) + use psb_error_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, i, l, err_act,info + complex(psb_spk_) :: key + integer :: index + + character(len=20) :: name + + name='psb_hsort' + 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_asort_up_ + end if + + select case(dir_) + case(psb_asort_up_,psb_asort_down_) + ! OK + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_! + ! + dir_ = -dir_ + + 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 + if (flag_==psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_insert_scomplex_idx_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_scomplex_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_scomplex_heap(key,l,x,dir_,info) + if (l /= i) then + write(0,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_scomplex_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(0,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + +9999 continue + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine chsort + + subroutine zhsort(x,ix,dir,flag) use psb_error_mod implicit none @@ -905,7 +1418,6 @@ contains end subroutine zhsort - function psb_howmany_int_heap(heap) implicit none type(psb_int_heap), intent(in) :: heap @@ -1006,6 +1518,115 @@ contains end subroutine psb_int_heap_get_first + function psb_howmany_real_idx_heap(heap) + implicit none + type(psb_real_idx_heap), intent(in) :: heap + integer :: psb_howmany_real_idx_heap + psb_howmany_real_idx_heap = heap%last + end function psb_howmany_real_idx_heap + + subroutine psb_init_real_idx_heap(heap,info,dir) + use psb_realloc_mod + implicit none + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return + end subroutine psb_init_real_idx_heap + + subroutine psb_dump_real_idx_heap(iout,heap,info) + implicit none + type(psb_real_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if + end subroutine psb_dump_real_idx_heap + + subroutine psb_insert_real_idx_heap(key,index,heap,info) + use psb_realloc_mod + implicit none + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + + call psi_insert_real_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return + end subroutine psb_insert_real_idx_heap + + subroutine psb_real_idx_heap_get_first(key,index,heap,info) + implicit none + + type(psb_real_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + real(psb_spk_), intent(out) :: key + + info = 0 + + call psi_real_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return + end subroutine psb_real_idx_heap_get_first + function psb_howmany_double_idx_heap(heap) implicit none @@ -1227,6 +1848,118 @@ contains + function psb_howmany_scomplex_idx_heap(heap) + implicit none + type(psb_scomplex_idx_heap), intent(in) :: heap + integer :: psb_howmany_scomplex_idx_heap + psb_howmany_scomplex_idx_heap = heap%last + end function psb_howmany_scomplex_idx_heap + + subroutine psb_init_scomplex_idx_heap(heap,info,dir) + use psb_realloc_mod + implicit none + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + integer, intent(in), optional :: dir + + info = 0 + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) +!!$ case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + case (psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(0,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_asort_up_ + end select + + call psb_ensure_size(psb_heap_resize,heap%keys,info) + call psb_ensure_size(psb_heap_resize,heap%idxs,info) + return + end subroutine psb_init_scomplex_idx_heap + + subroutine psb_dump_scomplex_idx_heap(iout,heap,info) + implicit none + type(psb_scomplex_idx_heap), intent(in) :: heap + integer, intent(out) :: info + integer, intent(in) :: iout + + info = 0 + if (iout < 0) then + write(0,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) 0) then + write(iout,*) heap%keys(1:heap%last) + write(iout,*) heap%idxs(1:heap%last) + end if + end if + end subroutine psb_dump_scomplex_idx_heap + + subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) + use psb_realloc_mod + implicit none + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: info + + info = 0 + if (heap%last < 0) then + write(0,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info == 0) & + & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) + if (info /= 0) then + write(0,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_scomplex_idx_heap(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return + end subroutine psb_insert_scomplex_idx_heap + + subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) + implicit none + + type(psb_scomplex_idx_heap), intent(inout) :: heap + integer, intent(out) :: index,info + complex(psb_spk_), intent(out) :: key + + + info = 0 + + call psi_scomplex_idx_heap_get_first(key,index,& + & heap%last,heap%keys,heap%idxs,heap%dir,info) + + return + end subroutine psb_scomplex_idx_heap_get_first + + + function psb_howmany_dcomplex_idx_heap(heap) implicit none type(psb_dcomplex_idx_heap), intent(in) :: heap @@ -1570,8 +2303,235 @@ contains end subroutine psi_int_heap_get_first - - + + subroutine psi_insert_real_heap(key,last,heap,dir,info) + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + real(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_insert_real_heap + + + subroutine psi_real_heap_get_first(key,last,heap,dir,info) + implicit none + + real(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + real(psb_spk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_real_heap_get_first + + subroutine psi_insert_double_heap(key,last,heap,dir,info) implicit none @@ -1802,6 +2762,234 @@ contains + subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: last + integer, intent(out) :: info + integer :: i, i2 + complex(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_insert_scomplex_heap + + + subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) + implicit none + + complex(psb_spk_), intent(inout) :: key + integer, intent(inout) :: last + integer, intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: info + + integer :: i, j + complex(psb_spk_) :: temp + + + info = 0 + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_scomplex_heap_get_first + + subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) implicit none @@ -2289,6 +3477,264 @@ contains return end subroutine psi_int_idx_heap_get_first + subroutine psi_insert_real_idx_heap(key,index,last,heap,idxs,dir,info) + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + real(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_insert_real_idx_heap + + subroutine psi_real_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + implicit none + + real(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + real(psb_spk_), intent(out) :: key + + integer :: i, j,itemp + real(psb_spk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_real_idx_heap_get_first + + subroutine psi_insert_double_idx_heap(key,index,last,heap,idxs,dir,info) implicit none @@ -2547,6 +3993,264 @@ contains end subroutine psi_double_idx_heap_get_first + subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + integer, intent(in) :: index,dir + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(inout) :: idxs(:),last + integer, intent(out) :: info + integer :: i, i2, itemp + complex(psb_spk_) :: temp + + info = 0 + if (last < 0) then + write(0,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(0,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) < heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ do +!!$ if (i<=1) exit +!!$ i2 = i/2 +!!$ if (heap(i) > heap(i2)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(i2) +!!$ idxs(i2) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(i2) +!!$ heap(i2) = temp +!!$ i = i2 +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_insert_scomplex_idx_heap + + subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + implicit none + + complex(psb_spk_), intent(inout) :: heap(:) + integer, intent(out) :: index,info + integer, intent(inout) :: last,idxs(:) + integer, intent(in) :: dir + complex(psb_spk_), intent(out) :: key + + integer :: i, j, itemp + complex(psb_spk_) :: temp + + info = 0 + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) +!!$ case (psb_sort_up_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) < heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) > heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do +!!$ +!!$ +!!$ case (psb_sort_down_) +!!$ +!!$ i = 1 +!!$ do +!!$ if (i > (last/2)) exit +!!$ if ( (heap(2*i) > heap(2*i+1)) .or.& +!!$ & (2*i == last)) then +!!$ j = 2*i +!!$ else +!!$ j = 2*i + 1 +!!$ end if +!!$ +!!$ if (heap(i) < heap(j)) then +!!$ itemp = idxs(i) +!!$ idxs(i) = idxs(j) +!!$ idxs(j) = itemp +!!$ temp = heap(i) +!!$ heap(i) = heap(j) +!!$ heap(j) = temp +!!$ i = j +!!$ else +!!$ exit +!!$ end if +!!$ end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(0,*) 'Invalid direction in heap ',dir + end select + + return + end subroutine psi_scomplex_idx_heap_get_first + + subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) implicit none diff --git a/base/modules/psb_spmat_type.f90 b/base/modules/psb_spmat_type.f90 index 0b20731e4..54ea1c590 100644 --- a/base/modules/psb_spmat_type.f90 +++ b/base/modules/psb_spmat_type.f90 @@ -121,6 +121,26 @@ module psb_spmat_type + type psb_sspmat_type + integer :: m, k + character(len=5) :: fida + character(len=11) :: descra + integer :: infoa(psb_ifasize_) + real(psb_spk_), allocatable :: aspk(:) + integer, allocatable :: ia1(:), ia2(:) + integer, allocatable :: pl(:), pr(:) + end type psb_sspmat_type + + type psb_cspmat_type + integer :: m, k + character(len=5) :: fida + character(len=11) :: descra + integer :: infoa(psb_ifasize_) + complex(psb_spk_), allocatable :: aspk(:) + integer, allocatable :: ia1(:), ia2(:) + integer, allocatable :: pl(:), pr(:) + end type psb_cspmat_type + type psb_dspmat_type integer :: m, k character(len=5) :: fida @@ -130,6 +150,7 @@ module psb_spmat_type integer, allocatable :: ia1(:), ia2(:) integer, allocatable :: pl(:), pr(:) end type psb_dspmat_type + type psb_zspmat_type integer :: m, k character(len=5) :: fida @@ -141,85 +162,133 @@ module psb_spmat_type end type psb_zspmat_type interface psb_nullify_sp - module procedure psb_nullify_dsp, psb_nullify_zsp + module procedure psb_nullify_ssp, psb_nullify_csp,& + & psb_nullify_dsp, psb_nullify_zsp end interface interface psb_sp_clone - module procedure psb_dspclone, psb_zspclone + module procedure psb_sspclone, psb_cspclone,& + & psb_dspclone, psb_zspclone end interface interface psb_sp_setifld - module procedure psb_dsp_setifld, psb_zsp_setifld + module procedure psb_ssp_setifld, psb_csp_setifld,& + & psb_dsp_setifld, psb_zsp_setifld end interface interface psb_sp_getifld - module procedure psb_dsp_getifld, psb_zsp_getifld + module procedure psb_ssp_getifld, psb_csp_getifld,& + & psb_dsp_getifld, psb_zsp_getifld end interface interface psb_sp_transfer - module procedure psb_dsp_transfer, psb_zsp_transfer + module procedure psb_ssp_transfer, psb_csp_transfer,& + & psb_dsp_transfer, psb_zsp_transfer end interface interface psb_sp_trim - module procedure psb_dsp_trim, psb_zsp_trim + module procedure psb_ssp_trim, psb_csp_trim,& + & psb_dsp_trim, psb_zsp_trim end interface interface psb_sp_trimsize - module procedure psb_dsp_trimsize, psb_zsp_trimsize + module procedure psb_ssp_trimsize, psb_csp_trimsize,& + & psb_dsp_trimsize, psb_zsp_trimsize end interface interface psb_sp_reall - module procedure psb_dspreallocate, psb_dspreall3, & + module procedure psb_sspreallocate, psb_sspreall3, & + & psb_cspreall3, psb_cspreallocate,& + & psb_dspreallocate, psb_dspreall3, & & psb_zspreall3, psb_zspreallocate end interface interface psb_sp_all - module procedure psb_dspallocate, psb_dspall3, psb_dspallmk, psb_dspallmknz,& - & psb_zspallocate, psb_zspall3, psb_zspallmk, psb_zspallmknz + module procedure psb_sspallocate, psb_sspall3, psb_sspallmk, psb_sspallmknz, & + & psb_cspallocate, psb_cspall3, psb_cspallmk, psb_cspallmknz, & + & psb_dspallocate, psb_dspall3, psb_dspallmk, psb_dspallmknz, & + & psb_zspallocate, psb_zspall3, psb_zspallmk, psb_zspallmknz end interface interface psb_sp_free - module procedure psb_dsp_free, psb_zsp_free + module procedure psb_ssp_free, psb_csp_free,& + & psb_dsp_free, psb_zsp_free end interface interface psb_sp_reinit - module procedure psb_dspreinit, psb_zspreinit + module procedure psb_sspreinit, psb_cspreinit, & + & psb_dspreinit, psb_zspreinit end interface interface psb_sizeof - module procedure psb_dspsizeof, psb_zspsizeof + module procedure psb_sspsizeof, psb_cspsizeof,& + & psb_dspsizeof, psb_zspsizeof end interface interface psb_sp_get_nrows - module procedure psb_get_dsp_nrows, psb_get_zsp_nrows + module procedure psb_get_ssp_nrows, psb_get_csp_nrows,& + & psb_get_dsp_nrows, psb_get_zsp_nrows end interface interface psb_sp_get_ncols - module procedure psb_get_dsp_ncols, psb_get_zsp_ncols + module procedure psb_get_ssp_ncols, psb_get_csp_ncols,& + & psb_get_dsp_ncols, psb_get_zsp_ncols end interface interface psb_sp_get_nnzeros - module procedure psb_get_dsp_nnzeros, psb_get_zsp_nnzeros + module procedure psb_get_ssp_nnzeros, psb_get_csp_nnzeros,& + & psb_get_dsp_nnzeros, psb_get_zsp_nnzeros end interface interface psb_sp_get_nzsize - module procedure psb_get_dsp_nzsize, psb_get_zsp_nzsize + module procedure psb_get_ssp_nzsize, psb_get_csp_nzsize,& + & psb_get_dsp_nzsize, psb_get_zsp_nzsize end interface interface psb_sp_get_nnz_row - module procedure psb_get_dsp_nnz_row, psb_get_zsp_nnz_row + module procedure psb_get_ssp_nnz_row, psb_get_csp_nnz_row,& + & psb_get_dsp_nnz_row, psb_get_zsp_nnz_row end interface interface psb_sp_info - module procedure psb_dspinfo, psb_zspinfo + module procedure psb_sspinfo, psb_cspinfo, & + & psb_dspinfo, psb_zspinfo end interface contains + integer function psb_get_ssp_nrows(a) + type(psb_sspmat_type), intent(in) :: a + psb_get_ssp_nrows = a%m + + return + end function psb_get_ssp_nrows + + integer function psb_get_ssp_ncols(a) + type(psb_sspmat_type), intent(in) :: a + psb_get_ssp_ncols = a%k + + return + end function psb_get_ssp_ncols + integer function psb_get_csp_nrows(a) + type(psb_cspmat_type), intent(in) :: a + psb_get_csp_nrows = a%m + + return + end function psb_get_csp_nrows + + integer function psb_get_csp_ncols(a) + type(psb_cspmat_type), intent(in) :: a + psb_get_csp_ncols = a%k + + return + end function psb_get_csp_ncols + + integer function psb_get_dsp_nrows(a) type(psb_dspmat_type), intent(in) :: a psb_get_dsp_nrows = a%m @@ -248,6 +317,30 @@ contains end function psb_get_zsp_ncols + integer function psb_get_ssp_nnzeros(a) + type(psb_sspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nztotreq_,a,ires,info) + if (info == 0) then + psb_get_ssp_nnzeros = ires + else + psb_get_ssp_nnzeros = 0 + end if + end function psb_get_ssp_nnzeros + + integer function psb_get_csp_nnzeros(a) + type(psb_cspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nztotreq_,a,ires,info) + if (info == 0) then + psb_get_csp_nnzeros = ires + else + psb_get_csp_nnzeros = 0 + end if + end function psb_get_csp_nnzeros + integer function psb_get_dsp_nnzeros(a) type(psb_dspmat_type), intent(in) :: a integer :: ires,info @@ -272,6 +365,30 @@ contains end if end function psb_get_zsp_nnzeros + integer function psb_get_ssp_nzsize(a) + type(psb_sspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nzsizereq_,a,ires,info) + if (info == 0) then + psb_get_ssp_nzsize = ires + else + psb_get_ssp_nzsize = 0 + end if + end function psb_get_ssp_nzsize + + integer function psb_get_csp_nzsize(a) + type(psb_cspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nzsizereq_,a,ires,info) + if (info == 0) then + psb_get_csp_nzsize = ires + else + psb_get_csp_nzsize = 0 + end if + end function psb_get_csp_nzsize + integer function psb_get_dsp_nzsize(a) type(psb_dspmat_type), intent(in) :: a integer :: ires,info @@ -296,6 +413,31 @@ contains end if end function psb_get_zsp_nzsize + integer function psb_get_ssp_nnz_row(ir,a) + integer, intent(in) :: ir + type(psb_sspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nzrowreq_,a,ires,info,iaux=ir) + if (info == 0) then + psb_get_ssp_nnz_row = ires + else + psb_get_ssp_nnz_row = 0 + end if + end function psb_get_ssp_nnz_row + + integer function psb_get_csp_nnz_row(ir,a) + integer, intent(in) :: ir + type(psb_cspmat_type), intent(in) :: a + integer :: ires,info + + call psb_sp_info(psb_nzrowreq_,a,ires,info,iaux=ir) + if (info == 0) then + psb_get_csp_nnz_row = ires + else + psb_get_csp_nnz_row = 0 + end if + end function psb_get_csp_nnz_row integer function psb_get_dsp_nnz_row(ir,a) integer, intent(in) :: ir @@ -309,6 +451,7 @@ contains psb_get_dsp_nnz_row = 0 end if end function psb_get_dsp_nnz_row + integer function psb_get_zsp_nnz_row(ir,a) integer, intent(in) :: ir type(psb_zspmat_type), intent(in) :: a @@ -323,6 +466,543 @@ contains end function psb_get_zsp_nnz_row + subroutine psb_nullify_ssp(mat) + implicit none + type(psb_sspmat_type), intent(inout) :: mat + +!!$ nullify(mat%aspk,mat%ia1,mat%ia2,mat%pl,mat%pr) + + mat%infoa(:)=0 + mat%m=0 + mat%k=0 + mat%fida='' + mat%descra='' + + end subroutine psb_nullify_ssp + + Subroutine psb_sspreinit(a,info,clear) + use psb_string_mod + Implicit None + + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + + !locals + logical, parameter :: debug=.false. + logical :: clear_ + character(len=20) :: name + + info = 0 + name = 'psb_sp_reinit' + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + select case(psb_sp_getifld(psb_state_,a,info)) + case(psb_spmat_asb_) + + if (clear_) a%aspk(:) = dzero + + if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then + if(psb_toupper(a%fida(1:3)) == 'JAD') then + a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 + else + a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 + endif + endif + a%infoa(psb_state_) = psb_spmat_upd_ + case(psb_spmat_bld_) + ! in this case do nothing. this allows sprn to be called + ! right after allocate, with spins doing the right thing. + ! hopefully :-) + + case( psb_spmat_upd_) + + case default + info=591 + call psb_errpush(info,name) + end select + + end Subroutine psb_sspreinit + + Subroutine psb_sspallocate(a, nnz,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: nnz + integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (nnz < 0) then + info=45 + return + Endif + if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k + call psb_nullify_sp(a) + call psb_sp_reall(a,nnz,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + 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' + Return + + End Subroutine psb_sspallocate + + Subroutine psb_sspallmk(m,k,a,info) + implicit none + !....Parameters... + + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: m,k + Integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + integer :: nnz + + INFO = 0 + call psb_nullify_sp(a) + nnz = 2*max(1,m,k) + a%m=max(0,m) + a%k=max(0,k) + if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k + call psb_sp_reall(a,nnz,info) + if (debug) write(0,*) 'Check in ALLOCATE ',info,allocated(a%pl),allocated(a%pr) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + a%fida = 'COO' + a%descra = 'GUN' + a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ + if (debug) write(0,*) 'SPALL : end' + Return + + end subroutine psb_sspallmk + + Subroutine psb_sspallmknz(m,k,a, nnz,info) + implicit none + !....parameters... + + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: m,k,nnz + integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (nnz < 0) then + info=45 + return + endif + call psb_nullify_sp(a) + if (debug) write(0,*) 'spallmknz : nnz ',nnz,a%m,a%k,psb_get_errstatus() + a%m=max(0,m) + a%k=max(0,k) + call psb_sp_reall(a,nnz,info) + if (debug) write(0,*) 'Check in ALLOCATE ',info,allocated(a%pl),allocated(a%pr) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set infoa fields + a%fida = 'COO' + a%descra = 'GUN' + a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ + if (debug) write(0,*) 'spall : end' + return + + end subroutine psb_sspallmknz + + + subroutine psb_sspall3(a, ni1,ni2,nd,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: ni1,ni2,nd + Integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + call psb_nullify_sp(a) + call psb_sp_reall(a, ni1,ni2,nd,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + 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' + Return + + End Subroutine psb_sspall3 + + + subroutine psb_sspreallocate(a, nnz,info,ifc) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: NNZ + Integer, intent(out) :: info + ! + ! ifc is used here to allocate space in IA1 for smart + ! regeneration. This probably ought to be changed, + ! by adding a new component to d_spmat, or by making + ! infoa a pointer. + ! + Integer, intent(in), optional :: ifc + integer :: ifc_ + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (nnz < 0) then + info=45 + return + endif + if (present(ifc)) then + ifc_ = max(1,ifc) + else + ifc_ = 1 + endif + + if (ifc_ == 1) then + if (debug) write(0,*) 'sspreallocate: calling realloc',max(nnz,a%m+1,a%k+1) + call psb_realloc(max(nnz,a%m+1,a%k+1),a%ia1,a%ia2,a%aspk,info) + if (debug) write(0,*) 'sspreallocate: done realloc',info, psb_get_errstatus() + else + call psb_realloc(max(nnz,a%m+1,a%k+1),a%aspk,info) + if (info /= 0) return + call psb_realloc(max(nnz,a%m+1,a%k+1),a%ia2,info) + if (info /= 0) return + call psb_realloc(max(ifc*nnz+200,a%m+1,a%k+1),a%ia1,info) + if (info /= 0) return + end if + if (info /= 0) return + call psb_realloc(max(1,a%m),a%pl,info) + if (info /= 0) return + call psb_realloc(max(1,a%k),a%pr,info) + if (debug) write(0,*) 'sspreallocate:',allocated(a%ia1),allocated(a%ia2),& + & allocated(a%aspk),allocated(a%pl),allocated(a%pr),info + if (info /= 0) return + + Return + + End Subroutine psb_sspreallocate + + subroutine psb_sspreall3(a, ni1,ni2,nd,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: ni1,ni2,nd + Integer, intent(inout) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (debug) write(0,*) 'Before realloc',nd,size(a%aspk),ni1,ni2 + call psb_realloc(nd,a%aspk,info) + if (debug) write(0,*) 'After realloc',nd,size(a%aspk),info + if (info /= 0) return + if (debug) write(0,*) 'Before realloc2',ni2,allocated(a%ia2),size(a%ia2) + call psb_realloc(ni2,a%ia2,info) + if (info /= 0) return + if (debug) write(0,*) 'Before realloc3',ni1,allocated(a%ia1),size(a%ia1) + call psb_realloc(ni1,a%ia1,info) + if (info /= 0) return + if (debug) write(0,*) 'Before realloc4',max(1,a%m),allocated(a%pl),size(a%pl) + call psb_realloc(max(1,a%m),a%pl,info) + if (info /= 0) return + if (debug) write(0,*) 'Before realloc5',max(1,a%k),allocated(a%pr),size(a%pr) + call psb_realloc(max(1,a%k),a%pr,info) + if (info /= 0) return + + Return + + End Subroutine psb_sspreall3 + + + subroutine psb_sspclone(a, b,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(in) :: A + Type(psb_sspmat_type), intent(out) :: B + Integer, intent(out) :: info + + !locals + + INFO = 0 + call psb_nullify_sp(b) + call psb_safe_ab_cpy(a%aspk,b%aspk,info) + if (info == 0) call psb_safe_ab_cpy(a%ia1,b%ia1,info) + if (info == 0) call psb_safe_ab_cpy(a%ia2,b%ia2,info) + if (info == 0) call psb_safe_ab_cpy(a%pl,b%pl,info) + if (info == 0) call psb_safe_ab_cpy(a%pr,b%pr,info) + if (info /= 0) then + info=2023 + return + Endif + b%infoa(:) = a%infoa(:) + b%fida = a%fida + b%descra = a%descra + b%m = a%m + b%k = a%k + + Return + + End Subroutine psb_sspclone + + + + ! Will be changed to use MOVE_ALLOC + subroutine psb_ssp_transfer(a, b,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Type(psb_sspmat_type), intent(inout) :: B + Integer, intent(out) :: info + + info = 0 + + + call psb_transfer( a%aspk, b%aspk , info) + call psb_transfer( a%ia1 , b%ia1 , info) + call psb_transfer( a%ia2 , b%ia2 , info) + call psb_transfer( a%pl , b%pl , info) + call psb_transfer( a%pr , b%pr , info) + b%infoa(:) = a%infoa(:) + b%fida = a%fida + b%descra = a%descra + b%m = a%m + b%k = a%k + + call psb_nullify_sp(a) + + Return + + End Subroutine psb_ssp_transfer + + + Subroutine psb_ssp_setifld(val,field,a,info) + implicit none + !....Parameters... + + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(in) :: field,val + Integer, intent(out) :: info + + info = 0 + + + if (info == 0) & + & call psb_setifield(val,field,a%infoa,psb_ifasize_,info) + + + Return + + end subroutine psb_ssp_setifld + + + ! + ! Reduce the size of A to the barest minimum necessary. + ! + ! + + + subroutine psb_ssp_trim(a,info) + use psb_string_mod + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + + !locals + Integer :: i1, i2, ia + + info = 0 + call psb_sp_trimsize(a,i1,i2,ia,info) + i1 = max(i1,1); i2 = max(i2,1); ia = max(ia,1) + if (info == 0) call psb_sp_reall(a,i1,i2,ia,info) + + Return + + End Subroutine psb_ssp_trim + + + subroutine psb_ssp_trimsize(a, i1,i2,ia,info) + use psb_string_mod + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(in) :: A + Integer, intent(out) :: i1, i2, ia, info + + !locals + Integer :: nza + + info = 0 + if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then + info = -1 + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + return + endif + select case(psb_tolower(a%fida)) + case('csr') + nza = a%ia2(a%m+1)-1 + ia = nza + i1 = nza + i2 = a%m + 1 + case('csc') + nza = a%ia2(a%k+1)-1 + ia = nza + i1 = nza + i2 = a%k + 1 + case('coo','coi') + nza = a%infoa(psb_nnz_) + i1 = nza + i2 = nza + ia = nza + case('jad') + ! Feeling lazy today + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + case default + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + end select + + Return + + End Subroutine psb_ssp_trimsize + + function psb_ssp_getifld(field,a,info) + implicit none + !....Parameters... + + Type(psb_sspmat_type), intent(in) :: A + Integer, intent(in) :: field + Integer :: psb_ssp_getifld + Integer, intent(out) :: info + + !locals + integer :: val + + info = 0 + val = -1 + + if ((field < 1).or.(field > psb_ifasize_)) then + info = -1 + psb_ssp_getifld = val + return + endif + + call psb_getifield(val,field,a%infoa,psb_ifasize_,info) + + psb_ssp_getifld = val + Return + + end function psb_ssp_getifld + + function psb_sspsizeof(a) + implicit none + !....Parameters... + + Type(psb_sspmat_type), intent(in) :: A + Integer :: psb_sspsizeof + + !locals + integer :: val + + val = psb_sizeof_int*size(a%infoa) + + if (allocated(a%aspk)) then + val = val + psb_sizeof_sp * size(a%aspk) + endif + + if (allocated(a%ia1)) then + val = val + psb_sizeof_int * size(a%ia1) + endif + if (allocated(a%ia2)) then + val = val + psb_sizeof_int * size(a%ia2) + endif + if (allocated(a%pl)) then + val = val + psb_sizeof_int * size(a%pl) + endif + if (allocated(a%pr)) then + val = val + psb_sizeof_int * size(a%pr) + endif + + + psb_sspsizeof = val + Return + + end function psb_sspsizeof + + + subroutine psb_ssp_free(a,info) + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + !locals + integer :: iret + info = 0 + + if (allocated(a%aspk)) then +!!$ write(0,*) 'Deallocating aspk' + deallocate(a%aspk,STAT=IRET) +!!$ write(0,*) 'Deallocated aspk',iret + if (iret /= 0) info = max(info,1) + endif + if (allocated(a%ia1)) then + deallocate(a%ia1,STAT=IRET) + if (iret /= 0) info = max(info,2) + endif + if (allocated(a%ia2)) then + deallocate(a%ia2,STAT=IRET) + if (iret /= 0) info = max(info,3) + endif + if (allocated(a%pr)) then + deallocate(a%pr,STAT=IRET) + if (iret /= 0) info = max(info,4) + endif + if (allocated(a%pl)) then + deallocate(a%pl,STAT=IRET) + if (iret /= 0) info = max(info,5) + endif + call psb_nullify_sp(a) +!!$ write(0,*) 'End of sp_free ',info + Return + End Subroutine psb_ssp_free + subroutine psb_nullify_dsp(mat) implicit none type(psb_dspmat_type), intent(inout) :: mat @@ -338,7 +1018,7 @@ contains end subroutine psb_nullify_dsp Subroutine psb_dspreinit(a,info,clear) - + use psb_string_mod use psb_string_mod Implicit None @@ -709,24 +1389,6 @@ contains End Subroutine psb_dsp_trim - subroutine psb_zsp_trim(a,info) - use psb_string_mod - implicit none - !....Parameters... - Type(psb_zspmat_type), intent(inout) :: A - Integer, intent(out) :: info - !locals - Integer :: i1, i2, ia - - info = 0 - call psb_sp_trimsize(a,i1,i2,ia,info) - i1 = max(i1,1); i2 = max(i2,1); ia = max(ia,1) - if (info == 0) call psb_sp_reall(a,i1,i2,ia,info) - - Return - - End Subroutine psb_zsp_trim - subroutine psb_dsp_trimsize(a, i1,i2,ia,info) use psb_string_mod @@ -878,6 +1540,508 @@ contains End Subroutine psb_dsp_free + subroutine psb_nullify_csp(mat) + implicit none + type(psb_cspmat_type), intent(inout) :: mat + + mat%infoa(:)=0 + mat%m=0 + mat%k=0 + mat%fida='' + mat%descra='' + + end subroutine psb_nullify_csp + + Subroutine psb_cspreinit(a,info,clear) + use psb_string_mod + Implicit None + + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + + !locals + logical :: clear_ + character(len=20) :: name + + info = 0 + name = 'psb_sp_reinit' + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + select case(psb_sp_getifld(psb_state_,a,info)) + case(psb_spmat_asb_) + + if (clear_) a%aspk(:) = zzero + + if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then + if(psb_toupper(a%fida(1:3)) == 'JAD') then + a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 + else + a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0 + endif + endif + a%infoa(psb_state_) = psb_spmat_upd_ + case(psb_spmat_bld_) + ! in this case do nothing. this allows sprn to be called + ! right after allocate, with spins doing the right thing. + ! hopefully :-) + + case( psb_spmat_upd_) + + case default + info=591 + call psb_errpush(info,name) + end select + + end Subroutine psb_cspreinit + + Subroutine psb_cspallocate(a, nnz,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: nnz + integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (nnz < 0) then + info=45 + return + Endif + call psb_nullify_sp(a) + if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k + call psb_sp_reall(a,nnz,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + 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' + Return + + End Subroutine psb_cspallocate + + Subroutine psb_cspallmk(m,k,a,info) + implicit none + !....Parameters... + + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: m,k + Integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + integer :: nnz + + INFO = 0 + nnz = 2*max(1,m,k) + call psb_nullify_sp(a) + if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k + a%m=max(0,m) + a%k=max(0,k) + call psb_sp_reall(a,nnz,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + a%fida = 'COO' + a%descra = 'GUN' + a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ + if (debug) write(0,*) 'SPALL : end' + Return + + end subroutine psb_cspallmk + + Subroutine psb_cspallmknz(m,k,a, nnz,info) + implicit none + !....parameters... + + type(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: m,k,nnz + integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + if (nnz < 0) then + info=45 + return + endif + call psb_nullify_sp(a) + if (debug) write(0,*) 'spall : nnz ',nnz,a%m,a%k + a%m=max(0,m) + a%k=max(0,k) + call psb_sp_reall(a,nnz,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set infoa fields + a%fida = 'COO' + a%descra = 'GUN' + a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ + if (debug) write(0,*) 'spall : end' + return + + end subroutine psb_cspallmknz + + + subroutine psb_cspall3(a, ni1,ni2,nd,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: ni1,ni2,nd + Integer, intent(out) :: info + + !locals + logical, parameter :: debug=.false. + + info = 0 + + call psb_nullify_sp(a) + call psb_sp_reall(a, ni1,ni2,nd,info) + if (info /= 0) return + a%pl(:)=0 + a%pr(:)=0 + ! set INFOA fields + 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' + Return + + End Subroutine psb_cspall3 + + subroutine psb_cspreall3(a, ni1,ni2,nz,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: ni1,ni2,nz + Integer, intent(inout) :: info + + + info = 0 + call psb_realloc(nz,a%aspk,info) + if (info /= 0) return + call psb_realloc(ni2,a%ia2,info) + if (info /= 0) return + call psb_realloc(ni1,a%ia1,info) + if (info /= 0) return + call psb_realloc(max(1,a%m),a%pl,info) + if (info /= 0) return + call psb_realloc(max(1,a%k),a%pr,info) + if (info /= 0) return + + Return + + End Subroutine psb_cspreall3 + + + subroutine psb_cspreallocate(a, nnz,info,ifc) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: NNZ + Integer, intent(out) :: info + ! + ! ifc is used here to allocate space in IA1 for smart + ! regeneration. This probably ought to be changed, + ! by adding a new component to d_spmat, or by making + ! infoa a pointer. + ! + Integer, intent(in), optional :: ifc + integer :: ifc_ + + info = 0 + if (nnz < 0) then + info=45 + return + endif + if (present(ifc)) then + ifc_ = max(1,ifc) + else + ifc_ = 1 + endif + + if (ifc_ == 1) then + call psb_realloc(max(nnz,a%m+1,a%k+1),a%ia1,a%ia2,a%aspk,info) + else + call psb_realloc(max(nnz,a%m+1,a%k+1),a%aspk,info) + if (info /= 0) return + call psb_realloc(max(nnz,a%m+1,a%k+1),a%ia2,info) + if (info /= 0) return + call psb_realloc(ifc*nnz+200,a%ia1,info) + if (info /= 0) return + end if + if (info /= 0) return + call psb_realloc(max(1,a%m),a%pl,info) + if (info /= 0) return + call psb_realloc(max(1,a%k),a%pr,info) + if (info /= 0) return + + Return + + End Subroutine psb_cspreallocate + + subroutine psb_cspclone(a, b,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(in) :: A + Type(psb_cspmat_type), intent(out) :: B + Integer, intent(out) :: info + + + INFO = 0 + call psb_nullify_sp(b) + call psb_safe_ab_cpy(a%aspk,b%aspk,info) + if (info == 0) call psb_safe_ab_cpy(a%ia1,b%ia1,info) + if (info == 0) call psb_safe_ab_cpy(a%ia2,b%ia2,info) + if (info == 0) call psb_safe_ab_cpy(a%pl,b%pl,info) + if (info == 0) call psb_safe_ab_cpy(a%pr,b%pr,info) + if (info /= 0) then + info=2023 + return + Endif + b%infoa(:) = a%infoa(:) + b%fida = a%fida + b%descra = a%descra + b%m = a%m + b%k = a%k + + Return + + End Subroutine psb_cspclone + + + ! This is done with pointer assignments, but it + ! will be feasible with MOVE_ALLOC when we move + ! to ALLOCATABLE components. + subroutine psb_csp_transfer(a, b,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Type(psb_cspmat_type), intent(inout) :: B + Integer, intent(out) :: info + + info = 0 + + call psb_transfer( a%aspk, b%aspk , info) + call psb_transfer( a%ia1 , b%ia1 , info) + call psb_transfer( a%ia2 , b%ia2 , info) + call psb_transfer( a%pl , b%pl , info) + call psb_transfer( a%pr , b%pr , info) + b%infoa(:) = a%infoa(:) + b%fida = a%fida + b%descra = a%descra + b%m = a%m + b%k = a%k + + call psb_nullify_sp(a) + + Return + + End Subroutine psb_csp_transfer + + Subroutine psb_csp_setifld(val,field,a,info) + implicit none + !....Parameters... + + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(in) :: field,val + Integer, intent(out) :: info + + + info = 0 + + + if (info == 0) & + & call psb_setifield(val,field,a%infoa,psb_ifasize_,info) + + + Return + + end subroutine psb_csp_setifld + + + subroutine psb_csp_trim(a,info) + use psb_string_mod + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + !locals + Integer :: i1, i2, ia + + info = 0 + call psb_sp_trimsize(a,i1,i2,ia,info) + i1 = max(i1,1); i2 = max(i2,1); ia = max(ia,1) + if (info == 0) call psb_sp_reall(a,i1,i2,ia,info) + + Return + + End Subroutine psb_csp_trim + + subroutine psb_csp_trimsize(a, i1,i2,ia,info) + use psb_string_mod + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(in) :: A + Integer, intent(out) :: i1, i2, ia, info + + !locals + Integer :: nza + + info = 0 + if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then + info = -1 + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + return + endif + select case(psb_tolower(a%fida)) + case('csr') + nza = a%ia2(a%m+1)-1 + ia = nza + i1 = nza + i2 = a%m + 1 + case('csc') + nza = a%ia2(a%k+1)-1 + ia = nza + i1 = nza + i2 = a%k + 1 + case('coo','coi') + nza = a%infoa(psb_nnz_) + i1 = nza + i2 = nza + ia = nza + case('jad') + ! Feeling lazy today + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + case default + i1 = size(a%ia1) + i2 = size(a%ia2) + ia = size(a%aspk) + end select + + Return + + End Subroutine psb_csp_trimsize + + function psb_csp_getifld(field,a,info) + implicit none + !....Parameters... + + Type(psb_cspmat_type), intent(in) :: A + Integer, intent(in) :: field + Integer :: psb_csp_getifld + Integer, intent(out) :: info + + !locals + integer :: val + + info = 0 + val = -1 + + if ((field < 1).or.(field > psb_ifasize_)) then + info = -1 + psb_csp_getifld = val + return + endif + + call psb_getifield(val,field,a%infoa,psb_ifasize_,info) + + psb_csp_getifld = val + Return + + end function psb_csp_getifld + + function psb_cspsizeof(a) + implicit none + !....Parameters... + + Type(psb_cspmat_type), intent(in) :: A + Integer :: psb_cspsizeof + + !locals + integer :: val + + val = psb_sizeof_int*size(a%infoa) + + if (allocated(a%aspk)) then + val = val + 2 * psb_sizeof_dp * size(a%aspk) + endif + + if (allocated(a%ia1)) then + val = val + psb_sizeof_int * size(a%ia1) + endif + if (allocated(a%ia2)) then + val = val + psb_sizeof_int * size(a%ia2) + endif + if (allocated(a%pl)) then + val = val + psb_sizeof_int * size(a%pl) + endif + if (allocated(a%pr)) then + val = val + psb_sizeof_int * size(a%pr) + endif + + + psb_cspsizeof = val + Return + + end function psb_cspsizeof + + + + + subroutine psb_csp_free(a,info) + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + + info = 0 + + if (allocated(a%aspk)) then + deallocate(a%aspk,STAT=INFO) + endif + if (allocated(a%ia1)) then + deallocate(a%ia1,STAT=INFO) + endif + if ( allocated(a%ia2)) then + deallocate(a%ia2,STAT=INFO) + endif + if ( allocated(a%pr)) then + deallocate(a%pr,STAT=INFO) + endif + if ( allocated(a%pl)) then + deallocate(a%pl,STAT=INFO) + endif + call psb_nullify_sp(a) + Return + End Subroutine psb_csp_free + + subroutine psb_nullify_zsp(mat) implicit none type(psb_zspmat_type), intent(inout) :: mat @@ -1219,6 +2383,24 @@ contains end subroutine psb_zsp_setifld + subroutine psb_zsp_trim(a,info) + use psb_string_mod + implicit none + !....Parameters... + Type(psb_zspmat_type), intent(inout) :: A + Integer, intent(out) :: info + !locals + Integer :: i1, i2, ia + + info = 0 + call psb_sp_trimsize(a,i1,i2,ia,info) + i1 = max(i1,1); i2 = max(i2,1); ia = max(ia,1) + if (info == 0) call psb_sp_reall(a,i1,i2,ia,info) + + Return + + End Subroutine psb_zsp_trim + subroutine psb_zsp_trimsize(a, i1,i2,ia,info) use psb_string_mod implicit none @@ -1361,6 +2543,166 @@ contains Return End Subroutine psb_zsp_free + + subroutine psb_sspinfo(ireq,a,ires,info,iaux) + use psb_const_mod + use psb_error_mod + use psb_string_mod + implicit none + + type(psb_sspmat_type), intent(in), target :: a + integer, intent(in) :: ireq + integer, intent(out) :: ires, info + integer, intent(in), optional :: iaux + + integer :: j,ip,jp,nr,irw,nz, err_act, row, ipx, pia, pja, rb,idx, nc + integer, pointer :: ia1(:), ia2(:), ia3(:), ja(:) + character(len=20) :: name, ch_err + + name='psb_sspinfo' + info = 0 + call psb_erractionsave(err_act) + + + if (ireq == psb_nztotreq_) then + ! The number of nonzeroes + if (psb_toupper(a%fida) == 'CSR') then + nr = a%m + ires = a%ia2(nr+1)-1 + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + ires = a%infoa(psb_nnz_) + else if (psb_toupper(a%fida) == 'JAD') then + ires = a%infoa(psb_nnz_) + else if (psb_toupper(a%fida) == 'CSC') then + nc = a%k + ires = a%ia2(nc+1)-1 + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (ireq == psb_nzrowreq_) then + ! The number of nonzeroes in row iaux + if (.not.present(iaux)) then + write(0,*) 'Need IAUX when ireq=nzrowreq' + ires=-1 + return + endif + irw = iaux + if (irw > a%m) then + write(0,*) 'SPINFO: Accessing out of bounds? ',irw,a%m + ires = 0 + return + endif + if (psb_toupper(a%fida) == 'CSR') then + ires = a%ia2(irw+1)-a%ia2(irw) + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then + ! In this case we can do a binary search. + nz = a%infoa(psb_nnz_) + call ibsrch(ip,irw,nz,a%ia1) + jp = ip + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia1(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + do + if (jp > nz) exit + if (a%ia1(jp) == irw) then + jp =jp + 1 + else + exit + endif + end do + ires = jp-ip + else + ires = count(a%ia1(1:a%infoa(psb_nnz_))==irw) + endif +!!$ ires = 0 +!!$ do i=1, a%infoa(psb_nnz_) +!!$ if (a%ia1(i) == irw) ires = ires + 1 +!!$ enddo + else if (psb_toupper(a%fida) == 'JAD') then + pia = a%ia2(2) ! points to the beginning of ia(3,png) + pja = a%ia2(3) ! points to the beginning of ja(:) + ja => a%ia2(pja:) ! the array containing the pointers to ka and aspk + 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 + + idx=a%pl(irw) + j=0 + nz=0 + blkfnd: do + j=j+1 + if(ia1(j) == idx) then + nz=nz+ia3(j)-ia2(j) + ipx = ia1(j) ! the first row index of the block + rb = idx-ipx ! the row offset within the block + row = ia3(j)+rb + nz = nz+ja(row+1)-ja(row) + exit blkfnd + else if(ia1(j) > idx) then + nz=nz+ia3(j-1)-ia2(j-1) + ipx = ia1(j-1) ! the first row index of the block + rb = idx-ipx ! the row offset within the block + row = ia3(j-1)+rb + nz = nz+ja(row+1)-ja(row) + exit blkfnd + end if + end do blkfnd + ires=nz + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (ireq == psb_nzsizereq_) then + if (psb_toupper(a%fida) == 'CSR') then + ires = size(a%aspk) + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + ires = size(a%aspk) + else if (psb_toupper(a%fida) == 'JAD') then + ires = a%infoa(psb_nnz_) + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + write(0,*) 'Unknown request into SPINFO' + ires=-1 + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine psb_sspinfo + subroutine psb_dspinfo(ireq,a,ires,info,iaux) use psb_const_mod use psb_error_mod @@ -1520,6 +2862,159 @@ contains end subroutine psb_dspinfo + subroutine psb_cspinfo(ireq,a,ires,info,iaux) + use psb_const_mod + use psb_error_mod + use psb_string_mod + implicit none + + type(psb_cspmat_type), intent(in), target :: a + integer, intent(in) :: ireq + integer, intent(out) :: ires, info + integer, intent(in), optional :: iaux + + integer :: j,ip,jp,nr,irw,nz, err_act, row, ipx, pia, pja, rb,idx, nc + integer, pointer :: ia1(:), ia2(:), ia3(:), ja(:) + character(len=20) :: name, ch_err + + name='psb_cspinfo' + info = 0 + call psb_erractionsave(err_act) + + + if (ireq == psb_nztotreq_) then + ! The number of nonzeroes + if (psb_toupper(a%fida) == 'CSR') then + nr = a%m + ires = a%ia2(nr+1)-1 + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + ires = a%infoa(psb_nnz_) + else if (psb_toupper(a%fida) == 'JAD') then + ires = a%infoa(psb_nnz_) + else if (psb_toupper(a%fida) == 'CSC') then + nc = a%k + ires = a%ia2(nc+1)-1 + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (ireq == psb_nzrowreq_) then + ! The number of nonzeroes in row iaux + if (.not.present(iaux)) then + write(0,*) 'Need IAUX when ireq=nzrowreq' + ires=-1 + return + endif + irw = iaux + if (psb_toupper(a%fida) == 'CSR') then + ires = a%ia2(irw+1)-a%ia2(irw) + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then + ! In this case we can do a binary search. + nz = a%infoa(psb_nnz_) + call ibsrch(ip,irw,nz,a%ia1) + jp = ip + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia1(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + do + if (jp > nz) exit + if (a%ia1(jp) == irw) then + jp =jp + 1 + else + exit + endif + end do + ires = jp-ip + else + ires = count(a%ia1(1:a%infoa(psb_nnz_))==irw) + endif +!!$ ires = 0 +!!$ do i=1, a%infoa(psb_nnz_) +!!$ if (a%ia1(i) == irw) ires = ires + 1 +!!$ enddo + else if (psb_toupper(a%fida) == 'JAD') then + pia = a%ia2(2) ! points to the beginning of ia(3,png) + pja = a%ia2(3) ! points to the beginning of ja(:) + ja => a%ia2(pja:) ! the array containing the pointers to ka and aspk + 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 + + idx=a%pl(irw) + j=0 + nz=0 + blkfnd: do + j=j+1 + if(ia1(j) == idx) then + nz=nz+ia3(j)-ia2(j) + ipx = ia1(j) ! the first row index of the block + rb = idx-ipx ! the row offset within the block + row = ia3(j)+rb + nz = nz+ja(row+1)-ja(row) + exit blkfnd + else if(ia1(j) > idx) then + nz=nz+ia3(j-1)-ia2(j-1) + ipx = ia1(j-1) ! the first row index of the block + rb = idx-ipx ! the row offset within the block + row = ia3(j-1)+rb + nz = nz+ja(row+1)-ja(row) + exit blkfnd + end if + end do blkfnd + ires=nz + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (ireq == psb_nzsizereq_) then + if (psb_toupper(a%fida) == 'CSR') then + ires = size(a%aspk) + else if ((psb_toupper(a%fida) == 'COO').or.(psb_toupper(a%fida) == 'COI')) then + ires = size(a%aspk) + else if (psb_toupper(a%fida) == 'JAD') then + ires = a%infoa(psb_nnz_) + else + ires=-1 + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + write(0,*) 'Unknown request into SPINFO' + ires=-1 + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine psb_cspinfo subroutine psb_zspinfo(ireq,a,ires,info,iaux) use psb_const_mod diff --git a/base/modules/psb_spsb_mod.f90 b/base/modules/psb_spsb_mod.f90 index a20eb0917..589bb691e 100644 --- a/base/modules/psb_spsb_mod.f90 +++ b/base/modules/psb_spsb_mod.f90 @@ -31,7 +31,7 @@ !!$ module psb_spsb_mod - interface + interface dot function ddot(n,dx,incx,dy,incy) use psb_const_mod real(psb_dpk_) :: dx(*),dy(*),dtemp @@ -40,7 +40,7 @@ module psb_spsb_mod end function ddot end interface - interface + interface axpby subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod real(psb_dpk_) :: X(lldx,*), Y(lldy,*) @@ -49,7 +49,7 @@ module psb_spsb_mod end subroutine daxpby end interface - interface + interface csmm subroutine dcsmm(trans,m,n,k,alpha,pl,fida,descra,a,ia1,ia2,& & infoa,pr,b,ldb,beta,c,ldc,work,lwork,ierror) use psb_const_mod @@ -62,7 +62,7 @@ module psb_spsb_mod end subroutine dcsmm end interface - interface + interface csnmi function dcsnmi(trans,m,n,fida,descra,a,ia1,ia2,& & infoa,ierror) use psb_const_mod @@ -75,7 +75,8 @@ module psb_spsb_mod end function dcsnmi end interface - interface + + interface csrp subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,infoa,& & p,work,lwork,ierror) use psb_const_mod @@ -88,7 +89,7 @@ module psb_spsb_mod end subroutine dcsrp end interface - interface + interface cssm subroutine dcssm(trans,m,n,alpha,unitd,d,& & pl,fidt,descrt,t,it1,it2,infot,pr,& & b,ldb,beta,c,ldc,work,lwork,ierror) @@ -102,7 +103,8 @@ module psb_spsb_mod end subroutine dcssm end interface - interface + + interface csupd subroutine dcsupd(m, n, fida, descra, a, ia1,& & ia2, infoa, ia, ja, fidh, descrh, h, ih1, ih2,& & infoh, ih, jh, flag, glob_to_loc,& @@ -118,7 +120,7 @@ module psb_spsb_mod end subroutine dcsupd end interface - interface + interface gelp subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) use psb_const_mod integer :: ldb, m, n, lwork, ierror @@ -128,7 +130,7 @@ module psb_spsb_mod end subroutine dgelp end interface - interface + interface lpupd subroutine dlpupd(m,n,perm,b,ldb,beta,c,ldc) use psb_const_mod integer :: m, n, ldb, ldc @@ -138,7 +140,7 @@ module psb_spsb_mod end subroutine dlpupd end interface - interface + interface swmm subroutine dswmm(trans,m,n,k,alpha,fida,descra,a,ia1,ia2,& & infoa,b,ldb,beta,c,ldc,work,lwork,ierror) use psb_const_mod @@ -152,7 +154,8 @@ module psb_spsb_mod end interface - interface + + interface swprt subroutine dswprt(m,n,fida,descra,a,ia1,ia2,infoa,title,& & iout,ierror) use psb_const_mod @@ -162,7 +165,7 @@ module psb_spsb_mod end subroutine dswprt end interface - interface + interface swsm subroutine dswsm(trans,m,n,alpha,unitd,d,fidt,descrt,t,it1,it2,& & infot,b,ldb,beta,c,ldc,work,lwork,ierror) use psb_const_mod @@ -175,7 +178,7 @@ module psb_spsb_mod end subroutine dswsm end interface - interface + interface symbmm subroutine symbmm (n, m, l, ia, ja, diaga, ib,& & jb, diagb, ic, jc, diagc, index) integer :: ia(*), ja(*), diaga, ib(*),& diff --git a/base/modules/psb_string_mod.f90 b/base/modules/psb_string_mod.f90 index 5b53e7486..d04360562 100644 --- a/base/modules/psb_string_mod.f90 +++ b/base/modules/psb_string_mod.f90 @@ -57,12 +57,6 @@ contains do i=1,len(string) psb_tolowerc(i:i) = lower1c(string(i:i)) -!!$ k = index(ucase,string(i:i)) -!!$ if (k /=0 ) then -!!$ psb_tolowerc(i:i) = lcase(k:k) -!!$ else -!!$ psb_tolowerc(i:i) = string(i:i) -!!$ end if enddo end function psb_tolowerc @@ -73,12 +67,6 @@ contains do i=1,len(string) psb_toupperc(i:i) = upper1c(string(i:i)) -!!$ k = index(lcase,string(i:i)) -!!$ if (k /=0 ) then -!!$ psb_toupperc(i:i) = ucase(k:k) -!!$ else -!!$ psb_toupperc(i:i) = string(i:i) -!!$ end if enddo end function psb_toupperc diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index 746e1cebd..197ef99e7 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -34,7 +34,21 @@ Module psb_tools_mod use psb_spmat_type interface psb_geall - ! 2-D double precision version + subroutine psb_salloc(x, desc_a, info, n, lb) + use psb_descriptor_type + implicit none + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n, lb + end subroutine psb_salloc + subroutine psb_sallocv(x, desc_a,info,n) + use psb_descriptor_type + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n + end subroutine psb_sallocv subroutine psb_dalloc(x, desc_a, info, n, lb) use psb_descriptor_type implicit none @@ -43,7 +57,6 @@ Module psb_tools_mod integer,intent(out) :: info integer, optional, intent(in) :: n, lb end subroutine psb_dalloc - ! 1-D double precision version subroutine psb_dallocv(x, desc_a,info,n) use psb_descriptor_type real(psb_dpk_), allocatable, intent(out) :: x(:) @@ -51,7 +64,6 @@ Module psb_tools_mod integer,intent(out) :: info integer, optional, intent(in) :: n end subroutine psb_dallocv - ! 2-D integer version subroutine psb_ialloc(x, desc_a, info,n, lb) use psb_descriptor_type integer, allocatable, intent(out) :: x(:,:) @@ -66,7 +78,21 @@ Module psb_tools_mod integer :: info integer, optional, intent(in) :: n end subroutine psb_iallocv - ! 2-D double complex version + subroutine psb_calloc(x, desc_a, info, n, lb) + use psb_descriptor_type + implicit none + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + integer, optional, intent(in) :: n, lb + end subroutine psb_calloc + subroutine psb_callocv(x, desc_a,info,n) + use psb_descriptor_type + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + integer, optional, intent(in) :: n + end subroutine psb_callocv subroutine psb_zalloc(x, desc_a, info, n, lb) use psb_descriptor_type implicit none @@ -75,7 +101,6 @@ Module psb_tools_mod integer :: info integer, optional, intent(in) :: n, lb end subroutine psb_zalloc - ! 1-D double complex version subroutine psb_zallocv(x, desc_a,info,n) use psb_descriptor_type complex(psb_dpk_), allocatable, intent(out) :: x(:) @@ -87,42 +112,60 @@ Module psb_tools_mod interface psb_geasb - ! 2-D double precision version + subroutine psb_sasb(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer, intent(out) :: info + end subroutine psb_sasb + subroutine psb_sasbv(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer, intent(out) :: info + end subroutine psb_sasbv subroutine psb_dasb(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_), allocatable, intent(inout) :: x(:,:) integer, intent(out) :: info end subroutine psb_dasb - ! 1-D double precision version subroutine psb_dasbv(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a real(psb_dpk_), allocatable, intent(inout) :: x(:) integer, intent(out) :: info end subroutine psb_dasbv - ! 2-D integer version subroutine psb_iasb(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a integer, allocatable, intent(inout) :: x(:,:) integer, intent(out) :: info end subroutine psb_iasb - ! 1-D integer version subroutine psb_iasbv(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a integer, allocatable, intent(inout) :: x(:) integer, intent(out) :: info end subroutine psb_iasbv - ! 2-D double precision version + subroutine psb_casb(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer, intent(out) :: info + end subroutine psb_casb + subroutine psb_casbv(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer, intent(out) :: info + end subroutine psb_casbv subroutine psb_zasb(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) integer, intent(out) :: info end subroutine psb_zasb - ! 1-D double precision version subroutine psb_zasbv(x, desc_a, info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a @@ -132,6 +175,18 @@ Module psb_tools_mod end interface interface psb_sphalo + Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_descriptor_type + use psb_spmat_type + Type(psb_sspmat_type),Intent(in) :: a + Type(psb_sspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in),target :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer, intent(in), optional :: data + end Subroutine psb_ssphalo Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& & rowscale,colscale,outfmt,data) use psb_descriptor_type @@ -144,6 +199,18 @@ Module psb_tools_mod character(len=5), optional :: outfmt integer, intent(in), optional :: data end Subroutine psb_dsphalo + Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_descriptor_type + use psb_spmat_type + Type(psb_cspmat_type),Intent(in) :: a + Type(psb_cspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in) :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer, intent(in), optional :: data + end Subroutine psb_csphalo Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& & rowscale,colscale,outfmt,data) use psb_descriptor_type @@ -172,42 +239,60 @@ Module psb_tools_mod interface psb_gefree - ! 2-D double precision version + subroutine psb_sfree(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + end subroutine psb_sfree + subroutine psb_sfreev(x, desc_a, info) + use psb_descriptor_type + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + end subroutine psb_sfreev subroutine psb_dfree(x, desc_a, info) use psb_descriptor_type real(psb_dpk_),allocatable, intent(inout) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer :: info end subroutine psb_dfree - ! 1-D double precision version subroutine psb_dfreev(x, desc_a, info) use psb_descriptor_type real(psb_dpk_),allocatable, intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer :: info end subroutine psb_dfreev - ! 2-D integer version subroutine psb_ifree(x, desc_a, info) use psb_descriptor_type integer,allocatable, intent(inout) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer :: info end subroutine psb_ifree - ! 1-D integer version subroutine psb_ifreev(x, desc_a, info) use psb_descriptor_type integer, allocatable, intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer :: info end subroutine psb_ifreev - ! 2-D double precision version + subroutine psb_cfree(x, desc_a, info) + use psb_descriptor_type + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + end subroutine psb_cfree + subroutine psb_cfreev(x, desc_a, info) + use psb_descriptor_type + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + end subroutine psb_cfreev subroutine psb_zfree(x, desc_a, info) use psb_descriptor_type complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer :: info end subroutine psb_zfree - ! 1-D double precision version subroutine psb_zfreev(x, desc_a, info) use psb_descriptor_type complex(psb_dpk_),allocatable, intent(inout) :: x(:) @@ -218,7 +303,26 @@ Module psb_tools_mod interface psb_geins - ! 2-D double precision version + subroutine psb_sinsi(m,irw,val, x,desc_a,info,dupl) + use psb_descriptor_type + integer, intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:,:) + integer, intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_sinsi + subroutine psb_sinsvi(m,irw,val,x,desc_a,info,dupl) + use psb_descriptor_type + integer, intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:) + integer, intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_sinsvi subroutine psb_dinsi(m,irw,val, x,desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -229,7 +333,6 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: dupl end subroutine psb_dinsi - ! 1-D double precision version subroutine psb_dinsvi(m,irw,val,x,desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -240,7 +343,6 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: dupl end subroutine psb_dinsvi - ! 2-D double precision version subroutine psb_iinsi(m,irw,val, x,desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -251,7 +353,6 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: dupl end subroutine psb_iinsi - ! 1-D double precision version subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -262,7 +363,26 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: dupl end subroutine psb_iinsvi - ! 2-D double precision version + subroutine psb_cinsi(m,irw,val, x, desc_a,info,dupl) + use psb_descriptor_type + integer, intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:,:) + integer, intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_cinsi + subroutine psb_cinsvi(m, irw,val, x,desc_a,info,dupl) + use psb_descriptor_type + integer, intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_cinsvi subroutine psb_zinsi(m,irw,val, x, desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -273,7 +393,6 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: dupl end subroutine psb_zinsi - ! 1-D double precision version subroutine psb_zinsvi(m, irw,val, x,desc_a,info,dupl) use psb_descriptor_type integer, intent(in) :: m @@ -315,6 +434,16 @@ Module psb_tools_mod interface psb_cdbldext + Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info,extype) + use psb_descriptor_type + Use psb_spmat_type + integer, intent(in) :: novr + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in), target :: desc_a + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + end Subroutine psb_scdbldext Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info,extype) use psb_descriptor_type Use psb_spmat_type @@ -325,6 +454,16 @@ Module psb_tools_mod integer, intent(out) :: info integer, intent(in),optional :: extype end Subroutine psb_dcdbldext + Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info,extype) + use psb_descriptor_type + Use psb_spmat_type + integer, intent(in) :: novr + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in), target :: desc_a + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + end Subroutine psb_ccdbldext Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info,extype) use psb_descriptor_type Use psb_spmat_type @@ -358,6 +497,14 @@ Module psb_tools_mod end interface interface psb_spall + subroutine psb_sspalloc(a, desc_a, info, nnz) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_sspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + end subroutine psb_sspalloc subroutine psb_dspalloc(a, desc_a, info, nnz) use psb_descriptor_type use psb_spmat_type @@ -366,6 +513,14 @@ Module psb_tools_mod integer, intent(out) :: info integer, optional, intent(in) :: nnz end subroutine psb_dspalloc + subroutine psb_cspalloc(a, desc_a, info, nnz) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_cspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + end subroutine psb_cspalloc subroutine psb_zspalloc(a, desc_a, info, nnz) use psb_descriptor_type use psb_spmat_type @@ -377,6 +532,15 @@ Module psb_tools_mod end interface interface psb_spasb + subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl) + use psb_descriptor_type + use psb_spmat_type + type(psb_sspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_sspasb subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) use psb_descriptor_type use psb_spmat_type @@ -386,6 +550,15 @@ Module psb_tools_mod integer,optional, intent(in) :: dupl, upd character(len=*), optional, intent(in) :: afmt end subroutine psb_dspasb + subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl) + use psb_descriptor_type + use psb_spmat_type + type(psb_cspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_cspasb subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) use psb_descriptor_type use psb_spmat_type @@ -398,10 +571,17 @@ Module psb_tools_mod end interface interface psb_spfree - module procedure psb_dsp_free, psb_zsp_free + module procedure psb_ssp_free, psb_dsp_free, psb_zsp_free end interface interface psb_spfree + subroutine psb_sspfree(a, desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(inout) ::a + integer, intent(out) :: info + end subroutine psb_sspfree subroutine psb_dspfree(a, desc_a,info) use psb_descriptor_type use psb_spmat_type @@ -409,6 +589,13 @@ Module psb_tools_mod type(psb_dspmat_type), intent(inout) ::a integer, intent(out) :: info end subroutine psb_dspfree + subroutine psb_cspfree(a, desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(inout) ::a + integer, intent(out) :: info + end subroutine psb_cspfree subroutine psb_zspfree(a, desc_a,info) use psb_descriptor_type use psb_spmat_type @@ -420,6 +607,26 @@ Module psb_tools_mod interface psb_spins + subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + end subroutine psb_sspins + subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + end subroutine psb_sspins_2desc subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) use psb_descriptor_type use psb_spmat_type @@ -437,9 +644,29 @@ Module psb_tools_mod type(psb_desc_type), intent(inout) :: desc_ac type(psb_dspmat_type), intent(inout) :: a integer, intent(in) :: nz,ia(:),ja(:) - real(kind(1.d0)), intent(in) :: val(:) + real(psb_dpk_), intent(in) :: val(:) integer, intent(out) :: info end subroutine psb_dspins_2desc + subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + end subroutine psb_cspins + subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + end subroutine psb_cspins_2desc subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) use psb_descriptor_type use psb_spmat_type @@ -457,13 +684,21 @@ Module psb_tools_mod type(psb_desc_type), intent(inout) :: desc_ac type(psb_zspmat_type), intent(inout) :: a integer, intent(in) :: nz,ia(:),ja(:) - complex(kind(1.d0)), intent(in) :: val(:) + complex(psb_dpk_), intent(in) :: val(:) integer, intent(out) :: info end subroutine psb_zspins_2desc end interface interface psb_sprn + subroutine psb_ssprn(a, desc_a,info,clear) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + end subroutine psb_ssprn subroutine psb_dsprn(a, desc_a,info,clear) use psb_descriptor_type use psb_spmat_type @@ -472,6 +707,14 @@ Module psb_tools_mod integer, intent(out) :: info logical, intent(in), optional :: clear end subroutine psb_dsprn + subroutine psb_csprn(a, desc_a,info,clear) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + end subroutine psb_csprn subroutine psb_zsprn(a, desc_a,info,clear) use psb_descriptor_type use psb_spmat_type diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 3a5ca8e53..a7ee09233 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -96,57 +96,91 @@ module psi_mod end interface interface psi_swapdata + subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_sswapdatam + subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_sswapdatav + subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_sswapidxm + subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_sswapidxv subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_dswapdatam subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_dswapdatav subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag, n - integer, intent(out) :: info - real(psb_dpk_) :: y(:,:), beta + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + real(psb_dpk_) :: y(:,:), beta real(psb_dpk_),target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxm subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag - integer, intent(out) :: info - real(psb_dpk_) :: y(:), beta + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_dpk_) :: y(:), beta real(psb_dpk_),target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxv subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - integer :: y(:,:), beta - integer, target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag, n + integer, intent(out) :: info + integer :: y(:,:), beta + integer, target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_iswapdatam subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - integer :: y(:), beta - integer, target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + integer :: y(:), beta + integer, target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_iswapdatav subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod @@ -161,98 +195,166 @@ module psi_mod integer, intent(in) :: ictxt,icomm,flag integer, intent(out) :: info integer :: y(:), beta - integer,target :: work(:) + integer,target :: work(:) integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_iswapidxv - subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) + subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_zswapdatam - subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_cswapdatam + subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data - end subroutine psi_zswapdatav - subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_cswapdatav + subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod integer, intent(in) :: ictxt,icomm,flag, n integer, intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_cswapidxm + subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_cswapidxv + subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_zswapdatam + subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_zswapdatav + subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxm subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag - integer, intent(out) :: info - complex(psb_dpk_) :: y(:), beta + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_dpk_) :: y(:), beta complex(psb_dpk_),target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxv end interface interface psi_swaptran + subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_sswaptranm + subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_sswaptranv + subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_stranidxm + subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_stranidxv subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag, n + integer, intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_dswaptranm subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_dswaptranv subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag, n - integer, intent(out) :: info - real(psb_dpk_) :: y(:,:), beta + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + real(psb_dpk_) :: y(:,:), beta real(psb_dpk_),target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxm subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag - integer, intent(out) :: info - real(psb_dpk_) :: y(:), beta + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + real(psb_dpk_) :: y(:), beta real(psb_dpk_),target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxv subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - integer :: y(:,:), beta - integer,target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag, n + integer, intent(out) :: info + integer :: y(:,:), beta + integer,target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_iswaptranm subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - integer :: y(:), beta - integer,target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + integer :: y(:), beta + integer,target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_iswaptranv subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod @@ -270,39 +372,73 @@ module psi_mod integer, target :: work(:) integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_itranidxv + subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_cswaptranm + subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) + use psb_descriptor_type + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data + end subroutine psi_cswaptranv + subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ctranidxm + subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + use psb_const_mod + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer, intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ctranidxv subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag, n - integer, intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_zswaptranm subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) use psb_descriptor_type - integer, intent(in) :: flag - integer, intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer, optional :: data end subroutine psi_zswaptranv subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag, n - integer, intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta + integer, intent(in) :: ictxt,icomm,flag, n + integer, intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_), target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxm subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psb_const_mod - integer, intent(in) :: ictxt,icomm,flag - integer, intent(out) :: info - complex(psb_dpk_) :: y(:), beta + integer, intent(in) :: ictxt,icomm,flag + integer, intent(out) :: info + complex(psb_dpk_) :: y(:), beta complex(psb_dpk_), target :: work(:) - integer, intent(in) :: idx(:),totxch,totsnd,totrcv + integer, intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxv end interface @@ -427,18 +563,24 @@ module psi_mod interface psi_ovrl_upd module procedure psi_iovrl_updr1, psi_iovrl_updr2,& + & psi_sovrl_updr1, psi_sovrl_updr2, & + & psi_covrl_updr1, psi_covrl_updr2, & & psi_dovrl_updr1, psi_dovrl_updr2, & & psi_zovrl_updr1, psi_zovrl_updr2 end interface interface psi_ovrl_save module procedure psi_iovrl_saver1, psi_iovrl_saver2,& + & psi_sovrl_saver1, psi_sovrl_saver2,& + & psi_covrl_saver1, psi_covrl_saver2,& & psi_dovrl_saver1, psi_dovrl_saver2,& & psi_zovrl_saver1, psi_zovrl_saver2 end interface interface psi_ovrl_restore module procedure psi_iovrl_restrr1, psi_iovrl_restrr2,& + & psi_sovrl_restrr1, psi_sovrl_restrr2,& + & psi_covrl_restrr1, psi_covrl_restrr2,& & psi_dovrl_restrr1, psi_dovrl_restrr2,& & psi_zovrl_restrr1, psi_zovrl_restrr2 end interface @@ -683,6 +825,149 @@ contains end do end subroutine psi_inner_cnv2 + subroutine psi_sovrl_updr1(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_sovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + 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 psi_sovrl_updr1 + + + subroutine psi_sovrl_updr2(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_sovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + 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 psi_sovrl_updr2 + subroutine psi_dovrl_updr1(x,desc_a,update,info) use psb_descriptor_type use psb_const_mod @@ -826,6 +1111,149 @@ contains return end subroutine psi_dovrl_updr2 + subroutine psi_covrl_updr1(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_covrl_updr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + 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 psi_covrl_updr1 + + + subroutine psi_covrl_updr2(x,desc_a,update,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in) :: update + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, ndm + character(len=20) :: name, ch_err + + name='psi_covrl_updr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = 70 + call psb_errpush(info,name,i_err=(/3,update,0,0,0/)) + goto 9999 + end select + + 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 psi_covrl_updr2 + subroutine psi_zovrl_updr1(x,desc_a,update,info) use psb_descriptor_type use psb_const_mod @@ -1115,6 +1543,221 @@ contains end subroutine psi_iovrl_updr2 + subroutine psi_sovrl_saver1(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + 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 psi_sovrl_saver1 + + subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + 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 psi_sovrl_restrr1 + + + subroutine psi_sovrl_saver2(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_sovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + 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 psi_sovrl_saver2 + + subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + 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 psi_sovrl_restrr2 + subroutine psi_dovrl_saver1(x,xs,desc_a,info) use psb_descriptor_type @@ -1331,6 +1974,220 @@ contains return end subroutine psi_dovrl_restrr2 + subroutine psi_covrl_saver1(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_saver1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + 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 psi_covrl_saver1 + + subroutine psi_covrl_restrr1(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + 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 psi_covrl_restrr1 + + + subroutine psi_covrl_saver2(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_covrl_saver2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + 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 psi_covrl_saver2 + + subroutine psi_covrl_restrr2(x,xs,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = 4001 + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + 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 psi_covrl_restrr2 subroutine psi_zovrl_saver1(x,xs,desc_a,info) @@ -1764,321 +2621,6 @@ contains return end subroutine psi_iovrl_restrr2 - -!!$ subroutine psi_dgthzm(n,k,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ real(psb_dpk_) :: x(:,:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(pt)=x(idx(i),j) -!!$ end do -!!$ end do -!!$ -!!$ end subroutine psi_dgthzm -!!$ -!!$ subroutine psi_dgthzv(n,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ real(psb_dpk_) :: x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ do i=1,n -!!$ y(i)=x(idx(i)) -!!$ end do -!!$ -!!$ end subroutine psi_dgthzv -!!$ -!!$ -!!$ subroutine psi_dsctm(n,k,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ real(psb_dpk_) :: beta, x(:), y(:,:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ if (beta == dzero) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = x(pt) -!!$ end do -!!$ end do -!!$ else if (beta == done) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ else -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ end if -!!$ end subroutine psi_dsctm -!!$ -!!$ subroutine psi_dsctv(n,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ real(psb_dpk_) :: beta, x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ if (beta == dzero) then -!!$ do i=1,n -!!$ y(idx(i)) = x(i) -!!$ end do -!!$ else if (beta == done) then -!!$ do i=1,n -!!$ y(idx(i)) = y(idx(i))+x(i) -!!$ end do -!!$ else -!!$ do i=1,n -!!$ y(idx(i)) = beta*y(idx(i))+x(i) -!!$ end do -!!$ end if -!!$ end subroutine psi_dsctv -!!$ -!!$ -!!$ subroutine psi_igthzm(n,k,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ integer :: x(:,:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(pt)=x(idx(i),j) -!!$ end do -!!$ end do -!!$ -!!$ end subroutine psi_igthzm -!!$ -!!$ -!!$ subroutine psi_igthzv(n,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ integer :: x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ do i=1,n -!!$ y(i)=x(idx(i)) -!!$ end do -!!$ -!!$ end subroutine psi_igthzv -!!$ -!!$ -!!$ -!!$ subroutine psi_isctm(n,k,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ integer :: beta, x(:), y(:,:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ if (beta == izero) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = x(pt) -!!$ end do -!!$ end do -!!$ else if (beta == ione) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ else -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ end if -!!$ end subroutine psi_isctm -!!$ -!!$ subroutine psi_isctv(n,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ integer :: beta, x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ if (beta == izero) then -!!$ do i=1,n -!!$ y(idx(i)) = x(i) -!!$ end do -!!$ else if (beta == ione) then -!!$ do i=1,n -!!$ y(idx(i)) = y(idx(i))+x(i) -!!$ end do -!!$ else -!!$ do i=1,n -!!$ y(idx(i)) = beta*y(idx(i))+x(i) -!!$ end do -!!$ end if -!!$ end subroutine psi_isctv -!!$ -!!$ -!!$ subroutine psi_zgthzm(n,k,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ complex(psb_dpk_) :: x(:,:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(pt)=x(idx(i),j) -!!$ end do -!!$ end do -!!$ -!!$ end subroutine psi_zgthzm -!!$ -!!$ -!!$ subroutine psi_zgthzv(n,idx,x,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ complex(psb_dpk_) :: x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ do i=1,n -!!$ y(i)=x(idx(i)) -!!$ end do -!!$ -!!$ end subroutine psi_zgthzv -!!$ -!!$ subroutine psi_zsctm(n,k,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, k, idx(:) -!!$ complex(psb_dpk_) :: beta, x(:), y(:,:) -!!$ -!!$ ! Locals -!!$ integer :: i, j, pt -!!$ -!!$ if (beta == zzero) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = x(pt) -!!$ end do -!!$ end do -!!$ else if (beta == zone) then -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ else -!!$ pt=0 -!!$ do j=1,k -!!$ do i=1,n -!!$ pt=pt+1 -!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt) -!!$ end do -!!$ end do -!!$ end if -!!$ end subroutine psi_zsctm -!!$ -!!$ -!!$ subroutine psi_zsctv(n,idx,x,beta,y) -!!$ -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ integer :: n, idx(:) -!!$ complex(psb_dpk_) :: beta, x(:), y(:) -!!$ -!!$ ! Locals -!!$ integer :: i -!!$ -!!$ if (beta == zzero) then -!!$ do i=1,n -!!$ y(idx(i)) = x(i) -!!$ end do -!!$ else if (beta == zone) then -!!$ do i=1,n -!!$ y(idx(i)) = y(idx(i))+x(i) -!!$ end do -!!$ else -!!$ do i=1,n -!!$ y(idx(i)) = beta*y(idx(i))+x(i) -!!$ end do -!!$ end if -!!$ end subroutine psi_zsctv - subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) use psb_const_mod use psb_error_mod diff --git a/base/modules/psi_serial_mod.f90 b/base/modules/psi_serial_mod.f90 index 94e1e6743..7433a5f96 100644 --- a/base/modules/psi_serial_mod.f90 +++ b/base/modules/psi_serial_mod.f90 @@ -34,13 +34,15 @@ module psi_serial_mod interface psi_gth module procedure & - & psi_igthv, psi_dgthv, psi_zgthv,& - & psi_igthzv, psi_dgthzv, psi_zgthzv,& - & psi_igthzmv, psi_dgthzmv, psi_zgthzmv + & psi_igthv, psi_sgthv, psi_cgthv, psi_dgthv, psi_zgthv,& + & psi_igthzv, psi_sgthzv, psi_cgthzv, psi_dgthzv, psi_zgthzv,& + & psi_igthzmv, psi_sgthzmv, psi_cgthzmv, psi_dgthzmv, psi_zgthzmv end interface interface psi_sct module procedure psi_isctmv, psi_isctv,& + & psi_ssctmv, psi_ssctv,& + & psi_csctmv, psi_csctv,& & psi_dsctmv, psi_dsctv,& & psi_zsctmv, psi_zsctv end interface @@ -60,7 +62,11 @@ contains ! Locals integer :: i if (beta == izero) then - if (alpha == ione) then + if (alpha == izero) then + do i=1,n + y(i) = izero + end do + else if (alpha == ione) then do i=1,n y(i) = x(idx(i)) end do @@ -82,7 +88,9 @@ contains y(1:n) = beta*y(1:n) end if - if (alpha == ione) then + if (alpha == izero) then + ! do nothing + else if (alpha == ione) then do i=1,n y(i) = y(i) + x(idx(i)) end do @@ -99,6 +107,62 @@ contains end subroutine psi_igthv + subroutine psi_sgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:), alpha, beta + + ! Locals + integer :: i + if (beta == szero) then + if (alpha == szero) then + do i=1,n + y(i) = szero + end do + else if (alpha == sone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -sone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == sone) then + ! Do nothing + else if (beta == -sone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == szero) then + ! do nothing + else if (alpha == sone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -sone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + + end subroutine psi_sgthv + subroutine psi_dgthv(n,idx,alpha,x,beta,y) use psb_const_mod @@ -110,7 +174,11 @@ contains ! Locals integer :: i if (beta == dzero) then - if (alpha == done) then + if (alpha == dzero) then + do i=1,n + y(i) = dzero + end do + else if (alpha == done) then do i=1,n y(i) = x(idx(i)) end do @@ -132,7 +200,9 @@ contains y(1:n) = beta*y(1:n) end if - if (alpha == done) then + if (alpha == dzero) then + ! do nothing + else if (alpha == done) then do i=1,n y(i) = y(i) + x(idx(i)) end do @@ -149,6 +219,62 @@ contains end subroutine psi_dgthv + subroutine psi_cgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:),alpha,beta + + ! Locals + integer :: i + if (beta == czero) then + if (alpha == czero) then + do i=1,n + y(i) = czero + end do + else if (alpha == cone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -cone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == cone) then + ! Do nothing + else if (beta == -cone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == czero) then + ! do nothing + else if (alpha == cone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -cone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + + end subroutine psi_cgthv + subroutine psi_zgthv(n,idx,alpha,x,beta,y) use psb_const_mod @@ -160,7 +286,11 @@ contains ! Locals integer :: i if (beta == zzero) then - if (alpha == zone) then + if (alpha == zzero) then + do i=1,n + y(i) = zzero + end do + else if (alpha == zone) then do i=1,n y(i) = x(idx(i)) end do @@ -182,7 +312,9 @@ contains y(1:n) = beta*y(1:n) end if - if (alpha == zone) then + if (alpha == zzero) then + ! do nothing + else if (alpha == zone) then do i=1,n y(i) = y(i) + x(idx(i)) end do @@ -201,6 +333,26 @@ contains + subroutine psi_sgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_spk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + + end subroutine psi_sgthzmv subroutine psi_dgthzmv(n,k,idx,x,y) @@ -246,6 +398,27 @@ contains end subroutine psi_igthzmv + subroutine psi_cgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_spk_) :: x(:,:), y(:) + + ! Locals + integer :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + + end subroutine psi_cgthzmv + subroutine psi_zgthzmv(n,k,idx,x,y) use psb_const_mod @@ -267,6 +440,23 @@ contains end subroutine psi_zgthzmv + subroutine psi_sgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_sgthzv + subroutine psi_dgthzv(n,idx,x,y) use psb_const_mod @@ -301,6 +491,23 @@ contains end subroutine psi_igthzv + subroutine psi_cgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: x(:), y(:) + + ! Locals + integer :: i + + do i=1,n + y(i)=x(idx(i)) + end do + + end subroutine psi_cgthzv + subroutine psi_zgthzv(n,idx,x,y) use psb_const_mod @@ -319,6 +526,74 @@ contains end subroutine psi_zgthzv + subroutine psi_ssctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + real(psb_spk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == szero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == sone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if + end subroutine psi_ssctmv + + subroutine psi_ssctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + real(psb_spk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == szero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == sone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i)) + end do + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + end if + end subroutine psi_ssctv + + subroutine psi_dsctmv(n,k,idx,x,beta,y) use psb_const_mod @@ -450,6 +725,71 @@ contains end if end subroutine psi_isctv + subroutine psi_csctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, k, idx(:) + complex(psb_spk_) :: beta, x(:), y(:,:) + + ! Locals + integer :: i, j, pt + + if (beta == czero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == cone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if + end subroutine psi_csctmv + + + subroutine psi_csctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer :: n, idx(:) + complex(psb_spk_) :: beta, x(:), y(:) + + ! Locals + integer :: i + + if (beta == czero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == cone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if + end subroutine psi_csctv + subroutine psi_zsctmv(n,k,idx,x,beta,y) use psb_const_mod diff --git a/base/psblas/Makefile b/base/psblas/Makefile index de66b8934..70d2894f5 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -3,9 +3,15 @@ include ../../Make.inc #FCOPT=-O2 OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ psb_dnrm2.o psb_dnrmi.o psb_dspmm.o psb_dspsm.o\ - pdtreecomb.o \ + pdtreecomb.o pstreecomb.o\ psb_zamax.o psb_zasum.o psb_zaxpby.o psb_zdot.o \ - psb_znrm2.o psb_znrmi.o psb_zspmm.o psb_zspsm.o + psb_znrm2.o psb_znrmi.o psb_zspmm.o psb_zspsm.o\ + psb_saxpby.o psb_sdot.o psb_sasum.o psb_samax.o\ + psb_snrm2.o psb_snrmi.o psb_sspmm.o psb_sspsm.o\ + psb_sxdot.o\ + psb_camax.o psb_casum.o psb_caxpby.o psb_cdot.o \ + psb_cnrm2.o psb_cnrmi.o psb_cspmm.o psb_cspsm.o + LIBDIR=.. MODDIR=../modules diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 new file mode 100644 index 000000000..8f33fab1e --- /dev/null +++ b/base/psblas/psb_camax.f90 @@ -0,0 +1,528 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_camax.f90 +! +! Function: psb_camax +! Searches the absolute max of X. +! +! normi := max(abs(sub(X)(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! x(:,:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +function psb_camax (x,desc_a, info, jx) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_) :: psb_camax + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, icamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_camax' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=icamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),1) + amax=cabs1(x(iix+imax-1,jjx)) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + psb_camax=amax + + 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 function psb_camax + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_camaxv +! Searches the absolute max of X. +! +! normi := max(abs(X(i)) +! +! Arguments: +! x(:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_camaxv (x,desc_a, info) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_camaxv + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, jx, ix, m, imax, icamax + real(psb_spk_) :: amax + complex(psb_spk_) :: cmax + character(len=20) :: name, ch_err + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_camaxv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=icamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) + cmax=(x(iix+imax-1)) + amax=cabs1(cmax) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + psb_camaxv=amax + + 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 function psb_camaxv + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_camaxvs +! Searches the absolute max of X. +! +! normi := max(abs(sub(X)(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! res - real The result. +! x(:,:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +subroutine psb_camaxvs(res,x,desc_a, info) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(out) :: res + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, icamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + complex(psb_spk_) :: cmax + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_camaxvs' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx=1 + + m = psb_cd_get_global_rows(desc_a) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=icamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) + cmax=(x(iix+imax-1)) + amax=cabs1(cmax) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + res = amax + + 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_camaxvs + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cmamaxs +! Searches the absolute max of X. +! +! normi := max(abs(X(i)) +! +! Arguments: +! res(:) - real. The result. +! x(:,:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_cmamaxs(res,x,desc_a, info,jx) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_), intent(out) :: res(:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, i, k, icamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + complex(psb_spk_) :: cmax + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_cmamaxs' + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + k = min(size(x,2),size(res,1)) + + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + do i=1,k + imax=icamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx+i-1),1) + cmax=(x(iix+imax-1,jjx+i-1)) + res(i)=cabs1(cmax) + end do + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, res(1:k)) + + 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_cmamaxs diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 new file mode 100644 index 000000000..feedd8734 --- /dev/null +++ b/base/psblas/psb_casum.f90 @@ -0,0 +1,430 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_casum.f90 +! +! Function: psb_casum +! Computes norm1 of X +! +! norm1 := sum(sub( X )(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! x(:,:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +function psb_casum (x,desc_a, info, jx) + + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_) :: psb_casum + + ! locals + integer :: ictxt, np, me, & + & err_act, iix, jjx, ix, ijx, m, i, idx, ndm + real(psb_spk_) :: asum, scasum + character(len=20) :: name, ch_err + complex(psb_spk_) :: cmax + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_casum' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=scasum(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),ione) + + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx,jjx)) + end do + + + else + asum=0.0 + end if + ! compute global sum + call psb_sum(ictxt, asum) + else + asum=0.0 + end if + + + psb_casum=asum + + 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 function psb_casum + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_casumv +! Computes norm1 of X +! +! norm1 := sum(X(i)) +! +! Arguments: +! x(:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_casumv(x,desc_a, info) + + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_casumv + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, jx, ix, m, i, idx, ndm + real(psb_spk_) :: asum, scasum + character(len=20) :: name, ch_err + complex(psb_spk_) :: cmax + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_casumv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx=1 + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=scasum(psb_cd_get_local_rows(desc_a),x,ione) + + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx)) + end do + + else + asum=0.d0 + end if + + ! compute global sum + call psb_sum(ictxt, asum) + else + asum=0.d0 + end if + + psb_casumv=asum + + 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 function psb_casumv + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_casumvs +! Computes norm1 of X +! +! norm1 := sum(X(i)) +! +! Arguments: +! res - real. The result. +! x(:) - complex The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +subroutine psb_casumvs(res,x,desc_a, info) + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, jx, m, i, idx, ndm + real(psb_spk_) :: asum, scasum + character(len=20) :: name, ch_err + complex(psb_spk_) :: cmax + complex :: cdum + real :: cabs1 + cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) + + name='psb_casumvs' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=scasum(psb_cd_get_local_rows(desc_a),x,ione) + + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*cabs1(x(idx)) + end do + + else + asum=0.d0 + end if + + ! compute global sum + call psb_sum(ictxt,asum) + else + asum=0.d0 + end if + + + res = asum + + 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_casumvs diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 new file mode 100644 index 000000000..9ec74bf12 --- /dev/null +++ b/base/psblas/psb_caxpby.f90 @@ -0,0 +1,284 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_caxpby.f90 +! +! Subroutine: psb_caxpby +! Adds one distributed matrix to another, +! +! sub( Y ) := beta * sub( Y ) + alpha * sub( X ) +! +! where sub( X ) denotes X(:,JX) +! +! sub( Y ) denotes Y(:,JY). +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x(:,:) - complex,input The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y(:,:) - real,inout The input vector Y +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! jx - integer(optional) The column offset for X +! jy - integer(optional) The column offset for Y +! +subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) + use psb_descriptor_type + use psb_check_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(in), optional :: n, jx, jy + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(in) :: x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy + character(len=20) :: name, ch_err + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + if (present(jx)) then + ijx = jx + else + ijx = ione + endif + + iy = ione + if (present(jy)) then + ijy = jy + else + ijy = ione + endif + + if (present(n)) then + if(((ijx+n) <= size(x,2)).and.& + & ((ijy+n) <= size(y,2))) then + in = n + else + in = min(size(x,2),size(y,2)) + end if + else + in = min(size(x,2),size(y,2)) + endif + + if(ijx /= ijy) then + info=3050 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if ((in /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + call caxpby(psb_cd_get_local_cols(desc_a),in,& + & alpha,x(iix,jjx),size(x,1),beta,& + & y(iiy,jjy),size(y,1),info) + end if + end if + + 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_caxpby + + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_caxpbyv +! Adds one distributed matrix to another, +! +! Y := beta * Y + alpha * X +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x(:) - complex,input The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y(:) - real,inout The input vector Y +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! +subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(inout) :: y(:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, iy, m, iiy, jjy + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_geaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + end if + + if(psb_cd_get_local_rows(desc_a) > 0) then + call caxpby(psb_cd_get_local_cols(desc_a),ione,& + & alpha,x,size(x),beta,& + & y,size(y),info) + end if + + 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_caxpbyv diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 new file mode 100644 index 000000000..1de1d3831 --- /dev/null +++ b/base/psblas/psb_cdot.f90 @@ -0,0 +1,574 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cdot.f90 +! +! Function: psb_cdot +! psb_cdot forms the dot product of two distributed vectors, +! +! dot := sub( X )**C * sub( Y ) +! +! where sub( X ) denotes X(:,JX) +! +! sub( Y ) denotes Y(:,JY). +! +! Arguments: +! x(:,:) - complex The input vector containing the entries of sub( X ). +! y(:,:) - complex The input vector containing the entries of sub( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for sub( X ). +! jy - integer(optional). The column offset for sub( Y ). +! +function psb_cdot(x, y,desc_a, info, jx, jy) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in), optional :: jx, jy + integer, intent(out) :: info + complex(psb_spk_) :: psb_cdot + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m + complex(psb_spk_) :: dot_local + complex(psb_spk_) :: cdotc + character(len=20) :: name, ch_err + + name='psb_cdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + if (present(jx)) then + ijx = jx + else + ijx = ione + endif + + iy = ione + if (present(jy)) then + ijy = jy + else + ijy = ione + endif + + if(ijx /= ijy) then + info=3050 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = cdotc(psb_cd_get_local_rows(desc_a),& + & x(iix,jjx),ione,y(iiy,jjy),ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx,jjx))*y(idx,jjy)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_cdot = dot_local + + 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 function psb_cdot + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_cdotv +! psb_cdotv forms the dot product of two distributed vectors, +! +! dot := X**C * Y +! +! Arguments: +! x(:) - complex The input vector containing the entries of X. +! y(:) - complex The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_cdotv(x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_) :: psb_cdotv + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m + complex(psb_spk_) :: dot_local + complex(psb_spk_) :: cdotc + character(len=20) :: name, ch_err + + name='psb_cdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + jx = ione + jy = ione + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) + if (info == 0)& + & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = cdotc(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx))*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_cdotv = dot_local + + 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 function psb_cdotv + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cdotvs +! psb_cdotvs forms the dot product of two distributed vectors, +! +! res := X**C * Y +! +! Arguments: +! res - complex. The result. +! x(:) - complex The input vector containing the entries of X. +! y(:) - complex The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_cdotvs(res, x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:), y(:) + complex(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m + complex(psb_spk_) :: dot_local + complex(psb_spk_) :: cdotc + character(len=20) :: name, ch_err + + name='psb_cdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + m = psb_cd_get_global_rows(desc_a) + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = cdotc(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(conjg(x(idx))*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + res = dot_local + + 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_cdotvs + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cmdots +! psb_cmdots forms the dot product of multiple distributed vectors, +! +! res(i) := ( X(:,i) )**C * ( Y(:,i) ) +! +! Arguments: +! res(:) - complex. The result. +! x(:) - complex The input vector containing the entries of sub( X ). +! y(:) - complex The input vector containing the entries of sub( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_cmdots(res, x, y, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:), y(:,:) + complex(psb_spk_), intent(out) :: res(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k + complex(psb_spk_),allocatable :: dot_local(:) + complex(psb_spk_) :: cdotc + character(len=20) :: name, ch_err + + name='psb_cmdots' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ix /= ione).or.(iy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + k = min(size(x,2),size(y,2)) + allocate(dot_local(k)) + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + do j=1,k + dot_local(j) = cdotc(psb_cd_get_local_rows(desc_a),& + & x(1,j),ione,y(1,j),ione) + ! adjust dot_local because overlapped elements are computed more than once + end do + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local(1:k) = dot_local(1:k) - (real(ndm-1)/real(ndm))*(conjg(x(idx,1:k))*y(idx,1:k)) + end do + else + dot_local(:)=0.d0 + end if + else + dot_local(:)=0.d0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local(1:k)) + + res(1:k) = dot_local(1:k) + + 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_cmdots diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 new file mode 100644 index 000000000..fa99510eb --- /dev/null +++ b/base/psblas/psb_cnrm2.f90 @@ -0,0 +1,399 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cnrm2.f90 +! +! Function: psb_cnrm2 +! Forms the norm2 of a distributed vector, +! +! norm2 := sqrt ( sub( X )**T * sub( X ) ) +! +! where sub( X ) denotes X(:,JX). +! +! Arguments: +! x(:,:) - complex The input vector containing the entries of sub( X ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for sub( X ). +! +function psb_cnrm2(x, desc_a, info, jx) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in), optional :: jx + integer, intent(out) :: info + real(psb_spk_) :: psb_cnrm2 + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, scnrm2, dd + + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_cnrm2' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = scnrm2( ndim, x(iix,jjx), ione ) + + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx,jjx))/nrm2)**2) + end do + else + nrm2 = dzero + end if + else + nrm2 = dzero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + psb_cnrm2 = nrm2 + + 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 function psb_cnrm2 + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_cnrm2 +! Forms the norm2 of a distributed vector, +! +! norm2 := sqrt ( X**T * X) +! +! Arguments: +! x(:) - complex The input vector containing the entries of X. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_cnrm2v(x, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_cnrm2v + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, scnrm2, dd + + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_cnrm2v' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx=1 + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = scnrm2( ndim, x, ione ) + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx))/nrm2)**2) + end do + else + nrm2 = dzero + end if + else + nrm2 = dzero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + psb_cnrm2v = nrm2 + + 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 function psb_cnrm2v + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cnrm2vs +! Forms the norm2 of a distributed vector, +! +! norm2 := sqrt ( X**T * X) +! +! Arguments: +! res - real The result. +! x(:) - complex The input vector containing the entries of X. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_cnrm2vs(res, x, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, scnrm2, dd + + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_cnrm2' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = scnrm2( ndim, x, ione ) + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx))/nrm2)**2) + end do + else + nrm2 = dzero + end if + else + nrm2 = dzero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + res = nrm2 + + 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_cnrm2vs diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 new file mode 100644 index 000000000..12b20a248 --- /dev/null +++ b/base/psblas/psb_cnrmi.f90 @@ -0,0 +1,125 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cnrmi.f90 +! +! Function: psb_cnrmi +! Forms the approximated norm of a sparse matrix, +! +! normi := max(abs(sum(A(i,j)))) +! +! Arguments: +! a - type(psb_dspmat_type). The sparse matrix containing A. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_cnrmi(a,desc_a,info) + use psb_descriptor_type + use psb_serial_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_) :: psb_cnrmi + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iia, jja, ia, ja, mdim, ndim, m + real(psb_spk_) :: nrmi + character(len=20) :: name, ch_err + + name='psb_cnrmi' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iia /= 1).or.(jja /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if ((m /= 0).and.(n /= 0)) then + nrmi = psb_csnmi(a,info) + + if(info /= 0) then + info=4010 + ch_err='psb_csnmi' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + nrmi = 0.d0 + end if + + ! compute global max + call psb_amx(ictxt, nrmi) + + psb_cnrmi = nrmi + + 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 function psb_cnrmi diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 new file mode 100644 index 000000000..ba1504fd9 --- /dev/null +++ b/base/psblas/psb_cspmm.f90 @@ -0,0 +1,689 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspmm.f90 +! +! Subroutine: psb_cspmm +! Performs one of the distributed matrix-vector operations +! +! sub( Y ) := alpha * Pr * A * Pc * sub( X ) + beta * sub( Y ), or +! +! sub( Y ) := alpha * Pr * A' * Pr * sub( X ) + beta * sub( Y ), +! +! where: +! +! sub( X ) denotes: X(1:N,JX:JX+K-1), +! +! sub( Y ) denotes: Y(1:M,JY:JY+K-1), +! +! alpha and beta are scalars, and sub( X ) and sub( Y ) are distributed +! vectors and A is a M-by-N distributed matrix. +! +! Arguments: +! alpha - complex The scalar alpha. +! a - type(psb_cspmat_type). The sparse matrix containing A. +! x(:,:) - complex The input vector containing the entries of ( X ). +! beta - complex The scalar beta. +! y(:,:) - complex The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. Default: 'N' +! k - integer(optional). The number of right-hand sides. +! jx - integer(optional). The column offset for ( X ). Default: 1 +! jy - integer(optional). The column offset for ( Y ). Default: 1 +! work(:) - complex,(optional). Working area. +! doswap - logical(optional). Whether to performe halo updates. +! +subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& + & trans, k, jx, jy, work, doswap) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(inout), target :: x(:,:) + complex(psb_spk_), intent(inout), target :: y(:,:) + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans + integer, intent(in), optional :: k, jx, jy + logical, intent(in), optional :: doswap + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& + & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& + & i, ib, ib1, ip, idx + integer, parameter :: nb=4 + complex(psb_spk_), pointer :: xp(:,:), yp(:,:), iwork(:) + complex(psb_spk_), allocatable :: xvsave(:,:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit + + name='psb_cspmm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + iy = 1 + if (present(jy)) then + ijy = jy + else + ijy = 1 + endif + + if (present(doswap)) then + doswap_ = doswap + else + doswap_ = .true. + endif + + if (present(k)) then + ik = min(k,size(x,2)-ijx+1) + ik = min(ik,size(y,2)-ijy+1) + else + ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + endif + + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_ = 'N' + endif + if ( (trans_ == 'N').or.(trans_ == 'T')& + & .or.(trans_ == 'C')) then + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x,1) + lldy = size(y,1) + + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=czero + + ! checking for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (trans_ == 'N') then + ! Matrix is not transposed + if((ja /= ix).or.(ia /= iy)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + + if (doswap_.and.(np>1)) then + ib1=min(nb,ik) + xp => x(iix:lldx,jjx:jjx+ib1-1) + if (doswap_)& + & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ib1,czero,xp,desc_a,iwork,info) + + + blk: do i=1, ik, nb + ib=ib1 + ib1 = max(0,min(nb,(ik)-(i-1+ib))) + xp => x(iix:lldx,jjx+i+ib-1:jjx+i+ib+ib1-2) + if ((ib1 > 0).and.(doswap_)) & + & call psi_swapdata(psb_swap_send_,ib1,& + & czero,xp,desc_a,iwork,info) + + if(info /= 0) exit blk + + ! local Matrix-vector product + call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i+ib-1),& + & beta,y(:,jjy+i-1:jjy+i+ib-1),info,trans=trans_) + + if(info /= 0) exit blk + + if((ib1 > 0).and.(doswap_))& + & call psi_swapdata(psb_swap_recv_,ib1,& + & czero,xp,desc_a,iwork,info) + + if(info /= 0) exit blk + end do blk + else + if (doswap_)& + & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ib1,czero,x(:,1:ik),desc_a,iwork,info) + if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + end if + + if(info /= 0) then + info = 4011 + call psb_errpush(info,name) + goto 9999 + end if + + else + + ! Matrix is transposed + if((ja /= iy).or.(ia /= ix)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + + ! checking for vectors correctness + call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + y(nrow+1:ncol,1:ik) = czero + + if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info + if (info /= 0) then + info = 4010 + ch_err='psb_csmm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + + if (doswap_)then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & ik,cone,y(:,1:ik),desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ik,cone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + end if + + if (aliw) deallocate(iwork,stat=info) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info + if(info /= 0) then + info = 4010 + ch_err='Deallocate iwork' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + nullify(iwork) + + 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_cspmm + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cspmv +! Performs one of the distributed matrix-vector operations +! +! Y := alpha * Pr * A * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A' * Pr * X + beta * Y, +! +! alpha and beta are scalars, and X and Y are distributed +! vectors and A is a M-by-N distributed matrix. +! +! Arguments: +! alpha - complex The scalar alpha. +! a - type(psb_cspmat_type). The sparse matrix containing A. +! x(:) - complex The input vector containing the entries of ( X ). +! beta - complex The scalar beta. +! y(:) - complex The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. Default: 'N' +! work(:) - complex,(optional). Working area. +! doswap - logical(optional). Whether to performe halo updates. +! +subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& + & trans, work, doswap) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(inout), target :: x(:) + complex(psb_spk_), intent(inout), target :: y(:) + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans + logical, intent(in), optional :: doswap + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & + & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& + & ib, ip, idx + integer, parameter :: nb=4 + complex(psb_spk_), pointer :: iwork(:), xp(:), yp(:) + complex(psb_spk_), allocatable :: xvsave(:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit + + name='psb_cspmv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + ix = 1 + jx = 1 + iy = 1 + jy = 1 + ik = 1 + ib = 1 + + if (present(doswap)) then + doswap_ = doswap + else + doswap_ = .true. + endif + + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_ = 'N' + endif + if ( (trans_ == 'N').or.(trans_ == 'T')& + & .or.(trans_ == 'C')) then + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x) + lldy = size(y) + + iwork => null() + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info + ! checking for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info + if (trans_ == 'N') then + ! Matrix is not transposed + if((ja /= ix).or.(ia /= iy)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + if (doswap_) then + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & czero,x,desc_a,iwork,info,data=psb_comm_halo_) + end if + + ! local Matrix-vector product + call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) + + if(info /= 0) then + info = 4011 + call psb_errpush(info,name) + goto 9999 + end if + + else + ! Matrix is transposed + if((ja /= iy).or.(ia /= ix)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0)& + & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + xp => x(1:lldx) + yp => y(1:lldy) + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + call psi_ovrl_save(x,xvsave,desc_a,info) + if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + yp(nrow+1:ncol) = czero + + ! local Matrix-vector product + if (info == 0) call psb_csmm(alpha,a,x,beta,yp,info,trans=trans_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info + + if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= 0) then + info = 4010 + ch_err='psb_csmm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (doswap_) then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & cone,yp,desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + end if + + if (aliw) deallocate(iwork,stat=info) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info + if(info /= 0) then + info = 4010 + ch_err='Deallocate iwork' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nullify(iwork) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + 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_cspmv diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 new file mode 100644 index 000000000..4774a76c9 --- /dev/null +++ b/base/psblas/psb_cspsm.f90 @@ -0,0 +1,568 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspsm.f90 +! +! Subroutine: psb_cspsm +! Performs one of the distributed matrix-vector operations +! +! sub( Y ) := alpha * Pr * A-1 * Pc *sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * D * Pr * A-1 * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-1 * Pc * D * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-T * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * D * Pr * A-T * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-T * Pc * D * sub( X ) + beta * sub (Y ), or +! +! where : +! +! sub( X ) denotes X(1:M,JX:JX+K-1), +! +! sub( Y ) denotes Y(1:M,JY:JY+K-1). +! +! sub( X ) is a distributed +! vector and T is a M-by-M distributed triangular matrix. +! +! Arguments: +! alpha - complex. The scalar alpha. +! a - type(psb_cspmat_type). The sparse matrix containing A. +! x(:,:) - complex The input vector containing the entries of ( X ). +! beta - complex The scalar beta. +! y(:,:) - complex The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. If not present 'N' is assumed. +! unitd - character(optional). Specify some type of operation with +! the diagonal matrix D. +! choice - integer(optional). The kind of update to perform on overlap elements. +! d(:) - complex, optional Matrix for diagonal scaling. +! k - integer(optional). The number of right-hand sides. +! jx - integer(optional). The column offset for ( X ). Default: 1 +! jy - integer(optional). The column offset for ( Y ). Default: 1 +! work(:) - complex, optional Working area. +! +subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& + & trans, unitd, choice, diag, k, jx, jy, work) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(in), target :: x(:,:) + complex(psb_spk_), intent(inout), target :: y(:,:) + type (psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional, target :: diag(:) + complex(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans, unitd + integer, intent(in), optional :: choice + integer, intent(in), optional :: k, jx, jy + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, ijx, ijy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + + character :: lunitd + integer, parameter :: nb=4 + complex(psb_spk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_cspsm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! just this case right now + ia = 1 + ja = 1 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + iy = 1 + if (present(jy)) then + ijy = jy + else + ijy = 1 + endif + + if (present(k)) then + ik = min(k,size(x,2)-ijx+1) + ik = min(ik,size(y,2)-ijy+1) + else + ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + endif + + if (present(choice)) then + choice_ = choice + else + choice_ = psb_avg_ + endif + + if (present(unitd)) then + lunitd = psb_toupper(unitd) + else + lunitd = 'U' + endif + + if (present(trans)) then + itrans = psb_toupper(trans) + if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then + ! OK + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + else + itrans = 'N' + endif + + m = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x,1) + lldy = size(y,1) + + if((lldx < ncol).or.(lldy < ncol)) then + info=3010 + call psb_errpush(info,name) + goto 9999 + end if + + ! check for presence/size of a work area + iwork => null() + liwork= 2*ncol + if (a%pr(1) /= 0) llwork = liwork + m * ik + if (a%pl(1) /= 0) llwork = llwork + m * ik + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=0.d0 + + if(present(diag)) then + lld = size(diag) + id => diag + else + lld=1 + allocate(id(1)) + id=1.d0 + end if + + ! checking for matrix correctness + call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) + ! checking for vectors correctness + if (info == 0) & + & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect/mat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(ja /= ix) then + ! this case is not yet implemented + info = 3030 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + end if + + if(info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! Perform local triangular system solve + xp => x(iix:lldx,jjx:jjx+ik-1) + yp => y(iiy:lldy,jjy:jjy+ik-1) + call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) + + if(info /= 0) then + info = 4010 + ch_err='zcssm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! update overlap elements + if (choice_ > 0) then + + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& + & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + end if + + if(aliw) deallocate(iwork) + if(.not.present(diag)) deallocate(id) + + 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_cspsm + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_cspsv +! Performs one of the distributed matrix-vector operations +! +! Y := alpha * Pr * A-1 * Pc * X + beta * Y, or +! +! Y := alpha * D * Pr * A-1 * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A-1 * Pc * D * X + beta * Y, or +! +! Y := alpha * Pr * A-T * Pc * X + beta * Y, or +! +! Y := alpha * D * Pr * A-T * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A-T * Pc * D * X + beta * Y, or +! +! X is a distributed +! vector and T is a M-by-M distributed triangular matrix. +! +! +! Arguments: +! alpha - complex. The scalar alpha. +! a - type(psb_cspmat_type). The sparse matrix containing A. +! x(:) - complex The input vector containing the entries of ( X ). +! beta - complex The scalar beta. +! y(:) - complex The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. If not present 'N' is assumed. +! unitd - character(optional). Specify some type of operation with +! the diagonal matrix D. +! choice - integer(optional). The kind of update to perform on overlap elements. +! d(:) - complex, optional Matrix for diagonal scaling. +! work(:) - complex, optional Working area. +! +subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& + & trans, unitd, choice, diag, work) + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(in), target :: x(:) + complex(psb_spk_), intent(inout), target :: y(:) + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + complex(psb_spk_), intent(in), optional, target :: diag(:) + complex(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans, unitd + integer, intent(in), optional :: choice + + ! locals + integer :: ictxt, np, me, & + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, jx, jy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + + character :: lunitd + integer, parameter :: nb=4 + complex(psb_spk_),pointer :: iwork(:), xp(:), yp(:), id(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_cspsv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! just this case right now + ia = 1 + ja = 1 + ix = 1 + iy = 1 + ik = 1 + jx= 1 + jy= 1 + + if (present(choice)) then + choice_ = choice + else + choice_ = psb_avg_ + endif + + if (present(unitd)) then + lunitd = psb_toupper(unitd) + else + lunitd = 'U' + endif + + if (present(trans)) then + itrans = psb_toupper(trans) + if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then + ! Ok + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + else + itrans = 'N' + endif + + m = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x) + lldy = size(y) + + if((lldx < ncol).or.(lldy < ncol)) then + info=3010 + call psb_errpush(info,name) + goto 9999 + end if + + iwork => null() + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=0.d0 + + if(present(diag)) then + lld = size(diag) + id => diag + else + lld=1 + allocate(id(1)) + id=1.d0 + end if + + ! checking for matrix correctness + call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) + ! checking for vectors correctness + if (info == 0) & + & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect/mat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(ja /= ix) then + ! this case is not yet implemented + info = 3030 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + end if + + if(info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! Perform local triangular system solve + xp => x(iix:lldx) + yp => y(iiy:lldy) + call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) + + if(info /= 0) then + info = 4010 + ch_err='dcssm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! update overlap elements + if(choice_ > 0) then + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + end if + + if (aliw) deallocate(iwork) + if(.not.present(diag)) deallocate(id) + + 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_cspsv + diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 775fa61a8..b84ebcb48 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -57,8 +57,8 @@ function psb_dnrmi(a,desc_a,info) ! locals integer :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m - real(psb_dpk_) :: nrmi, dcsnmi - character(len=20) :: name, ch_err + real(psb_dpk_) :: nrmi + character(len=20) :: name, ch_err name='psb_dnrmi' if(psb_get_errstatus() /= 0) return @@ -94,15 +94,10 @@ function psb_dnrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - mdim = psb_cd_get_local_rows(desc_a) - ndim = psb_cd_get_local_cols(desc_a) - nrmi = dcsnmi('N',mdim,ndim,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,& - & a%infoa,info) - + nrmi = psb_csnmi(a,info) if(info /= 0) then info=4010 - ch_err='dcsnmi' + ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 new file mode 100644 index 000000000..520cff684 --- /dev/null +++ b/base/psblas/psb_samax.f90 @@ -0,0 +1,511 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_samax.f90 +! +! Function: psb_samax +! Searches the absolute max of X. +! +! normi := max(abs(sub(X)(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! x(:,:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +function psb_samax (x,desc_a, info, jx) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_) :: psb_samax + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, isamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + + name='psb_samax' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=isamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),1) + amax=abs(x(iix+imax-1,jjx)) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + psb_samax=amax + + 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 function psb_samax + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_samaxv +! Searches the absolute max of X. +! +! normi := max(abs(X(i)) +! +! Arguments: +! x(:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_samaxv (x,desc_a, info) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_samaxv + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, jx, ix, m, imax, isamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + + name='psb_samaxv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=isamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) + amax=abs(x(iix+imax-1)) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + psb_samaxv=amax + + 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 function psb_samaxv + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_samaxvs +! Searches the absolute max of X. +! +! normi := max(abs(sub(X)(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! res - real. The result. +! x(:,:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +subroutine psb_samaxvs (res,x,desc_a, info) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(out) :: res + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, isamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + + name='psb_samaxvs' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx=1 + + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + imax=isamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix),1) + amax=abs(x(iix+imax-1)) + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, amax) + + res = amax + + 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_samaxvs + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_smamaxs +! Searches the absolute max of X. +! +! normi := max(abs(X(i)) +! +! Arguments: +! res(:) - real The result. +! x(:,:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_smamaxs (res,x,desc_a, info,jx) + use psb_penv_mod + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_), intent(out) :: res(:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, ijx, m, imax, i, k, isamax + real(psb_spk_) :: amax + character(len=20) :: name, ch_err + + name='psb_smamaxs' + if (psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + amax=0.d0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + k = min(size(x,2),size(res,1)) + + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((psb_cd_get_local_rows(desc_a) > 0).and.(m /= 0)) then + do i=1,k + imax=isamax(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx+i-1),1) + res(i)=abs(x(iix+imax-1,jjx+i-1)) + end do + else + amax = szero + end if + + ! compute global max + call psb_amx(ictxt, res(1:k)) + + 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_smamaxs diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 new file mode 100644 index 000000000..0d1620f03 --- /dev/null +++ b/base/psblas/psb_sasum.f90 @@ -0,0 +1,421 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sasum.f90 +! +! Function: psb_sasum +! Computes norm1 of X +! +! norm1 := sum(sub( X )(i)) +! +! where sub( X ) denotes X(1:N,JX:). +! +! Arguments: +! x(:,:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +function psb_sasum (x,desc_a, info, jx) + + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: jx + real(psb_spk_) :: psb_sasum + + ! locals + integer :: ictxt, np, me, err_act, & + & iix, jjx, ix, ijx, m, i, idx, ndm + real(psb_spk_) :: asum, sasum + character(len=20) :: name, ch_err + + name='psb_sasum' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=sasum(psb_cd_get_local_rows(desc_a)-iix+1,x(iix,jjx),ione) + + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx,jjx)) + end do + + ! compute global sum + call psb_sum(ictxt, asum) + + else + asum=0.0 + ! compute global sum + call psb_sum(ictxt, asum) + end if + else + asum=0.0 + end if + + + psb_sasum=asum + + 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 function psb_sasum + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_sasumv +! Computes norm1 of X +! +! norm1 := sum(X(i)) +! +! Arguments: +! x(:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_sasumv (x,desc_a, info) + + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_sasumv + + ! locals + integer :: ictxt, np, me, err_act, iix, jjx, jx, ix, m, i, idx, ndm + real(psb_spk_) :: asum, sasum + character(len=20) :: name, ch_err + + name='psb_sasumv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx=1 + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=sasum(psb_cd_get_local_rows(desc_a),x,ione) + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx)) + end do + + ! compute global sum + call psb_sum(ictxt, asum) + + else + asum=0.0 + ! compute global sum + call psb_sum(ictxt, asum) + end if + else + asum=0.0 + end if + + psb_sasumv=asum + + 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 function psb_sasumv + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sasumvs +! Computes norm1 of X +! +! norm1 := sum(X(i)) +! +! Arguments: +! res - real The result. +! x(:) - real The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset. +! +subroutine psb_sasumvs(res,x,desc_a, info) + use psb_serial_mod + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, err_act, iix, jjx, ix, jx, m, i, idx, ndm + real(psb_spk_) :: asum, sasum + character(len=20) :: name, ch_err + + name='psb_sasumvs' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + asum=0.0 + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((m /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + asum=sasum(psb_cd_get_local_rows(desc_a),x,ione) + + ! adjust asum because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + asum = asum - (real(ndm-1)/real(ndm))*abs(x(idx)) + end do + + ! compute global sum + call psb_sum(ictxt,asum) + + else + asum=0.0 + ! compute global sum + call psb_sum(ictxt, asum) + end if + else + asum=0.0 + end if + + + res = asum + + 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_sasumvs diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 new file mode 100644 index 000000000..79966c13e --- /dev/null +++ b/base/psblas/psb_saxpby.f90 @@ -0,0 +1,284 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_saxpby.f90 +! +! Subroutine: psb_saxpby +! Adds one distributed matrix to another, +! +! sub( Y ) := beta * sub( Y ) + alpha * sub( X ) +! +! where sub( X ) denotes X(:,JX) +! +! sub( Y ) denotes Y(:,JY). +! +! Arguments: +! alpha - real The scalar alpha +! x(:,:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for sub( X ). +! jy - integer(optional). The column offset for sub( Y ). +! +subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) + use psb_descriptor_type + use psb_check_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(in), optional :: n, jx, jy + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(in) :: x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy + character(len=20) :: name, ch_err + + name='psb_sgeaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + if (present(jx)) then + ijx = jx + else + ijx = ione + endif + + iy = ione + if (present(jy)) then + ijy = jy + else + ijy = ione + endif + + if (present(n)) then + if(((ijx+n) <= size(x,2)).and.& + & ((ijy+n) <= size(y,2))) then + in = n + else + in = min(size(x,2),size(y,2)) + end if + else + in = min(size(x,2),size(y,2)) + endif + + if(ijx /= ijy) then + info=3050 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if ((in /= 0)) then + if(psb_cd_get_local_rows(desc_a) > 0) then + call saxpby(psb_cd_get_local_rows(desc_a),in,& + & alpha,x(iix,jjx),size(x,1),beta,& + & y(iiy,jjy),size(y,1),info) + end if + end if + + 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_saxpby + + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_saxpbyv +! Adds one distributed matrix to another, +! +! Y := beta * Y + alpha * X +! +! Arguments: +! alpha - real The scalar alpha +! x(:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta +! y(:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +! +subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) + use psb_descriptor_type + use psb_const_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(inout) :: y(:) + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ix, iy, m, iiy, jjy + character(len=20) :: name, ch_err + + name='psb_sgeaxpby' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + end if + + if(psb_cd_get_local_rows(desc_a) > 0) then + call saxpby(psb_cd_get_local_rows(desc_a),ione,& + & alpha,x,size(x),beta,& + & y,size(y),info) + end if + + 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_saxpbyv diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 new file mode 100644 index 000000000..40a1e06c4 --- /dev/null +++ b/base/psblas/psb_sdot.f90 @@ -0,0 +1,574 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sdot.f90 +! +! Function: psb_sdot +! psb_sdot forms the dot product of two distributed vectors, +! +! dot := sub( X )**T * sub( Y ) +! +! where sub( X ) denotes X(:,JX) +! +! sub( Y ) denotes Y(:,JY). +! +! Arguments: +! x(:,:) - real The input vector containing the entries of ( X ). +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for sub( X ). +! jy - integer(optional). The column offset for sub( Y ). +! +function psb_sdot(x, y,desc_a, info, jx, jy) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in), optional :: jx, jy + integer, intent(out) :: info + real(psb_spk_) :: psb_sdot + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m + real(psb_spk_) :: dot_local + real(psb_spk_) :: sdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + if (present(jx)) then + ijx = jx + else + ijx = ione + endif + + iy = ione + if (present(jy)) then + ijy = jy + else + ijy = ione + endif + + if(ijx /= ijy) then + info=3050 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sdot(psb_cd_get_local_rows(desc_a),& + & x(iix,jjx),ione,y(iiy,jjy),ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx,jjx)*y(idx,jjy)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_sdot = dot_local + + 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 function psb_sdot + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_sdotv +! psb_sdotv forms the dot product of two distributed vectors, +! +! dot := X**T * Y +! +! Arguments: +! x(:) - real The input vector containing the entries of X. +! y(:) - real The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_sdotv(x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_sdotv + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m + real(psb_spk_) :: dot_local + real(psb_spk_) :: sdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + jx = ione + jy = ione + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sdot(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_sdotv = dot_local + + 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 function psb_sdotv + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sdotvs +! psb_sdotvs forms the dot product of two distributed vectors, +! +! dot := X**T * Y +! +! Arguments: +! res - real The result. +! x(:) - real The input vector containing the entries of X. +! y(:) - real The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_sdotvs(res, x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:), y(:) + real(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m + real(psb_spk_) :: dot_local + real(psb_spk_) :: sdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + m = psb_cd_get_global_rows(desc_a) + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sdot(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + res = dot_local + + 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_sdotvs + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_smdots +! psb_smdots forms the dot product of multiple distributed vectors, +! +! res(i) := ( X(:,i) )**T * ( Y(:,i) ) +! +! Arguments: +! res(:) - real. The result. +! x(:,:) - real The input vector containing the entries of ( X ). +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_smdots(res, x, y, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + real(psb_spk_), intent(out) :: res(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k + real(psb_spk_),allocatable :: dot_local(:) + real(psb_spk_) :: sdot + character(len=20) :: name, ch_err + + name='psb_smdots' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ix /= ione).or.(iy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + k = min(size(x,2),size(y,2)) + allocate(dot_local(k)) + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + do j=1,k + dot_local(j) = sdot(psb_cd_get_local_rows(desc_a),& + & x(1,j),ione,y(1,j),ione) + ! adjust dot_local because overlapped elements are computed more than once + end do + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local(1:k) = dot_local(1:k) - (real(ndm-1)/real(ndm))*(x(idx,1:k)*y(idx,1:k)) + end do + else + dot_local(:)=0.0 + end if + else + dot_local(:)=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local(1:k)) + + res(1:k) = dot_local(1:k) + + 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_smdots diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 new file mode 100644 index 000000000..b4311859c --- /dev/null +++ b/base/psblas/psb_snrm2.f90 @@ -0,0 +1,396 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_snrm2.f90 +! +! Function: psb_snrm2 +! Forms the norm2 of a distributed vector, +! +! norm2 := sqrt ( sub( X )**T * sub( X ) ) +! +! where sub( X ) denotes X(:,JX). +! +! Arguments: +! x - real,dimension(:,:). The input vector containing the entries of X. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for X . +! +function psb_snrm2(x, desc_a, info, jx) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in), optional :: jx + integer, intent(out) :: info + real(psb_spk_) :: psb_snrm2 + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, snrm2, dd + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_snrm2' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = psb_cd_get_global_rows(desc_a) + call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = snrm2( ndim, x(iix,jjx), ione ) + + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx,jjx))/nrm2)**2) + end do + else + nrm2 = szero + end if + else + nrm2 = szero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + psb_snrm2 = nrm2 + + 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 function psb_snrm2 + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_snrm2 +! Forms the norm2 of a distributed vector, +! +! norm2 := sqrt ( X**T * X) +! +! Arguments: +! x - real,dimension(:). The input vector containing the entries of X. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_snrm2v(x, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_) :: psb_snrm2v + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, snrm2, dd + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_snrm2v' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx=1 + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = snrm2( ndim, x, ione ) + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx))/nrm2)**2) + end do + else + nrm2 = szero + end if + else + nrm2 = szero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + psb_snrm2v = nrm2 + + 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 function psb_snrm2v + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_snrm2vs +! Forms the norm2 of a distributed vector, +! +! res := sqrt ( X**T * X) +! +! Arguments: +! res - real. The result. +! x - real,dimension(:). The input vector containing the entries of X. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_snrm2vs(res, x, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm + real(psb_spk_) :: nrm2, snrm2, dd + external scombnrm2 + character(len=20) :: name, ch_err + + name='psb_snrm2' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + jx = 1 + m = psb_cd_get_global_rows(desc_a) + + call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if (psb_cd_get_local_rows(desc_a) > 0) then + ndim = psb_cd_get_local_rows(desc_a) + nrm2 = snrm2( ndim, x, ione ) + ! adjust because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = real(ndm-1)/real(ndm) + nrm2 = nrm2 * sqrt(sone - dd*(abs(x(idx))/nrm2)**2) + end do + else + nrm2 = szero + end if + else + nrm2 = szero + end if + + call pstreecomb(ictxt,'All',1,nrm2,-1,-1,scombnrm2) + + res = nrm2 + + 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_snrm2vs diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 new file mode 100644 index 000000000..529344b5b --- /dev/null +++ b/base/psblas/psb_snrmi.f90 @@ -0,0 +1,125 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_snrmi.f90 +! +! Function: psb_snrmi +! Forms the approximated norm of a sparse matrix, +! +! normi := max(abs(sum(A(i,j)))) +! +! Arguments: +! a - type(psb_sspmat_type). The sparse matrix containing A. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_snrmi(a,desc_a,info) + use psb_descriptor_type + use psb_serial_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer, intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_) :: psb_snrmi + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iia, jja, ia, ja, mdim, ndim, m + real(psb_spk_) :: nrmi + character(len=20) :: name, ch_err + + name='psb_snrmi' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iia /= 1).or.(jja /= 1)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if ((m /= 0).and.(n /= 0)) then + nrmi = psb_csnmi(a,info) + + if(info /= 0) then + info=4010 + ch_err='psb_csnmi' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + nrmi = 0.d0 + end if + ! compute global max + call psb_amx(ictxt, nrmi) + + psb_snrmi = nrmi + + 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 function psb_snrmi diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 new file mode 100644 index 000000000..8f491923f --- /dev/null +++ b/base/psblas/psb_sspmm.f90 @@ -0,0 +1,688 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspmm.f90 +! +! Subroutine: psb_sspmm +! Performs one of the distributed matrix-vector operations +! +! sub( Y ) := alpha * Pr * A * Pc * sub( X ) + beta * sub( Y ), or +! +! sub( Y ) := alpha * Pr * A' * Pr * sub( X ) + beta * sub( Y ), +! +! where: +! +! sub( X ) denotes: X(1:N,JX:JX+K-1), +! +! sub( Y ) denotes: Y(1:M,JY:JY+K-1), +! +! alpha and beta are scalars, and sub( X ) and sub( Y ) are distributed +! vectors and A is a M-by-N distributed matrix. +! +! Arguments: +! alpha - real The scalar alpha. +! a - type(psb_zspmat_type). The sparse matrix containing A. +! x(:,:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta. +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. Default: 'N' +! k - integer(optional). The number of right-hand sides. +! jx - integer(optional). The column offset for ( X ). Default: 1 +! jy - integer(optional). The column offset for ( Y ). Default: 1 +! work(:) - real,(optional). Working area. +! doswap - logical(optional). Whether to performe halo updates. +! +subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& + & trans, k, jx, jy, work, doswap) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(inout), target :: x(:,:) + real(psb_spk_), intent(inout), target :: y(:,:) + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans + integer, intent(in), optional :: k, jx, jy + logical, intent(in), optional :: doswap + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& + & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& + & i, ib, ib1, ip, idx + integer, parameter :: nb=4 + real(psb_spk_), pointer :: xp(:,:), yp(:,:), iwork(:) + real(psb_spk_), allocatable :: xvsave(:,:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit + + name='psb_sspmm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + iy = 1 + if (present(jy)) then + ijy = jy + else + ijy = 1 + endif + + if (present(doswap)) then + doswap_ = doswap + else + doswap_ = .true. + endif + + if (present(k)) then + ik = min(k,size(x,2)-ijx+1) + ik = min(ik,size(y,2)-ijy+1) + else + ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + endif + + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_ = 'N' + endif + if ( (trans_ == 'N').or.(trans_ == 'T')& + & .or.(trans_ == 'C')) then + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x,1) + lldy = size(y,1) + + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=szero + + ! checking for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (trans_ == 'N') then + ! Matrix is not transposed + if((ja /= ix).or.(ia /= iy)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + + if (doswap_.and.(np>1)) then + ib1=min(nb,ik) + xp => x(iix:lldx,jjx:jjx+ib1-1) + if (doswap_)& + & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ib1,szero,xp,desc_a,iwork,info) + + + blk: do i=1, ik, nb + ib=ib1 + ib1 = max(0,min(nb,(ik)-(i-1+ib))) + xp => x(iix:lldx,jjx+i+ib-1:jjx+i+ib+ib1-2) + if ((ib1 > 0).and.(doswap_)) & + & call psi_swapdata(psb_swap_send_,ib1,& + & szero,xp,desc_a,iwork,info) + + if(info /= 0) exit blk + + ! local Matrix-vector product + call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i+ib-1),& + & beta,y(:,jjy+i-1:jjy+i+ib-1),info,trans=trans_) + + if(info /= 0) exit blk + + if((ib1 > 0).and.(doswap_))& + & call psi_swapdata(psb_swap_recv_,ib1,& + & szero,xp,desc_a,iwork,info) + + if(info /= 0) exit blk + end do blk + else + if (doswap_)& + & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ib1,szero,x(:,1:ik),desc_a,iwork,info) + if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + end if + if(info /= 0) then + info = 4011 + call psb_errpush(info,name) + goto 9999 + end if + + else + + ! Matrix is transposed + if((ja /= iy).or.(ia /= ix)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + + ! checking for vectors correctness + call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + y(nrow+1:ncol,1:ik) = szero + + if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info + if (info /= 0) then + info = 4010 + ch_err='psb_csmm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + + if (doswap_)then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & ik,sone,y(:,1:ik),desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ik,sone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + end if + + if (aliw) deallocate(iwork,stat=info) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info + if(info /= 0) then + info = 4010 + ch_err='Deallocate iwork' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + nullify(iwork) + + 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_sspmm + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sspmv +! Performs one of the distributed matrix-vector operations +! +! Y := alpha * Pr * A * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A' * Pr * X + beta * Y, +! +! alpha and beta are scalars, and X and Y are distributed +! vectors and A is a M-by-N distributed matrix. +! +! Arguments: +! alpha - real The scalar alpha. +! a - type(psb_zspmat_type). The sparse matrix containing A. +! x(:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta. +! y(:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. Default: 'N' +! work(:) - real,(optional). Working area. +! doswap - logical(optional). Whether to performe halo updates. +! +subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& + & trans, work, doswap) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psb_const_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(inout), target :: x(:) + real(psb_spk_), intent(inout), target :: y(:) + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans + logical, intent(in), optional :: doswap + + ! locals + integer :: ictxt, np, me,& + & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & + & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& + & ib, ip, idx + integer, parameter :: nb=4 + real(psb_spk_), pointer :: iwork(:), xp(:), yp(:) + real(psb_spk_), allocatable :: xvsave(:) + character :: trans_ + character(len=20) :: name, ch_err + logical :: aliw, doswap_ + integer :: debug_level, debug_unit + + name='psb_sspmv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ia = 1 + ja = 1 + ix = 1 + jx = 1 + iy = 1 + jy = 1 + ik = 1 + ib = 1 + + if (present(doswap)) then + doswap_ = doswap + else + doswap_ = .true. + endif + + if (present(trans)) then + trans_ = psb_toupper(trans) + else + trans_ = 'N' + endif + if ( (trans_ == 'N').or.(trans_ == 'T')& + & .or.(trans_ == 'C')) then + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x) + lldy = size(y) + + iwork => null() + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info + ! checking for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= 0) then + info=4010 + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info + if (trans_ == 'N') then + ! Matrix is not transposed + if((ja /= ix).or.(ia /= iy)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + if (doswap_) then + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & szero,x,desc_a,iwork,info,data=psb_comm_halo_) + end if + + ! local Matrix-vector product + call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) + + if(info /= 0) then + info = 4011 + call psb_errpush(info,name) + goto 9999 + end if + + else + ! Matrix is transposed + if((ja /= iy).or.(ia /= ix)) then + ! this case is not yet implemented + info = 3030 + call psb_errpush(info,name) + goto 9999 + end if + + ! checking for vectors correctness + call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0)& + & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + call psb_errpush(info,name) + goto 9999 + end if + + xp => x(1:lldx) + yp => y(1:lldy) + + ! + ! Non-empty overlap, need a buffer to hold + ! the entries updated with average operator. + ! + call psi_ovrl_save(x,xvsave,desc_a,info) + if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + yp(nrow+1:ncol) = szero + + ! local Matrix-vector product + if (info == 0) call psb_csmm(alpha,a,x,beta,yp,info,trans=trans_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' csmm ', info + + if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= 0) then + info = 4010 + ch_err='psb_csmm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (doswap_) then + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & sone,yp,desc_a,iwork,info) + if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' swaptran ', info + if(info /= 0) then + info = 4010 + ch_err='PSI_dSwapTran' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + end if + + if (aliw) deallocate(iwork,stat=info) + if (debug_level >= psb_debug_comp_) & + & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info + if(info /= 0) then + info = 4010 + ch_err='Deallocate iwork' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nullify(iwork) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + 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_sspmv diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 new file mode 100644 index 000000000..37a3bc9c1 --- /dev/null +++ b/base/psblas/psb_sspsm.f90 @@ -0,0 +1,569 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspsm.f90 +! +! Subroutine: psb_sspsm +! Performs one of the distributed matrix-vector operations +! +! sub( Y ) := alpha * Pr * A-1 * Pc *sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * D * Pr * A-1 * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-1 * Pc * D * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-T * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * D * Pr * A-T * Pc * sub( X ) + beta * sub (Y ), or +! +! sub( Y ) := alpha * Pr * A-T * Pc * D * sub( X ) + beta * sub (Y ), or +! +! where : +! +! sub( X ) denotes X(1:M,JX:JX+K-1), +! +! sub( Y ) denotes Y(1:M,JY:JY+K-1). +! +! sub( X ) is a distributed +! vector and T is a M-by-M distributed triangular matrix. +! +! Arguments: +! alpha - real The scalar alpha. +! a - type(psb_zspmat_type). The sparse matrix containing A. +! x(:,:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta. +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. If not present 'N' is assumed. +! unitd - character(optional). Specify some type of operation with +! the diagonal matrix D. +! choice - integer(optional). The kind of update to perform on overlap elements. +! d(:) - real , optional Matrix for diagonal scaling. +! k - integer(optional). The number of right-hand sides. +! jx - integer(optional). The column offset for ( X ). Default: 1 +! jy - integer(optional). The column offset for ( Y ). Default: 1 +! work(:) - real , optional Working area. +! +! +subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& + & trans, unitd, choice, diag, k, jx, jy, work) + + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(in), target :: x(:,:) + real(psb_spk_), intent(inout), target :: y(:,:) + type (psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional, target :: diag(:) + real(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans, unitd + integer, intent(in), optional :: choice + integer, intent(in), optional :: k, jx, jy + + ! locals + integer :: ictxt, np, me,& + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, ijx, ijy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + + character :: lunitd + integer, parameter :: nb=4 + real(psb_spk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sspsm' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! just this case right now + ia = 1 + ja = 1 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + iy = 1 + if (present(jy)) then + ijy = jy + else + ijy = 1 + endif + + if (present(k)) then + ik = min(k,size(x,2)-ijx+1) + ik = min(ik,size(y,2)-ijy+1) + else + ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + endif + + if (present(choice)) then + choice_ = choice + else + choice_ = psb_avg_ + endif + + if (present(unitd)) then + lunitd = psb_toupper(unitd) + else + lunitd = 'U' + endif + + if (present(trans)) then + itrans = psb_toupper(trans) + if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then + ! OK + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + else + itrans = 'N' + endif + + m = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x,1) + lldy = size(y,1) + + if((lldx < ncol).or.(lldy < ncol)) then + info=3010 + call psb_errpush(info,name) + goto 9999 + end if + + ! check for presence/size of a work area + iwork => null() + liwork= 2*ncol + if (a%pr(1) /= 0) llwork = liwork + m * ik + if (a%pl(1) /= 0) llwork = llwork + m * ik + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=0.d0 + + if(present(diag)) then + lld = size(diag) + id => diag + else + lld=1 + allocate(id(1)) + id=1.d0 + end if + + ! checking for matrix correctness + call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) + ! checking for vectors correctness + if (info == 0) & + & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect/mat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(ja /= ix) then + ! this case is not yet implemented + info = 3030 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + end if + + if(info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! Perform local triangular system solve + xp => x(iix:lldx,jjx:jjx+ik-1) + yp => y(iiy:lldy,jjy:jjy+ik-1) + call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) + + if(info /= 0) then + info = 4010 + ch_err='dcssm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! update overlap elements + if (choice_ > 0) then + + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& + & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + end if + + if(aliw) deallocate(iwork) + if(.not.present(diag)) deallocate(id) + + 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_sspsm + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sspsv +! Performs one of the distributed matrix-vector operations +! +! Y := alpha * Pr * A-1 * Pc * X + beta * Y, or +! +! Y := alpha * D * Pr * A-1 * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A-1 * Pc * D * X + beta * Y, or +! +! Y := alpha * Pr * A-T * Pc * X + beta * Y, or +! +! Y := alpha * D * Pr * A-T * Pc * X + beta * Y, or +! +! Y := alpha * Pr * A-T * Pc * D * X + beta * Y, or +! +! X is a distributed +! vector and T is a M-by-M distributed triangular matrix. +! +! +! Arguments: +! alpha - real The scalar alpha. +! a - type(psb_zspmat_type). The sparse matrix containing A. +! x(:) - real The input vector containing the entries of ( X ). +! beta - real The scalar beta. +! y(:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! trans - character(optional). Whether A or A'. If not present 'N' is assumed. +! unitd - character(optional). Specify some type of operation with +! the diagonal matrix D. +! choice - integer(optional). The kind of update to perform on overlap elements. +! d(:) - real , optional Matrix for diagonal scaling. +! work(:) - real , optional Working area. +! +subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& + & trans, unitd, choice, diag, work) + use psb_spmat_type + use psb_serial_mod + use psb_descriptor_type + use psb_comm_mod + use psi_mod + use psb_check_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(in), target :: x(:) + real(psb_spk_), intent(inout), target :: y(:) + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_spk_), intent(in), optional, target :: diag(:) + real(psb_spk_), optional, target :: work(:) + character, intent(in), optional :: trans, unitd + integer, intent(in), optional :: choice + + ! locals + integer :: ictxt, np, me, & + & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& + & ix, iy, ik, jx, jy, i, lld,& + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + + character :: lunitd + integer, parameter :: nb=4 + real(psb_spk_),pointer :: iwork(:), xp(:), yp(:), id(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sspsv' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ! just this case right now + ia = 1 + ja = 1 + ix = 1 + iy = 1 + ik = 1 + jx= 1 + jy= 1 + + if (present(choice)) then + choice_ = choice + else + choice_ = psb_avg_ + endif + + if (present(unitd)) then + lunitd = psb_toupper(unitd) + else + lunitd = 'U' + endif + + if (present(trans)) then + itrans = psb_toupper(trans) + if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then + ! Ok + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if + else + itrans = 'N' + endif + + m = psb_cd_get_global_rows(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + lldx = size(x) + lldy = size(y) + + if((lldx < ncol).or.(lldy < ncol)) then + info=3010 + call psb_errpush(info,name) + goto 9999 + end if + + iwork => null() + ! check for presence/size of a work area + liwork= 2*ncol + + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + iwork => work + endif + + iwork(1)=0.d0 + + if (present(diag)) then + lld = size(diag) + id => diag + else + lld=1 + allocate(id(1)) + id=1.d0 + end if + + ! checking for matrix correctness + call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) + ! checking for vectors correctness + if (info == 0) & + & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) + if (info == 0)& + & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect/mat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(ja /= ix) then + ! this case is not yet implemented + info = 3030 + end if + + if((iix /= 1).or.(iiy /= 1)) then + ! this case is not yet implemented + info = 3040 + end if + + if(info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! Perform local triangular system solve + xp => x(iix:lldx) + yp => y(iiy:lldy) + call psb_cssm(alpha,a,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans) + + if(info /= 0) then + info = 4010 + ch_err='dcssm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! update overlap elements + if (choice_ > 0) then + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) + + + if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Inner updates') + goto 9999 + end if + end if + + if (aliw) deallocate(iwork) + if(.not.present(diag)) deallocate(id) + + 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_sspsv + diff --git a/base/psblas/psb_sxdot.f90 b/base/psblas/psb_sxdot.f90 new file mode 100644 index 000000000..f1fada3c8 --- /dev/null +++ b/base/psblas/psb_sxdot.f90 @@ -0,0 +1,595 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sdot.f90 +! +! Function: psb_sdot +! psb_sdot forms the dot product of two distributed vectors, +! +! dot := sub( X )**T * sub( Y ) +! +! where sub( X ) denotes X(:,JX) +! +! sub( Y ) denotes Y(:,JY). +! +! Arguments: +! x(:,:) - real The input vector containing the entries of ( X ). +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The column offset for sub( X ). +! jy - integer(optional). The column offset for sub( Y ). +! +function psb_sxdot(x, y,desc_a, info, jx, jy) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(in), optional :: jx, jy + integer, intent(out) :: info + real(psb_dpk_) :: psb_sxdot + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m + real(psb_dpk_) :: dot_local + real(psb_dpk_) :: sxdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + if (present(jx)) then + ijx = jx + else + ijx = ione + endif + + iy = ione + if (present(jy)) then + ijy = jy + else + ijy = ione + endif + + if(ijx /= ijy) then + info=3050 + call psb_errpush(info,name) + goto 9999 + end if + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sxdot(psb_cd_get_local_rows(desc_a),& + & x(iix,jjx),ione,y(iiy,jjy),ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx,jjx)*y(idx,jjy)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_sxdot = dot_local + + 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 function psb_sxdot + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_sdotv +! psb_sdotv forms the dot product of two distributed vectors, +! +! dot := X**T * Y +! +! Arguments: +! x(:) - real The input vector containing the entries of X. +! y(:) - real The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +function psb_sxdotv(x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:), y(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + real(psb_dpk_) :: psb_sxdotv + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m + real(psb_dpk_) :: dot_local + real(psb_dpk_) :: sxdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + jx = ione + jy = ione + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sxdot(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + psb_sxdotv = dot_local + + 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 function psb_sxdotv + +function sxdot(n,x,ix,y,iy) + use psb_const_mod + real(psb_dpk_) :: sxdot + integer :: n,ix,iy + real(psb_spk_) :: x(*),y(*) + real(psb_dpk_) :: tmp + integer :: i + + if ((ix /= 1).or.(iy /= 1)) then + write(0,*) 'WARNING unimplemented case in SXDOT' + sxdot=dzero + return + end if + + tmp = dzero + do i=1, n + tmp = tmp + dble(x(i))*dble(y(i)) + end do + sxdot = tmp + +end function sxdot + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sdotvs +! psb_sdotvs forms the dot product of two distributed vectors, +! +! dot := X**T * Y +! +! Arguments: +! res - real The result. +! x(:) - real The input vector containing the entries of X. +! y(:) - real The input vector containing the entries of Y. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_sxdotvs(res, x, y,desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:), y(:) + real(psb_dpk_), intent(out) :: res + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m + real(psb_dpk_) :: dot_local + real(psb_dpk_) :: sxdot + character(len=20) :: name, ch_err + + name='psb_sdot' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + m = psb_cd_get_global_rows(desc_a) + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if (info == 0) & + & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + dot_local = sxdot(psb_cd_get_local_rows(desc_a),& + & x,ione,y,ione) + ! adjust dot_local because overlapped elements are computed more than once + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local = dot_local - (real(ndm-1)/real(ndm))*(x(idx)*y(idx)) + end do + else + dot_local=0.0 + end if + else + dot_local=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local) + + res = dot_local + + 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_sxdotvs + + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_smdots +! psb_smdots forms the dot product of multiple distributed vectors, +! +! res(i) := ( X(:,i) )**T * ( Y(:,i) ) +! +! Arguments: +! res(:) - real. The result. +! x(:,:) - real The input vector containing the entries of ( X ). +! y(:,:) - real The input vector containing the entries of ( Y ). +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! +subroutine psb_sxmdots(res, x, y, desc_a, info) + use psb_descriptor_type + use psb_check_mod + use psb_error_mod + use psb_penv_mod + implicit none + + real(psb_spk_), intent(in) :: x(:,:), y(:,:) + real(psb_dpk_), intent(out) :: res(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + + ! locals + integer :: ictxt, np, me, idx, ndm,& + & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k + real(psb_dpk_),allocatable :: dot_local(:) + real(psb_dpk_) :: sxdot + character(len=20) :: name, ch_err + + name='psb_smdots' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = psb_cd_get_global_rows(desc_a) + + ! check vector correctness + call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) + if(info /= 0) then + info=4010 + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ix /= ione).or.(iy /= ione)) then + info=3040 + call psb_errpush(info,name) + goto 9999 + end if + + k = min(size(x,2),size(y,2)) + allocate(dot_local(k)) + + if(m /= 0) then + if(psb_cd_get_local_rows(desc_a) > 0) then + do j=1,k + dot_local(j) = sxdot(psb_cd_get_local_rows(desc_a),& + & x(1,j),ione,y(1,j),ione) + ! adjust dot_local because overlapped elements are computed more than once + end do + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dot_local(1:k) = dot_local(1:k) - (real(ndm-1)/real(ndm))*(x(idx,1:k)*y(idx,1:k)) + end do + else + dot_local(:)=0.0 + end if + else + dot_local(:)=0.0 + end if + + ! compute global sum + call psb_sum(ictxt, dot_local(1:k)) + + res(1:k) = dot_local(1:k) + + 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_sxmdots diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 50b377be0..f575df602 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -70,7 +70,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy character(len=20) :: name, ch_err - name='psb_dgeaxpby' + name='psb_geaxpby' if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) @@ -224,7 +224,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) character(len=20) :: name, ch_err logical, parameter :: debug=.false. - name='psb_dgeaxpby' + name='psb_geaxpby' if(psb_get_errstatus() /= 0) return info=0 call psb_erractionsave(err_act) diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index fc6388c28..d275addbc 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -57,7 +57,7 @@ function psb_znrmi(a,desc_a,info) ! locals integer :: ictxt, np, me,& & err_act, n, iia, jja, ia, ja, mdim, ndim, m - real(psb_dpk_) :: nrmi, zcsnmi + real(psb_dpk_) :: nrmi character(len=20) :: name, ch_err name='psb_znrmi' @@ -94,15 +94,11 @@ function psb_znrmi(a,desc_a,info) end if if ((m /= 0).and.(n /= 0)) then - mdim = psb_cd_get_local_rows(desc_a) - ndim = psb_cd_get_local_cols(desc_a) - nrmi = zcsnmi('N',mdim,ndim,a%fida,& - & a%descra,a%aspk,a%ia1,a%ia2,& - & a%infoa,info) + nrmi = psb_csnmi(a,info) if(info /= 0) then info=4010 - ch_err='dcsnmi' + ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/base/psblas/pstreecomb.F b/base/psblas/pstreecomb.F new file mode 100644 index 000000000..31ba0b8cd --- /dev/null +++ b/base/psblas/pstreecomb.F @@ -0,0 +1,396 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C +C This file imported from ScaLAPACK. +C +C + SUBROUTINE PSTREECOMB( ICTXT, SCOPE, N, MINE, RDEST0, CDEST0, + $ SUBPTR ) +* +* -- ScaLAPACK tools routine (version 1.5) -- +* University of Tennessee, Knoxville, Oak Ridge National Laboratory, +* and University of California, Berkeley. +* May 1, 1997 +* +* .. Scalar Arguments .. + CHARACTER SCOPE + INTEGER CDEST0, ICTXT, N, RDEST0 +* .. +* .. Array Arguments .. + REAL MINE( * ) +* .. +* .. Subroutine Arguments .. + EXTERNAL SUBPTR +* .. +* +* Purpose +* ======= +* +* PSTREECOMB does a 1-tree parallel combine operation on scalars, +* using the subroutine indicated by SUBPTR to perform the required +* computation. +* +* Arguments +* ========= +* +* ICTXT (global input) INTEGER +* The BLACS context handle, indicating the global context of +* the operation. The context itself is global. +* +* SCOPE (global input) CHARACTER +* The scope of the operation: 'Rowwise', 'Columnwise', or +* 'All'. +* +* N (global input) INTEGER +* The number of elements in MINE. N = 1 for the norm-2 +* computation and 2 for the sum of square. +* +* MINE (local input/global output) REAL array of +* dimension at least equal to N. The local data to use in the +* combine. +* +* RDEST0 (global input) INTEGER +* The process row to receive the answer. If RDEST0 = -1, +* every process in the scope gets the answer. +* +* CDEST0 (global input) INTEGER +* The process column to receive the answer. If CDEST0 = -1, +* every process in the scope gets the answer. +* +* SUBPTR (local input) Pointer to the subroutine to call to perform +* the required combine. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL BCAST, RSCOPE, CSCOPE + INTEGER CMSSG, DEST, DIST, HISDIST, I, IAM, MYCOL, + $ MYROW, MYDIST, MYDIST2, NP, NPCOL, NPROW, + $ RMSSG, TCDEST, TRDEST +* .. +* .. Local Arrays .. + REAL HIS( 2 ) +* .. +* .. External Subroutines .. +#if !defined(SERIAL_MPI) + EXTERNAL BLACS_GRIDINFO, SGEBR2D, SGEBS2D, + $ SGERV2D, SGESD2D +#endif +* .. +* .. External Functions .. + LOGICAL PSB_LSAME + EXTERNAL PSB_LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* See if everyone wants the answer (need to broadcast the answer) +* + BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) ) + IF( BCAST ) THEN + TRDEST = 0 + TCDEST = 0 + ELSE + TRDEST = RDEST0 + TCDEST = CDEST0 + END IF +#if !defined(SERIAL_MPI) + +* +* Get grid parameters. +* + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Figure scope-dependant variables, or report illegal scope +* + RSCOPE = PSB_LSAME( SCOPE, 'R' ) + CSCOPE = PSB_LSAME( SCOPE, 'C' ) +* + IF( RSCOPE ) THEN + IF( BCAST ) THEN + TRDEST = MYROW + ELSE IF( MYROW.NE.TRDEST ) THEN + RETURN + END IF + NP = NPCOL + MYDIST = MOD( NPCOL + MYCOL - TCDEST, NPCOL ) + ELSE IF( CSCOPE ) THEN + IF( BCAST ) THEN + TCDEST = MYCOL + ELSE IF( MYCOL.NE.TCDEST ) THEN + RETURN + END IF + NP = NPROW + MYDIST = MOD( NPROW + MYROW - TRDEST, NPROW ) + ELSE IF( PSB_LSAME( SCOPE, 'A' ) ) THEN + NP = NPROW * NPCOL + IAM = MYROW*NPCOL + MYCOL + DEST = TRDEST*NPCOL + TCDEST + MYDIST = MOD( NP + IAM - DEST, NP ) + ELSE + RETURN + END IF +* + IF( NP.LT.2 ) + $ RETURN +* + MYDIST2 = MYDIST + RMSSG = MYROW + CMSSG = MYCOL + I = 1 +* + 10 CONTINUE +* + IF( MOD( MYDIST, 2 ).NE.0 ) THEN +* +* If I am process that sends information +* + DIST = I * ( MYDIST - MOD( MYDIST, 2 ) ) +* +* Figure coordinates of dest of message +* + IF( RSCOPE ) THEN + CMSSG = MOD( TCDEST + DIST, NP ) + ELSE IF( CSCOPE ) THEN + RMSSG = MOD( TRDEST + DIST, NP ) + ELSE + CMSSG = MOD( DEST + DIST, NP ) + RMSSG = CMSSG / NPCOL + CMSSG = MOD( CMSSG, NPCOL ) + END IF +* + CALL SGESD2D( ICTXT, N, 1, MINE, N, RMSSG, CMSSG ) +* + GO TO 20 +* + ELSE +* +* If I am a process receiving information, figure coordinates +* of source of message +* + DIST = MYDIST2 + I + IF( RSCOPE ) THEN + CMSSG = MOD( TCDEST + DIST, NP ) + HISDIST = MOD( NP + CMSSG - TCDEST, NP ) + ELSE IF( CSCOPE ) THEN + RMSSG = MOD( TRDEST + DIST, NP ) + HISDIST = MOD( NP + RMSSG - TRDEST, NP ) + ELSE + CMSSG = MOD( DEST + DIST, NP ) + RMSSG = CMSSG / NPCOL + CMSSG = MOD( CMSSG, NPCOL ) + HISDIST = MOD( NP + RMSSG*NPCOL+CMSSG - DEST, NP ) + END IF +* + IF( MYDIST2.LT.HISDIST ) THEN +* +* If I have anyone sending to me +* + CALL SGERV2D( ICTXT, N, 1, HIS, N, RMSSG, CMSSG ) + CALL SUBPTR( MINE, HIS ) +* + END IF + MYDIST = MYDIST / 2 +* + END IF + I = I * 2 +* + IF( I.LT.NP ) + $ GO TO 10 +* + 20 CONTINUE +* + IF( BCAST ) THEN + IF( MYDIST2.EQ.0 ) THEN + CALL SGEBS2D( ICTXT, SCOPE, ' ', N, 1, MINE, N ) + ELSE + CALL SGEBR2D( ICTXT, SCOPE, ' ', N, 1, MINE, N, + $ TRDEST, TCDEST ) + END IF + END IF +#endif +* + RETURN +* +* End of PSTREECOMB +* + END +* + SUBROUTINE SCOMBAMAX( V1, V2 ) +* +* -- ScaLAPACK tools routine (version 1.5) -- +* University of Tennessee, Knoxville, Oak Ridge National Laboratory, +* and University of California, Berkeley. +* May 1, 1997 +* +* .. Array Arguments .. + REAL V1( 2 ), V2( 2 ) +* .. +* +* Purpose +* ======= +* +* SCOMBAMAX finds the element having max. absolute value as well +* as its corresponding globl index. +* +* Arguments +* ========= +* +* V1 (local input/local output) REAL array of +* dimension 2. The first maximum absolute value element and +* its global index. V1(1) = AMAX, V1(2) = INDX. +* +* V2 (local input) REAL array of dimension 2. +* The second maximum absolute value element and its global +* index. V2(1) = AMAX, V2(2) = INDX. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( ABS( V1( 1 ) ).LT.ABS( V2( 1 ) ) ) THEN + V1( 1 ) = V2( 1 ) + V1( 2 ) = V2( 2 ) + END IF +* + RETURN +* +* End of SCOMBAMAX +* + END +* + SUBROUTINE SCOMBSSQ( V1, V2 ) +* +* -- ScaLAPACK tools routine (version 1.5) -- +* University of Tennessee, Knoxville, Oak Ridge National Laboratory, +* and University of California, Berkeley. +* May 1, 1997 +* +* .. Array Arguments .. + REAL V1( 2 ), V2( 2 ) +* .. +* +* Purpose +* ======= +* +* SCOMBSSQ does a scaled sum of squares on two scalars. +* +* Arguments +* ========= +* +* V1 (local input/local output) REAL array of +* dimension 2. The first scaled sum. V1(1) = SCALE, +* V1(2) = SUMSQ. +* +* V2 (local input) REAL array of dimension 2. +* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) +* .. +* .. Executable Statements .. +* + IF( V1( 1 ).GE.V2( 1 ) ) THEN + IF( V1( 1 ).NE.ZERO ) + $ V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) + ELSE + V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) + V1( 1 ) = V2( 1 ) + END IF +* + RETURN +* +* End of SCOMBSSQ +* + END +* + SUBROUTINE SCOMBNRM2( X, Y ) +* +* -- ScaLAPACK tools routine (version 1.5) -- +* University of Tennessee, Knoxville, Oak Ridge National Laboratory, +* and University of California, Berkeley. +* May 1, 1997 +* +* .. Scalar Arguments .. + REAL X, Y +* .. +* +* Purpose +* ======= +* +* SCOMBNRM2 combines local norm 2 results, taking care not to cause +* unnecessary overflow. +* +* Arguments +* ========= +* +* X (local input) REAL +* Y (local input) REAL +* X and Y specify the values x and y. X and Y are supposed to +* be >= 0. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + REAL W, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + W = MAX( X, Y ) + Z = MIN( X, Y ) +* + IF( Z.EQ.ZERO ) THEN + X = W + ELSE + X = W*SQRT( ONE+( Z / W )**2 ) + END IF +* + RETURN +* +* End of SCOMBNRM2 +* + END diff --git a/base/serial/Makefile b/base/serial/Makefile index 8c4410dc2..e3a6e8157 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -14,7 +14,20 @@ FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \ psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\ psb_getifield.o psb_setifield.o psb_update_mod.o psb_getrow_mod.o\ psb_dgelp.o psb_zgelp.o psb_dcsrp.o psb_zcsrp.o\ - psb_dspshift.o psb_dspsetbld.o psb_zspshift.o psb_zspsetbld.o + psb_dspshift.o psb_dspsetbld.o psb_zspshift.o psb_zspsetbld.o\ + psb_scsprt.o psb_sspcnv.o psb_scoins.o psb_scsmm.o psb_scsmv.o \ + psb_scssm.o psb_scssv.o psb_sneigh.o psb_sspgtblk.o psb_sspgetrow.o \ + psb_sfixcoo.o psb_sipcsr2coo.o psb_sipcoo2csr.o psb_sipcoo2csc.o \ + psb_sgelp.o psb_sspgtdiag.o psb_scsnmi.o psb_stransp.o \ + psb_sspclip.o psb_srwextd.o psb_sspscal.o\ + psb_snumbmm.o psb_ssymbmm.o\ + psb_ccsprt.o psb_cspcnv.o psb_ccoins.o psb_ccsnmi.o\ + psb_cfixcoo.o psb_cipcsr2coo.o psb_cipcoo2csr.o psb_cipcoo2csc.o \ + psb_cgelp.o psb_cspgtdiag.o psb_cspgtblk.o psb_cspgetrow.o\ + psb_ccssm.o psb_ccssv.o psb_ccsmm.o psb_ccsmv.o psb_ctransp.o psb_ctransc.o\ + psb_cspclip.o psb_crwextd.o psb_cspscal.o\ + psb_cnumbmm.o psb_csymbmm.o psb_cneigh.o +# LIBDIR=.. MODDIR=../modules @@ -27,9 +40,9 @@ lib: auxd cood csrd jadd f77d dpd lib1 lib1: $(FOBJS) -psb_dcoins.o psb_zcoins.o: psb_update_mod.o -psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o -psb_dspcnv.o pzb_zspcnv.o: psb_regen_mod.o +psb_scoins.o psb_dcoins.o psb_zcoins.o: psb_update_mod.o +psb_sspgetrow.o psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o +psb_sspcnv.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 a4c3f734c..ebfe0661e 100644 --- a/base/serial/aux/Makefile +++ b/base/serial/aux/Makefile @@ -6,6 +6,10 @@ include ../../../Make.inc 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 dmsr.o dmsrx.o dmsort_up.o dmsort_dw.o \ + ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o smsort_up.o smsort_dw.o \ + clcmp_mod.o clsr.o clsrx.o \ + calcmp_mod.o calsr.o calsrx.o \ + cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\ zlcmp_mod.o zlsr.o zlsrx.o \ zalcmp_mod.o zalsr.o zalsrx.o \ zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o diff --git a/base/serial/aux/cacmp_mod.f90 b/base/serial/aux/cacmp_mod.f90 new file mode 100644 index 000000000..ca96bb99f --- /dev/null +++ b/base/serial/aux/cacmp_mod.f90 @@ -0,0 +1,80 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +module cacmp_mod + use psb_const_mod + interface operator(<) + module procedure calt + end interface + interface operator(<=) + module procedure cale + end interface + interface operator(>) + module procedure cagt + end interface + interface operator(>=) + module procedure cage + end interface + +contains + + function calt(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: calt + + calt = (abs(a) < abs(b)) + end function calt + function cale(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: cale + + cale = (abs(a) <= abs(b)) + end function cale + + function cagt(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: cagt + + cagt = (abs(a) > abs(b)) + end function cagt + function cage(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: cage + + cage = (abs(a) >= abs(b)) + end function cage + +end module cacmp_mod + diff --git a/base/serial/aux/calcmp_mod.f90 b/base/serial/aux/calcmp_mod.f90 new file mode 100644 index 000000000..21e5348b8 --- /dev/null +++ b/base/serial/aux/calcmp_mod.f90 @@ -0,0 +1,84 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +module calcmp_mod + use psb_const_mod + interface operator(<) + module procedure callt + end interface + interface operator(<=) + module procedure calle + end interface + interface operator(>) + module procedure calgt + end interface + interface operator(>=) + module procedure calge + end interface + +contains + + function callt(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: callt + + callt = (abs(real(a))abs(real(b))).or. & + & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) + end function calgt + function calge(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: calge + + calge = (abs(real(a))>abs(real(b))).or. & + & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) + end function calge + +end module calcmp_mod + diff --git a/base/serial/aux/calsr.f90 b/base/serial/aux/calsr.f90 new file mode 100644 index 000000000..1df09b352 --- /dev/null +++ b/base/serial/aux/calsr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 calsr(n,x,dir) + use psb_serial_mod + use calcmp_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(psb_spk_) :: x(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: 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 + ! + ! 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 + call psb_errpush(4001,r_name='calsr',a_err='impossible pivot condition') + call psb_error() + 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 icalsr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icalsr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icalsr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call icalsr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call icalsr_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 + ! + ! 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 + call psb_errpush(4001,r_name='calsr',a_err='impossible pivot condition') + call psb_error() + 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 icalsr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icalsr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icalsr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call icalsr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call icalsr_dw(n,x) + endif + + case default + call psb_errpush(4001,r_name='calsr',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine icalsr_up(n,x) + use calcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 icalsr_up + + subroutine icalsr_dw(n,x) + use calcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 icalsr_dw + +end subroutine calsr diff --git a/base/serial/aux/calsrx.f90 b/base/serial/aux/calsrx.f90 new file mode 100644 index 000000000..f52ab42b2 --- /dev/null +++ b/base/serial/aux/calsrx.f90 @@ -0,0 +1,414 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 calsrx(n,x,indx,dir,flag) + use psb_serial_mod + use calcmp_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(psb_spk_) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer i, j, 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 + call psb_errpush(4001,r_name='calsrx',a_err='wrong flag') + call psb_error() + 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 + ! + ! 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 + call psb_errpush(4001,r_name='calsrx',a_err='impossible pivot condition') + call psb_error() + 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 icalsrx_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 icalsrx_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 icalsrx_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 icalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call icalsrx_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 + ! + ! 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 + call psb_errpush(4001,r_name='calsrx',a_err='impossible pivot condition') + call psb_error() + 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 icalsrx_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 icalsrx_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 icalsrx_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 icalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call icalsrx_dw(n,x,indx) + endif + + case default + call psb_errpush(4001,r_name='calsrx',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine icalsrx_up(n,x,indx) + use calcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 icalsrx_up + + subroutine icalsrx_dw(n,x,indx) + use calcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 icalsrx_dw + +end subroutine calsrx diff --git a/base/serial/aux/camsort_dw.f90 b/base/serial/aux/camsort_dw.f90 new file mode 100644 index 000000000..ec9b98370 --- /dev/null +++ b/base/serial/aux/camsort_dw.f90 @@ -0,0 +1,173 @@ +! +! Parallel Sparse BLAS version 2.2 +! (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: msort_dw.f90 +! +! Subroutine: msort_dw +! This subroutine sorts an integer array into ascending order. +! +! Arguments: +! n - integer Input: size of the array +! k - real(*) input: array of keys to be sorted +! l - integer(0:n+1) output: link list +! iret - integer output: 0 Normal termination +! 1 the array was already sorted +! * +! REFERENCES = (1) D. E. Knuth * +! The Art of Computer Programming, * +! vol.3: Sorting and Searching * +! Addison-Wesley, 1973 * +! * +! call msort_dw(n,x,iaux,iret) +! +! if (iret == 0) then +! lp = iaux(0) +! k = 1 +! do +! if ((lp==0).or.(k>n)) exit +! do +! if (lp >= k) exit +! lp = iaux(lp) +! end do +! iswap = x(lp) +! x(lp) = x(k) +! x(k) = iswap +! lswap = iaux(lp) +! iaux(lp) = iaux(k) +! iaux(k) = lp +! lp = lswap +! k = k + 1 +! enddo +! end if +! +! +subroutine camsort_dw(n,k,l,iret) + use cacmp_mod + implicit none + integer n, iret + complex(psb_spk_) :: k(n) + integer l(0:n+1) + ! + integer p,q,s,t + intrinsic iabs,isign + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = iabs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = isign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = isign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = isign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine camsort_dw diff --git a/base/serial/aux/camsort_up.f90 b/base/serial/aux/camsort_up.f90 new file mode 100644 index 000000000..db36fe3f6 --- /dev/null +++ b/base/serial/aux/camsort_up.f90 @@ -0,0 +1,173 @@ +! +! Parallel Sparse BLAS version 2.2 +! (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: msort_up.f90 +! +! Subroutine: msort_up +! This subroutine sorts an integer array into ascending order. +! +! Arguments: +! n - integer Input: size of the array +! k - integer(*) input: array of keys to be sorted +! l - integer(0:n+1) output: link list +! iret - integer output: 0 Normal termination +! 1 the array was already sorted +! * +! REFERENCES = (1) D. E. Knuth * +! The Art of Computer Programming, * +! vol.3: Sorting and Searching * +! Addison-Wesley, 1973 * +! * +! call msort_up(n,x,iaux,iret) +! +! if (iret == 0) then +! lp = iaux(0) +! k = 1 +! do +! if ((lp==0).or.(k>n)) exit +! do +! if (lp >= k) exit +! lp = iaux(lp) +! end do +! iswap = x(lp) +! x(lp) = x(k) +! x(k) = iswap +! lswap = iaux(lp) +! iaux(lp) = iaux(k) +! iaux(k) = lp +! lp = lswap +! k = k + 1 +! enddo +! end if +! +! +subroutine camsort_up(n,k,l,iret) + use cacmp_mod + implicit none + integer n, iret + complex(psb_spk_) k(n) + integer l(0:n+1) + ! + integer p,q,s,t + intrinsic iabs,isign + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = iabs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = isign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = isign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = isign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine camsort_up diff --git a/base/serial/aux/camsr.f90 b/base/serial/aux/camsr.f90 new file mode 100644 index 000000000..308b39087 --- /dev/null +++ b/base/serial/aux/camsr.f90 @@ -0,0 +1,92 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: imsr.f90 + ! Subroutine: + ! Parameters: +subroutine camsr(n,x,idir) + use psb_serial_mod + implicit none + + integer :: n, idir + complex(psb_spk_) :: x(n) + + + integer, allocatable :: iaux(:) + + integer :: lswap, iret, info, lp, k + complex(psb_spk_) :: swap + + if (n<0) then + return + endif + + if (n<=1) return + + allocate(iaux(0:n+1),stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='camsr') + call psb_error() + endif + + if (idir==psb_asort_up_) then + call camsort_up(n,x,iaux,iret) + else + call camsort_dw(n,x,iaux,iret) + end if + + if (iret == 0) then + lp = iaux(0) + k = 1 + do + if ((lp==0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + end if + + deallocate(iaux,stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='camsr') + call psb_error() + endif + return +end subroutine camsr diff --git a/base/serial/aux/camsrx.f90 b/base/serial/aux/camsrx.f90 new file mode 100644 index 000000000..d616f1783 --- /dev/null +++ b/base/serial/aux/camsrx.f90 @@ -0,0 +1,102 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: imsrx.f90 + ! Subroutine: + ! Parameters: +subroutine camsrx(n,x,indx,idir,flag) + use psb_serial_mod + implicit none + integer :: n,idir,flag + complex(psb_spk_) :: x(n) + integer :: indx(n) + + integer, allocatable :: iaux(:) + + integer :: iret, info, lp, k,lswap, ixswap + complex(psb_spk_) :: swap + + if (n<0) then + return + endif + + if (n==0) return + + if (flag == psb_sort_ovw_idx_) then + do k=1,n + indx(k) = k + enddo + end if + + if (n==1) return + + allocate(iaux(0:n+1),stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='camsrx') + call psb_error() + endif + + if (idir == psb_asort_up_) then + call camsort_up(n,x,iaux,iret) + else + call camsort_dw(n,x,iaux,iret) + end if + + if (iret /= 1) then + lp = iaux(0) + k = 1 + do + if ((lp==0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + end if + + deallocate(iaux,stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='camsrx') + call psb_error() + endif + return +end subroutine camsrx diff --git a/base/serial/aux/casr.f90 b/base/serial/aux/casr.f90 new file mode 100644 index 000000000..d40efb1f6 --- /dev/null +++ b/base/serial/aux/casr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 casr(n,x,dir) + use psb_serial_mod + use cacmp_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(psb_spk_) :: x(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: 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 + ! + ! 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 + call psb_errpush(4001,r_name='casr',a_err='impossible pivot condition') + call psb_error() + 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 icasr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icasr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icasr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call icasr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call icasr_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 + ! + ! 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 + call psb_errpush(4001,r_name='casr',a_err='impossible pivot condition') + call psb_error() + 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 icasr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icasr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call icasr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call icasr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call icasr_dw(n,x) + endif + + case default + call psb_errpush(4001,r_name='casr',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine icasr_up(n,x) + use cacmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 icasr_up + + subroutine icasr_dw(n,x) + use cacmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 icasr_dw + +end subroutine casr diff --git a/base/serial/aux/casrx.f90 b/base/serial/aux/casrx.f90 new file mode 100644 index 000000000..bfc40c440 --- /dev/null +++ b/base/serial/aux/casrx.f90 @@ -0,0 +1,414 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 casrx(n,x,indx,dir,flag) + use psb_serial_mod + use cacmp_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(psb_spk_) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer i, j, 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 + call psb_errpush(4001,r_name='casrx',a_err='wrong flag') + call psb_error() + 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 + ! + ! 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 + call psb_errpush(4001,r_name='casrx',a_err='impossible pivot condition') + call psb_error() + 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 icasrx_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 icasrx_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 icasrx_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 icasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call icasrx_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 + ! + ! 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 + call psb_errpush(4001,r_name='casrx',a_err='impossible pivot condition') + call psb_error() + 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 icasrx_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 icasrx_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 icasrx_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 icasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call icasrx_dw(n,x,indx) + endif + + case default + call psb_errpush(4001,r_name='casrx',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine icasrx_up(n,x,indx) + use cacmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 icasrx_up + + subroutine icasrx_dw(n,x,indx) + use cacmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 icasrx_dw + +end subroutine casrx diff --git a/base/serial/aux/clcmp_mod.f90 b/base/serial/aux/clcmp_mod.f90 new file mode 100644 index 000000000..086e08cfa --- /dev/null +++ b/base/serial/aux/clcmp_mod.f90 @@ -0,0 +1,80 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +module clcmp_mod + use psb_const_mod + interface operator(<) + module procedure cllt + end interface + interface operator(<=) + module procedure clle + end interface + interface operator(>) + module procedure clgt + end interface + interface operator(>=) + module procedure clge + end interface + +contains + + function cllt(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: cllt + + cllt = (real(a)real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b))) + end function clgt + function clge(a,b) + use psb_const_mod + complex(psb_spk_), intent(in) :: a,b + logical :: clge + + clge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b))) + end function clge + +end module clcmp_mod + diff --git a/base/serial/aux/clsr.f90 b/base/serial/aux/clsr.f90 new file mode 100644 index 000000000..3fa475b0d --- /dev/null +++ b/base/serial/aux/clsr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 clsr(n,x,dir) + use psb_serial_mod + use clcmp_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(psb_spk_) :: x(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: 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 + ! + ! 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 + call psb_errpush(4001,r_name='clsr',a_err='impossible pivot condition') + call psb_error() + 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 iclsr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iclsr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iclsr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iclsr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call iclsr_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 + ! + ! 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 + call psb_errpush(4001,r_name='clsr',a_err='impossible pivot condition') + call psb_error() + 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 iclsr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iclsr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iclsr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iclsr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call iclsr_dw(n,x) + endif + + case default + call psb_errpush(4001,r_name='clsr',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine iclsr_up(n,x) + use clcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 iclsr_up + + subroutine iclsr_dw(n,x) + use clcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: i,j + complex(psb_spk_) :: 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 iclsr_dw + +end subroutine clsr diff --git a/base/serial/aux/clsrx.f90 b/base/serial/aux/clsrx.f90 new file mode 100644 index 000000000..00446412f --- /dev/null +++ b/base/serial/aux/clsrx.f90 @@ -0,0 +1,414 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 clsrx(n,x,indx,dir,flag) + use psb_serial_mod + use clcmp_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(psb_spk_) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(psb_spk_) :: piv, xk, xt + integer i, j, 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 + call psb_errpush(4001,r_name='clsrx',a_err='wrong flag') + call psb_error() + 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 + ! + ! 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 + call psb_errpush(4001,r_name='clsrx',a_err='impossible pivot condition') + call psb_error() + 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 iclsrx_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 iclsrx_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 iclsrx_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 iclsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call iclsrx_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 + ! + ! 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 + call psb_errpush(4001,r_name='clsrx',a_err='impossible pivot condition') + call psb_error() + 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 iclsrx_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 iclsrx_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 iclsrx_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 iclsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call iclsrx_dw(n,x,indx) + endif + + case default + call psb_errpush(4001,r_name='clsrx',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine iclsrx_up(n,x,indx) + use clcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 iclsrx_up + + subroutine iclsrx_dw(n,x,indx) + use clcmp_mod + implicit none + integer :: n + complex(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(psb_spk_) :: 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 iclsrx_dw + +end subroutine clsrx diff --git a/base/serial/aux/sasr.f90 b/base/serial/aux/sasr.f90 new file mode 100644 index 000000000..53b89aff0 --- /dev/null +++ b/base/serial/aux/sasr.f90 @@ -0,0 +1,361 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 sasr(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(psb_spk_) :: x(n) + ! .. + ! .. Local Scalars .. + real(psb_spk_) :: 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 + ! + ! 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 + call psb_errpush(4001,r_name='sasr',a_err='impossible pivot condition') + call psb_error() + 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 sisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call sisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call sisr_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 + ! + ! 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 + call psb_errpush(4001,r_name='sasr',a_err='impossible pivot condition') + call psb_error() + 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 sisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call sisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call sisr_dw(n,x) + endif + + case default + call psb_errpush(4001,r_name='sasr',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine sisr_up(n,x) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: i,j + real(psb_spk_) :: 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 sisr_up + + subroutine sisr_dw(n,x) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: i,j + real(psb_spk_) :: 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 sisr_dw + +end subroutine sasr diff --git a/base/serial/aux/sasrx.f90 b/base/serial/aux/sasrx.f90 new file mode 100644 index 000000000..40826bfed --- /dev/null +++ b/base/serial/aux/sasrx.f90 @@ -0,0 +1,410 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 sasrx(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(psb_spk_) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + real(psb_spk_) :: piv, xt, xk + integer i, j, 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 + call psb_errpush(4001,r_name='sasrx',a_err='wrong flag') + call psb_error() + 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 + ! + ! 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 + call psb_errpush(4001,r_name='sasrx',a_err='impossible pivot condition') + call psb_error() + 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 isasrx_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 isasrx_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 isasrx_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 isasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call isasrx_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 + ! + ! 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 + call psb_errpush(4001,r_name='sasrx',a_err='impossible pivot condition') + call psb_error() + 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 isasrx_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 isasrx_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 isasrx_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 isasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call isasrx_dw(n,x,indx) + endif + + case default + call psb_errpush(4001,r_name='sasrx',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine isasrx_up(n,x,indx) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(psb_spk_) :: 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 isasrx_up + + subroutine isasrx_dw(n,x,indx) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(psb_spk_) :: 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 isasrx_dw + +end subroutine sasrx diff --git a/base/serial/aux/smsort_dw.f90 b/base/serial/aux/smsort_dw.f90 new file mode 100644 index 000000000..8968c2a70 --- /dev/null +++ b/base/serial/aux/smsort_dw.f90 @@ -0,0 +1,173 @@ +! +! Parallel Sparse BLAS version 2.2 +! (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: msort_dw.f90 +! +! Subroutine: msort_dw +! This subroutine sorts an integer array into ascending order. +! +! Arguments: +! n - integer Input: size of the array +! k - real(*) input: array of keys to be sorted +! l - integer(0:n+1) output: link list +! iret - integer output: 0 Normal termination +! 1 the array was already sorted +! * +! REFERENCES = (1) D. E. Knuth * +! The Art of Computer Programming, * +! vol.3: Sorting and Searching * +! Addison-Wesley, 1973 * +! * +! call msort_dw(n,x,iaux,iret) +! +! if (iret == 0) then +! lp = iaux(0) +! k = 1 +! do +! if ((lp==0).or.(k>n)) exit +! do +! if (lp >= k) exit +! lp = iaux(lp) +! end do +! iswap = x(lp) +! x(lp) = x(k) +! x(k) = iswap +! lswap = iaux(lp) +! iaux(lp) = iaux(k) +! iaux(k) = lp +! lp = lswap +! k = k + 1 +! enddo +! end if +! +! +subroutine smsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer n, iret + real(psb_spk_) :: k(n) + integer l(0:n+1) + ! + integer p,q,s,t + intrinsic iabs,isign + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = iabs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = isign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = isign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = isign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine smsort_dw diff --git a/base/serial/aux/smsort_up.f90 b/base/serial/aux/smsort_up.f90 new file mode 100644 index 000000000..11676dcf9 --- /dev/null +++ b/base/serial/aux/smsort_up.f90 @@ -0,0 +1,173 @@ +! +! Parallel Sparse BLAS version 2.2 +! (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: msort_up.f90 +! +! Subroutine: msort_up +! This subroutine sorts an integer array into ascending order. +! +! Arguments: +! n - integer Input: size of the array +! k - integer(*) input: array of keys to be sorted +! l - integer(0:n+1) output: link list +! iret - integer output: 0 Normal termination +! 1 the array was already sorted +! * +! REFERENCES = (1) D. E. Knuth * +! The Art of Computer Programming, * +! vol.3: Sorting and Searching * +! Addison-Wesley, 1973 * +! * +! call msort_up(n,x,iaux,iret) +! +! if (iret == 0) then +! lp = iaux(0) +! k = 1 +! do +! if ((lp==0).or.(k>n)) exit +! do +! if (lp >= k) exit +! lp = iaux(lp) +! end do +! iswap = x(lp) +! x(lp) = x(k) +! x(k) = iswap +! lswap = iaux(lp) +! iaux(lp) = iaux(k) +! iaux(k) = lp +! lp = lswap +! k = k + 1 +! enddo +! end if +! +! +subroutine smsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer n, iret + real(psb_spk_) k(n) + integer l(0:n+1) + ! + integer p,q,s,t + intrinsic iabs,isign + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = iabs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = isign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = isign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = isign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine smsort_up diff --git a/base/serial/aux/smsr.f90 b/base/serial/aux/smsr.f90 new file mode 100644 index 000000000..b7464a0d6 --- /dev/null +++ b/base/serial/aux/smsr.f90 @@ -0,0 +1,92 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: imsr.f90 + ! Subroutine: + ! Parameters: +subroutine smsr(n,x,idir) + use psb_serial_mod + implicit none + + integer :: n, idir + real(psb_spk_) :: x(n) + + + integer, allocatable :: iaux(:) + + integer :: lswap, iret, info, lp, k + real(psb_spk_) :: swap + + if (n<0) then + return + endif + + if (n<=1) return + + allocate(iaux(0:n+1),stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='smsr') + call psb_error() + endif + + if (idir==psb_sort_up_) then + call smsort_up(n,x,iaux,iret) + else + call smsort_dw(n,x,iaux,iret) + end if + + if (iret == 0) then + lp = iaux(0) + k = 1 + do + if ((lp==0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + end if + + deallocate(iaux,stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='smsr') + call psb_error() + endif + return +end subroutine smsr diff --git a/base/serial/aux/smsrx.f90 b/base/serial/aux/smsrx.f90 new file mode 100644 index 000000000..500012982 --- /dev/null +++ b/base/serial/aux/smsrx.f90 @@ -0,0 +1,102 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: imsrx.f90 + ! Subroutine: + ! Parameters: +subroutine smsrx(n,x,indx,idir,flag) + use psb_serial_mod + implicit none + integer :: n,idir,flag + real(psb_spk_) :: x(n) + integer :: indx(n) + + integer, allocatable :: iaux(:) + + integer :: iret, info, lp, k,lswap, ixswap + real(psb_spk_) :: swap + + if (n<0) then + return + endif + + if (n==0) return + + if (flag == psb_sort_ovw_idx_) then + do k=1,n + indx(k) = k + enddo + end if + + if (n==1) return + + allocate(iaux(0:n+1),stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='smsrx') + call psb_error() + endif + + if (idir == psb_sort_up_) then + call smsort_up(n,x,iaux,iret) + else + call smsort_dw(n,x,iaux,iret) + end if + + if (iret /= 1) then + lp = iaux(0) + k = 1 + do + if ((lp==0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + end if + + deallocate(iaux,stat=info) + if (info/=0) then + call psb_errpush(4000,r_name='smsrx') + call psb_error() + endif + return +end subroutine smsrx diff --git a/base/serial/aux/ssr.f90 b/base/serial/aux/ssr.f90 new file mode 100644 index 000000000..70ffc81ce --- /dev/null +++ b/base/serial/aux/ssr.f90 @@ -0,0 +1,359 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 ssr(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(psb_spk_) :: x(n) + ! .. + ! .. Local Scalars .. + real(psb_spk_) :: 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 + ! + ! 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 + call psb_errpush(4001,r_name='ssr',a_err='impossible pivot condition') + call psb_error() + 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 sisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call sisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call sisr_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 + ! + ! 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 + call psb_errpush(4001,r_name='ssr',a_err='impossible pivot condition') + call psb_error() + 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 sisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call sisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call sisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call sisr_dw(n,x) + endif + + case default + call psb_errpush(4001,r_name='ssr',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine sisr_up(n,x) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: i,j + real(psb_spk_) :: 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 sisr_up + + subroutine sisr_dw(n,x) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: i,j + real(psb_spk_) :: 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 sisr_dw + +end subroutine ssr diff --git a/base/serial/aux/ssrx.f90 b/base/serial/aux/ssrx.f90 new file mode 100644 index 000000000..1373e2157 --- /dev/null +++ b/base/serial/aux/ssrx.f90 @@ -0,0 +1,410 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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 ssrx(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(psb_spk_) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + real(psb_spk_) :: piv, xk, xt + integer i, j, 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 + call psb_errpush(4001,r_name='ssrx',a_err='wrong flag') + call psb_error() + 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 + ! + ! 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 + call psb_errpush(4001,r_name='ssrx',a_err='impossible pivot condition') + call psb_error() + 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 issrx_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 issrx_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 issrx_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 issrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call issrx_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 + ! + ! 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 + call psb_errpush(4001,r_name='ssrx',a_err='impossible pivot condition') + call psb_error() + 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 issrx_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 issrx_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 issrx_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 issrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call issrx_dw(n,x,indx) + endif + + case default + call psb_errpush(4001,r_name='ssrx',a_err='wrong dir') + call psb_error() + end select + + + return + +contains + + subroutine issrx_up(n,x,indx) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(psb_spk_) :: 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 issrx_up + + subroutine issrx_dw(n,x,indx) + implicit none + integer :: n + real(psb_spk_) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(psb_spk_) :: 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 issrx_dw + +end subroutine ssrx diff --git a/base/serial/coo/Makefile b/base/serial/coo/Makefile index 7b29f679d..84bdcb232 100644 --- a/base/serial/coo/Makefile +++ b/base/serial/coo/Makefile @@ -3,7 +3,9 @@ include ../../../Make.inc # # The object files # -FOBJS = dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\ +FOBJS = scoonrmi.o scoomm.o scoomv.o scoosm.o scoosv.o scoorws.o\ + dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\ + ccoonrmi.o ccoomm.o ccoomv.o ccoosm.o ccoosv.o ccoorws.o\ zcoomm.o zcoomv.o zcoonrmi.o zcoorws.o zcoosm.o zcoosv.o diff --git a/base/serial/coo/ccoomm.f b/base/serial/coo/ccoomm.f new file mode 100644 index 000000000..f66b62d98 --- /dev/null +++ b/base/serial/coo/ccoomm.f @@ -0,0 +1,96 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +c +c What if a wrong DESCRA is passed? +c +c +* +* + SUBROUTINE CCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, + * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK) + use psb_const_mod +C +C +C .. Scalar Arguments .. + complex(psb_spk_) ALPHA, BETA + INTEGER K, LDB, LDC, M, N, LWORK + CHARACTER TRANSA +C .. Array Arguments .. + complex(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) + INTEGER IA(*), JA(*),INFOA(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER I, J + CHARACTER DIAG, TRANS + + +C .. External Subroutines .. + EXTERNAL ZCOOMV +C .. Executable Statements .. +C +C +C + IF (DESCRA(1:1).EQ.'G') TRANS = TRANSA + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' +c +c Does DSRMV manage this case too? = 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE CCOOMV (TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, + + BETA,Y,WORK) + use psb_const_mod +C .. Parameters .. + complex(psb_spk_) ONE, ZERO + PARAMETER (ONE=sone,ZERO=szero) +C .. Scalar Arguments .. + complex(psb_spk_) ALPHA, BETA + INTEGER M, N + CHARACTER DIAG, TRANS +C .. Array Arguments .. + complex(psb_spk_) AS(*), WORK(*), X(*), Y(*) + INTEGER IA(*), JA(*),infoa(*) +C .. Local Scalars .. + complex(psb_spk_) ACC, TX + INTEGER I, J, K, NCOLA, NROWA,DUM, NNZ, IR, JC + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + UNI = (DIAG.EQ.'U') + TRA = (TRANS.EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) +C + IF ( .NOT. TRA) THEN + NROWA = M + NCOLA = N + ELSE IF (TRA) THEN + NROWA = N + NCOLA = M + END IF !(....TRA) + + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO I = 1, M + Y(I) = ZERO + ENDDO + ELSE + DO 20 I = 1, M + Y(I) = BETA*Y(I) + 20 CONTINUE + ENDIF + RETURN + END IF + + NNZ = INFOA(1) +C + IF (SYM) THEN + IF (UNI) THEN +C +C ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + IF (BETA.NE.ZERO) THEN + DO I = 1, M +C +C Product for diagonal elements +C + Y(I) = BETA*Y(I) + ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C Product for other elements + + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + ACC = ZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO +C + ELSE IF ( .NOT. UNI) THEN +C +C Check if matrix is lower or upper +C + IF (TRANS.EQ.'L') THEN +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + IF (IR.NE.JC) THEN + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDIF + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + + ELSE ! ....Trans<>L +C +C UPPER CASE +C ....OK!! (Actually it's just the same as above!) +C + + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + IF (IR.NE.JC) THEN + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDIF + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + END IF ! ......TRANS=='L' + + END IF ! ......Not UNI +C + ELSE IF ( .NOT. TRA) THEN !......NOT SYM + + IF ( .NOT. UNI) THEN +C +C .......General Not Unit, No Traspose +C + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I)+ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + END IF !....End Testing on UNI +C + ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) +C + IF ( .NOT. UNI) THEN +C + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.ZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I)+ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF +C + END IF !....UNI +C + IF (ALPHA.EQ.ONE) THEN +C + I = 1 + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) + AS(I)*X(JC) + ENDDO +C + ELSE IF (ALPHA.EQ.-ONE) THEN +C + I = 1 + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) - AS(I)*X(JC) + ENDDO +C + ELSE !.....Else on TRA + I = 1 + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) + ALPHA*AS(I)*X(JC) + ENDDO + +c$$$C +c$$$C This work array is used for efficiency +c$$$C +c$$$ DO 420 I = 1, N +c$$$ WORK(I) = ALPHA*X(I) +c$$$ 420 CONTINUE +c$$$C +c$$$ DO 460 I = 1, n +c$$$ DO 440 J = IA(I), IA(I+1) - 1 +c$$$ K = JA(J) +c$$$ Y(K) = Y(K) + AS(J)*WORK(I) +c$$$ 440 CONTINUE +c$$$ 460 CONTINUE +c$$$C + END IF !.....End testing on ALPHA + + END IF !.....End testing on SYM +C + RETURN +C +C END OF DSRMV +C + END + diff --git a/base/serial/coo/ccoonrmi.f b/base/serial/coo/ccoonrmi.f new file mode 100644 index 000000000..53291cc5d --- /dev/null +++ b/base/serial/coo/ccoonrmi.f @@ -0,0 +1,70 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C ... Compute Infinity norm for sparse matrix in CSR Format ... + FUNCTION CCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) ccoonrmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + complex(psb_spk_) A(*) +C .. Local scalars .. + INTEGER I, J, K, NNZ + real(psb_spk_) NRMI, SUM + + NRMI = 0.0 + NNZ = INFOA(1) + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA1(J).EQ.IA1(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + SUM = 0.0 + DO K = I, J-1 + SUM = SUM + ABS(DBLE(A(K))) + ABS(AIMAG(A(K))) + ENDDO + IF (SUM.GT.NRMI) THEN + NRMI = SUM + ENDIF + I = J + ENDDO + + CCOONRMI = NRMI + END diff --git a/base/serial/coo/ccoorws.f b/base/serial/coo/ccoorws.f new file mode 100644 index 000000000..a283d757b --- /dev/null +++ b/base/serial/coo/ccoorws.f @@ -0,0 +1,85 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C + SUBROUTINE CCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, + & INFOA,ROWSUM,IERROR) + use psb_const_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + complex(psb_spk_) A(*), ROWSUM(*) +C .. Local scalars .. + INTEGER I, J, NNZ, K + real(psb_spk_) SUM + logical psb_lsame + external psb_lsame + + NNZ = INFOA(1) + IF (psb_lsame(TRANS,'N')) THEN + DO I=1, M + ROWSUM(I) = 0.0D0 + ENDDO + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA1(J).EQ.IA1(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + SUM = 0.0 + DO K = I, J-1 + SUM = SUM + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) + ENDDO + ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM + I = J + ENDDO + + ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN + DO J = 1, N + ROWSUM(J) = 0.0D0 + ENDDO + DO I = 1, NNZ + ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + + + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) + ENDDO + ELSE + ierror = -1 + ENDIF + RETURN + END + + + diff --git a/base/serial/coo/ccoosm.f b/base/serial/coo/ccoosm.f new file mode 100644 index 000000000..d82527a18 --- /dev/null +++ b/base/serial/coo/ccoosm.f @@ -0,0 +1,115 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, + * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_error_mod + IMPLICIT NONE + complex(psb_spk_) ALPHA, BETA + INTEGER LDB, LDC, LWORK, M, N, IERROR + CHARACTER UNITD, TRANST + complex(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) + CHARACTER DESCRA*11 + INTEGER I, K, ERR_ACT + CHARACTER DIAG, UPLO + INTRINSIC DBLE, IDINT + CHARACTER*20 NAME + integer :: debug_level, debug_unit + + NAME = 'CCOOSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),':' ,m,ierror + + UPLO = '?' + IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' + IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' + IF (UPLO.EQ.'?') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (DESCRA(3:3).EQ.'N') DIAG = 'N' + IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + IF(UNITD.EQ.'B') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + IF (UNITD.EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE + END IF + + DO 60 I = 1, N + CALL CCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, + + B(1,I),C(1,I),IERROR) + 60 CONTINUE + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (UNITD.EQ.'L') THEN + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE + END IF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/coo/ccoosv.f b/base/serial/coo/ccoosv.f new file mode 100644 index 000000000..7bd6bf260 --- /dev/null +++ b/base/serial/coo/ccoosv.f @@ -0,0 +1,225 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C Assumption: the triangular matrix has the diagonal element in the +C "right" place, i.e. the last in its row for Lower and the first +C for Upper. +C + SUBROUTINE CCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) + use psb_const_mod + use psb_error_mod + complex(psb_spk_) ZERO + PARAMETER (ZERO=(0.0,0.0)) + INTEGER N,IERROR + CHARACTER DIAG, TRANS, UPLO + complex(psb_spk_) AS(*), B(*), X(*) + INTEGER IA(*), JA(*),INFOA(*) + complex(psb_spk_) ACC + INTEGER I, J, K, NNZ, II, JJ + LOGICAL LOW, TRA, UNI + integer :: debug_level, debug_unit + character(len=20) :: name='ccoosv' + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + UNI = (DIAG.EQ.'U') + TRA = (TRANS.EQ.'T') + LOW = (UPLO.EQ.'L') + NNZ = INFOA(1) + IERROR = 0 + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo + IF ( .NOT. TRA) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT TRA' + IF (LOW) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': LOW' + IF ( .NOT. UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT UNI' + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J-2 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + X(IR) = (B(IR)-ACC)/AS(J-1) + I = J + ENDDO + + ELSE IF (UNI) THEN +C +C Bug warning: if UNI, some rows might be empty +C + I = 1 + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': UNILOW ', + + i,n,nnz,uni,tra,low + DO II = 1, N + DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) + I = I + 1 + ENDDO + ACC = ZERO + IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN + J = I + 1 + DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) + J = J+1 + ENDDO + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + ELSE + J = I + ENDIF + X(II) = (B(II)-ACC) + I = J + ENDDO + + END IF + + ELSE IF ( .NOT. LOW) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT LOW' + IF ( .NOT. UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT UNI' + I = NNZ + J = NNZ + DO WHILE (I.GT.0) + DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) + J = J-1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J+2,-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + X(IR) = (B(IR)-ACC)/AS(J+1) + I = J + ENDDO + + ELSE IF (UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': UNI' + I = NNZ + DO II = N,1,-1 + DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) + I = I -1 + ENDDO + ACC = ZERO + IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN + J = I - 1 + DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) + J = J-1 + ENDDO + DO K = I, J+1, -1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + ELSE + J = I + ENDIF + X(II) = (B(II)-ACC) + I = J + ENDDO + + END IF + + END IF + + ELSE IF (TRA) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': TRA' + IERROR = 3010 + return +CCCCCCCCCCCCCCCC +C +C TBF +C +CCCCCCCCCCCCCCCC + DO 180 I = 1, N + X(I) = B(I) + 180 CONTINUE + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 220 I = N, 1, -1 + X(I) = X(I)/AS(IA(I+1)-1) + ACC = X(I) + DO 200 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 200 CONTINUE + 220 CONTINUE + ELSE IF (UNI) THEN + DO 260 I = N, 1, -1 + ACC = X(I) + DO 240 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 240 CONTINUE + 260 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 300 I = 1, N + X(I) = X(I)/AS(IA(I)) + ACC = X(I) + DO 280 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 280 CONTINUE + 300 CONTINUE + ELSE IF (UNI) THEN + DO 340 I = 1, N + ACC = X(I) + DO 320 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 320 CONTINUE + 340 CONTINUE + END IF + END IF + END IF + RETURN + END + + + diff --git a/base/serial/coo/dcoosm.f b/base/serial/coo/dcoosm.f index fe1cc3757..96dbc6a18 100644 --- a/base/serial/coo/dcoosm.f +++ b/base/serial/coo/dcoosm.f @@ -46,7 +46,7 @@ C CHARACTER*20 NAME integer :: debug_level, debug_unit - NAME = 'ZCOOSM\0' + NAME = 'DCOOSM\0' IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) debug_unit = psb_get_debug_unit() diff --git a/base/serial/coo/scoomm.f b/base/serial/coo/scoomm.f new file mode 100644 index 000000000..0251011d4 --- /dev/null +++ b/base/serial/coo/scoomm.f @@ -0,0 +1,98 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +c +c What if a wrong DESCRA is passed? +c +c +* +* + SUBROUTINE SCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, + * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod +C +C +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER K, LDB, LDC, M, N, LWORK, IERROR + CHARACTER TRANSA +C .. Array Arguments .. + real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) + INTEGER IA(*), JA(*),INFOA(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER I, J + CHARACTER DIAG, TRANS + + +C .. External Subroutines .. + EXTERNAL SCOOMV +C .. Executable Statements .. +C +C +C + IERROR=0 + IF (DESCRA(1:1).EQ.'G') TRANS = TRANSA + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' +c +c Does DSRMV manage this case too? = 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE SCOOMV(TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, + + BETA,Y,WORK,IERROR) + use psb_const_mod +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER M, N, IERROR + CHARACTER DIAG, TRANS +C .. Array Arguments .. + real(psb_spk_) AS(*), WORK(*), X(*), Y(*) + INTEGER IA(*), JA(*),infoa(*) +C .. Local Scalars .. + real(psb_spk_) ACC, TX + INTEGER I, J, K, NNZ, IR, JC + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + IERROR=0 + UNI = (DIAG.EQ.'U') + TRA = (TRANS.EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) +C + + IF (ALPHA.EQ.SZERO) THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, M + Y(I) = SZERO + ENDDO + ELSE + DO 20 I = 1, M + Y(I) = BETA*Y(I) + 20 CONTINUE + ENDIF + RETURN + END IF + + NNZ = INFOA(1) +C + IF (SYM) THEN + IF (UNI) THEN +C +C ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + IF (BETA.NE.SZERO) THEN + DO I = 1, M +C +C Product for diagonal elements +C + Y(I) = BETA*Y(I) + ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C Product for other elements + + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + ACC = SZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO +C + ELSE IF ( .NOT. UNI) THEN +C +C Check if matrix is lower or upper +C + IF (TRANS.EQ.'L') THEN +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = SZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + IF (IR.NE.JC) THEN + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDIF + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + + ELSE ! ....Trans<>L +C +C UPPER CASE +C ....OK!! (Actually it's just the same as above!) +C + + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = SZERO + IR = IA(I) + TX = X(IR) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + IF (IR.NE.JC) THEN + Y(JC) = Y(JC) + ALPHA * AS(K)*TX + ENDIF + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + END IF ! ......TRANS=='L' + + END IF ! ......Not UNI +C + ELSE IF ( .NOT. TRA) THEN !......NOT SYM + + IF ( .NOT. UNI) THEN +C +C .......General Not Unit, No Traspose +C + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF + + I = 1 + J = I + IF (nnz > 0) then + IR = IA(1) + ACC = szero + DO + if (i>nnz) then + Y(IR) = Y(IR) + ALPHA * ACC + exit + endif + IF (IA(I) /= IR) THEN + Y(IR) = Y(IR) + ALPHA * ACC + IR = IA(I) + ACC = SZERO + ENDIF + ACC = ACC + AS(I) * X(JA(I)) + I = I + 1 + ENDDO + endif +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I)+ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA(J).EQ.IA(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + ACC = SZERO + IR = IA(I) + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + Y(IR) = Y(IR) + ALPHA * ACC + I = J + ENDDO + + END IF !....End Testing on UNI +C + ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) +C + IF ( .NOT. UNI) THEN +C + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.SZERO) THEN + DO I = 1, M + Y(I) = BETA*Y(I)+ALPHA*X(I) + ENDDO + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF +C + END IF !....UNI +C + IF (ALPHA.EQ.SONE) THEN +C + I = 1 + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) + AS(I)*X(JC) + ENDDO +C + ELSE IF (ALPHA.EQ.-SONE) THEN +C + + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) - AS(I)*X(JC) + ENDDO +C + ELSE !.....Else on TRA + + DO I=1,M + WORK(I) = ALPHA*X(I) + ENDDO + + DO I=1,NNZ + IR = JA(I) + JC = IA(I) + Y(IR) = Y(IR) + AS(I)*WORK(JC) + ENDDO + + END IF !.....End testing on ALPHA + + END IF !.....End testing on SYM +C + RETURN +C +C END OF DSRMV +C + END + diff --git a/base/serial/coo/scoonrmi.f b/base/serial/coo/scoonrmi.f new file mode 100644 index 000000000..8a22f32a8 --- /dev/null +++ b/base/serial/coo/scoonrmi.f @@ -0,0 +1,73 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute Infinity norm for sparse matrix in CSR Format ... + FUNCTION SCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) scoonrmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + real(psb_spk_) A(*) +C .. Local scalars .. + INTEGER I, J, K, NNZ + real(psb_spk_) NRMI, SUM + + IERROR=0 + NRMI = 0.0 + NNZ = INFOA(1) + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA1(J).EQ.IA1(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + SUM = 0.0 + DO K = I, J-1 + SUM = SUM + ABS(A(K)) + ENDDO + IF (SUM.GT.NRMI) THEN + NRMI = SUM + ENDIF + I = J + ENDDO + + SCOONRMI = NRMI + RETURN + END diff --git a/base/serial/coo/scoorws.f b/base/serial/coo/scoorws.f new file mode 100644 index 000000000..798939c3b --- /dev/null +++ b/base/serial/coo/scoorws.f @@ -0,0 +1,85 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, + & INFOA,ROWSUM,IERROR) + use psb_const_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + real(psb_spk_) A(*), ROWSUM(*) +C .. Local scalars .. + INTEGER I, J, NNZ, K + real(psb_spk_) SUM + logical psb_lsame + external psb_lsame + + NNZ = INFOA(1) + IF (psb_lsame(TRANS,'N')) THEN + DO I=1, M + ROWSUM(I) = 0.0D0 + ENDDO + I = 1 + J = I + DO WHILE (I.LE.NNZ) + + DO WHILE ((IA1(J).EQ.IA1(I)).AND. + + (J.LE.NNZ)) + J = J+1 + ENDDO + + SUM = 0.0 + DO K = I, J-1 + SUM = SUM + ABS(A(K)) + ENDDO + ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM + I = J + ENDDO + + ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN + DO J = 1, N + ROWSUM(J) = 0.0D0 + ENDDO + DO I = 1, NNZ + ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + ABS(A(I)) + ENDDO + ELSE + ierror = -1 + ENDIF + RETURN + END + + + diff --git a/base/serial/coo/scoosm.f b/base/serial/coo/scoosm.f new file mode 100644 index 000000000..9d1a40aec --- /dev/null +++ b/base/serial/coo/scoosm.f @@ -0,0 +1,115 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, + * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_error_mod + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) ALPHA, BETA + INTEGER LDB, LDC, LWORK, M, N, IERROR + CHARACTER UNITD, TRANST + real(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) + CHARACTER DESCRA*11 + INTEGER I, K, ERR_ACT + CHARACTER DIAG, UPLO + INTRINSIC DBLE, IDINT + CHARACTER*20 NAME + integer :: debug_level, debug_unit + + NAME = 'SCOOSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),':' ,m,ierror + + UPLO = '?' + IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' + IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' + IF (UPLO.EQ.'?') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (DESCRA(3:3).EQ.'N') DIAG = 'N' + IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + IF(UNITD.EQ.'B') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + IF (UNITD.EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE + END IF + + DO 60 I = 1, N + CALL SCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, + + B(1,I),C(1,I),IERROR) + 60 CONTINUE + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (UNITD.EQ.'L') THEN + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE + END IF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/coo/scoosv.f b/base/serial/coo/scoosv.f new file mode 100644 index 000000000..764c39df6 --- /dev/null +++ b/base/serial/coo/scoosv.f @@ -0,0 +1,226 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C +C Assumption: the triangular matrix has the diagonal element in the +C "right" place, i.e. the last in its row for Lower and the first +C for Upper. +C + SUBROUTINE SCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) + use psb_const_mod + use psb_error_mod + real(psb_spk_) ZERO + PARAMETER (ZERO=0.0e0) + INTEGER N,IERROR + CHARACTER DIAG, TRANS, UPLO + real(psb_spk_) AS(*), B(*), X(*) + INTEGER IA(*), JA(*),INFOA(*) + real(psb_spk_) ACC + INTEGER I, J, K, NNZ, II + LOGICAL LOW, TRA, UNI + integer :: debug_level, debug_unit + character(len=20) :: name='dcoosv' + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + UNI = (DIAG.EQ.'U') + TRA = (TRANS.EQ.'T') + LOW = (UPLO.EQ.'L') + NNZ = INFOA(1) + IERROR = 0 + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo + IF ( .NOT. TRA) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT TRA' + IF (LOW) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': LOW' + IF ( .NOT. UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT UNI' + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) + J = J+1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J-2 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + X(IR) = (B(IR)-ACC)/AS(J-1) + I = J + ENDDO + + ELSE IF (UNI) THEN +C +C Bug warning: if UNI, some rows might be empty +C + I = 1 + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': UNILOW ', + + i,n,nnz,uni,tra,low + DO II = 1, N + DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) + I = I + 1 + ENDDO + ACC = ZERO + IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN + J = I + 1 + DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) + J = J+1 + ENDDO + DO K = I, J-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + ELSE + J = I + ENDIF + X(II) = (B(II)-ACC) + I = J + ENDDO + + END IF + + ELSE IF ( .NOT. LOW) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT LOW' + IF ( .NOT. UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NOT UNI' + I = NNZ + J = NNZ + DO WHILE (I.GT.0) + DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) + J = J-1 + ENDDO + ACC = ZERO + IR = IA(I) + DO K = I, J+2,-1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + X(IR) = (B(IR)-ACC)/AS(J+1) + I = J + ENDDO + + ELSE IF (UNI) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': UNI' + I = NNZ + DO II = N,1,-1 + DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) + I = I -1 + ENDDO + ACC = ZERO + IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN + J = I - 1 + DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) + J = J-1 + ENDDO + DO K = I, J+1, -1 + JC = JA(K) + ACC = ACC + AS(K)*X(JC) + ENDDO + ELSE + J = I + ENDIF + X(II) = (B(II)-ACC) + I = J + ENDDO + + END IF + + END IF + + ELSE IF (TRA) THEN + if (debug_level>=psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': TRA' + IERROR = 3010 + return +CCCCCCCCCCCCCCCC +C +C TBF +C +CCCCCCCCCCCCCCCC + DO 180 I = 1, N + X(I) = B(I) + 180 CONTINUE + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 220 I = N, 1, -1 + X(I) = X(I)/AS(IA(I+1)-1) + ACC = X(I) + DO 200 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 200 CONTINUE + 220 CONTINUE + ELSE IF (UNI) THEN + DO 260 I = N, 1, -1 + ACC = X(I) + DO 240 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 240 CONTINUE + 260 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 300 I = 1, N + X(I) = X(I)/AS(IA(I)) + ACC = X(I) + DO 280 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 280 CONTINUE + 300 CONTINUE + ELSE IF (UNI) THEN + DO 340 I = 1, N + ACC = X(I) + DO 320 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 320 CONTINUE + 340 CONTINUE + END IF + END IF + END IF + RETURN + END + + + diff --git a/base/serial/coo/zcoosm.f b/base/serial/coo/zcoosm.f index 650d80202..b35394bb1 100644 --- a/base/serial/coo/zcoosm.f +++ b/base/serial/coo/zcoosm.f @@ -46,7 +46,7 @@ C CHARACTER*20 NAME integer :: debug_level, debug_unit - NAME = 'DCOOSM\0' + NAME = 'ZCOOSM\0' IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) debug_unit = psb_get_debug_unit() diff --git a/base/serial/csr/Makefile b/base/serial/csr/Makefile index 2a96a6c51..6349bd3f5 100644 --- a/base/serial/csr/Makefile +++ b/base/serial/csr/Makefile @@ -6,6 +6,9 @@ include ../../../Make.inc FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \ dcsrmv4.o dcsrmv2.o dcsrmv3.o dcsrrws.o\ + scsrmm.o scsrmv.o scsrmv2.o scsrmv3.o scsrmv4.o scsrsm.o scsrsv.o\ + scrnrmi.o \ + ccrnrmi.o ccsrmm.o ccsrrws.o ccsrsm.o csrmv.o csrsv.o ccsrck.o\ zcrnrmi.o zcsrmm.o zcsrrws.o zcsrsm.o zsrmv.o zsrsv.o zcsrck.o OBJS=$(FOBJS) diff --git a/base/serial/csr/ccrnrmi.f b/base/serial/csr/ccrnrmi.f new file mode 100644 index 000000000..0493af2c8 --- /dev/null +++ b/base/serial/csr/ccrnrmi.f @@ -0,0 +1,64 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C + FUNCTION CCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + & INFOA,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) ccrnrmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + complex(psb_spk_) A(*) +C .. Local scalars .. + INTEGER I, J + real(psb_spk_) NRMI, SUM + + NRMI = 0.D0 + DO I = 1, M + SUM = 0.D0 + DO J = IA2(I), IA2(I+1)-1 +C +C .. definition coerent abs +C +C SUM = SUM + ABS(A(J)) +C +C .. essl_way abs +C + SUM = SUM + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) + ENDDO + NRMI = MAX(NRMI, SUM) + ENDDO + + CCRNRMI = NRMI + END diff --git a/base/serial/csr/ccsrck.f b/base/serial/csr/ccsrck.f new file mode 100644 index 000000000..116cf1119 --- /dev/null +++ b/base/serial/csr/ccsrck.f @@ -0,0 +1,165 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C +C Purpose +C ======= +C +C Performing checks on sparse matrix. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine will use +C matrix P or the transpose of P for the permutation as follows: +C TRANS = 'N' -> permute with matrix P +C TRANS = 'T' or 'C' -> permute the transpose of P +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A. +C Unchanged on exit. +C +C DESCRA - CHARACTER*5 array of DIMENSION (10) +C On entry DESCRA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSPRP memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit specify the error code. +C IERROR = 0 no errors +C IERROR > 0 error in integrity check + SUBROUTINE CCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, + + WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER LWORK,M, N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + complex(psb_spk_) A(*), WORK(*) + INTEGER IA1(*), IA2(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER I, J, nrow, nind +C +C .. Executable Statements .. +C + +C +C Check #1: Character descriptor have valid values +C + IERROR = 0 + + IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. + + (psb_toupper(DESCRA(1:1)).NE.'S').AND. + + (psb_toupper(DESCRA(1:1)).NE.'H').AND. + + (psb_toupper(DESCRA(1:1)).NE.'T').AND. + + (psb_toupper(DESCRA(1:1)).NE.'A').AND. + + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN + IERROR = 11 + GOTO 9999 + END IF + IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. + + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN + IERROR = 12 + GOTO 9999 + END IF + IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. + + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN + IERROR = 13 + GOTO 9999 + END IF +C +C Check #2: Pointers have non decreasing order +C + IF (IA2(1).LE.0) THEN + IERROR = 14 + GOTO 9999 + ENDIF + + NROW = 0 + DO 10 I = 1, M + IF (IA2(I) .GT. IA2(I+1)) THEN + NROW = NROW + 1 + END IF + 10 CONTINUE + IF (NROW .GT. 0) THEN + IERROR = 15 + GOTO 9999 + END IF +C +C Check #3: Indices are within problem dimension +C + NIND = 0 + DO 20 I = 1, M + DO 30 J = IA2(I), IA2(I+1) - 1 + IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN + NIND = NIND + 1 + END IF + 30 CONTINUE + 20 CONTINUE + IF (NIND .GT. 0) THEN + IERROR = 16 + GOTO 9999 + END IF + 9999 CONTINUE + RETURN + END diff --git a/base/serial/csr/ccsrmm.f b/base/serial/csr/ccsrmm.f new file mode 100644 index 000000000..51859831c --- /dev/null +++ b/base/serial/csr/ccsrmm.f @@ -0,0 +1,237 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE CCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, +C * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) +C +C Purpose +C ======= +C +C Computing C <-- ALPHA A B + BETA C or +C C <-- ALPHA At B + BETA C or +C C <-- ALPHA Atc B + BETA C +C Called by ZSWMM +C This routine calls kernel for CSR data structure. +C +C Parameters +C ========== +C +C TRANSA - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' -> use A' (transpose of matrix A) +C TRANS = 'C' -> use conjugate transpose of A +C Unchanged on exit. +C +C N.B.: M, K for C matrix +C M, N for A matrix +C N, K for B matrix +C In the calling subroutine, ZSWMM, it was: +C M, N for C matrix +C M, K for A matrix +C K, N for B matrix +C Check the parameters order! +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C K - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A (A') and +C number of rows of matrix B +C Unchanged on exit. +C +C ALPHA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C AR - COMPLEX*16 array of DIMENSION (*) +C On entry AR specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C JA - INTEGER array of dimension (*) +C On entry JA holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA - INTEGER array of dimension (*) +C On entry IA holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C B - COMPLEX*16 matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B +C Unchanged on exit. +C +C BETA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - COMPLEX*16 matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated with the matrix-matrix product. +C +C LDC - INTEGER +C On entry: leading dimension of C +C Unchanged on exit. +C +C WORK - COMPLEX*16 array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying ZSWMM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C + SUBROUTINE CCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, + * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + complex(psb_spk_) ALPHA, BETA + INTEGER K, LDB, LDC, M, N, LWORK + CHARACTER TRANSA +C .. Array Arguments .. + complex(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) + INTEGER IA(*), JA(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER I, J + CHARACTER DIAG, TRANS + +C .. External Subroutines .. + EXTERNAL CSRMV +C .. Executable Statements .. +C +C +C IF (DESCRA(1).EQ.'G') TRANS = TRANSA +C +C .. Why to loose TRANSA for H, T, A matrices? +C + TRANS = TRANSA +C + IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. + + (psb_toupper(DESCRA(2:2)).EQ.'U')) THEN + IF (psb_toupper(TRANSA).EQ.'C') THEN + TRANS = 'V' + ELSE + TRANS = 'U' + ENDIF + ENDIF + IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. + + (psb_toupper(DESCRA(2:2)).EQ.'L')) THEN + IF (psb_toupper(TRANSA).EQ.'C') THEN + TRANS = 'M' + ELSE + TRANS = 'L' + ENDIF + ENDIF + +C .. Diagonal matrix + IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN +C .. Diagonal matrix with unitary values + IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN + DO 40 I = 1, K + DO 20 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) + 20 CONTINUE + 40 CONTINUE + RETURN +C .. Diagonal matrix to be conjugated + ELSE IF (psb_toupper(TRANSA).EQ.'C') THEN + DO 80 I = 1, K + DO 60 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA * + + CONJG(AR(J)) * B(J,I) + 60 CONTINUE + 80 CONTINUE + RETURN +C .. Generic diagonal matrix + ELSE + DO 91 I = 1, K + DO 90 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA * + + AR(J) * B(J,I) + 90 CONTINUE + 91 CONTINUE + RETURN + ENDIF + END IF +C + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' +C +C C = A*B or C=A'*B or C=conjug(A')*B +C +C TRANS = +C 'N': Compute using A as it is. +C 'T': Compute using the transpose of A. +C 'C': Compute using conjugate transpose of A. +C 'U': A is symmetric, stored upper, compute as it is; +C (transposition makes no sense) +C 'V': A is symmetric, stored upper, to be conjugated. +C 'L': A is symmetric, stored lower, compute as it is. +C 'M': A is symmetric, stored lower, to be conjugated. +C DIAG = +C 'U': Unitary diagonal. +C 'N': Generic diagonal. + +C + DO 100 I = 1, K + CALL CSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,I), + + BETA,C(1,I),WORK) + 100 CONTINUE + RETURN + END + diff --git a/base/serial/csr/ccsrrws.f b/base/serial/csr/ccsrrws.f new file mode 100644 index 000000000..96433b735 --- /dev/null +++ b/base/serial/csr/ccsrrws.f @@ -0,0 +1,70 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C + SUBROUTINE CCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + & INFOA,ROWSUM,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + complex(psb_spk_) A(*), ROWSUM(*) +C .. Local scalars .. + INTEGER I, J + real(psb_spk_) SUM + + IF (psb_toupper(TRANS).EQ.'N') THEN + DO I = 1, M + ROWSUM(I) = (0.0D0, 0.0D0) + DO J = IA2(I), IA2(I + 1) - 1 + ROWSUM(I) = ROWSUM(I) + + + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) + ENDDO + ENDDO + ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. + + (psb_toupper(TRANS).EQ.'C')) THEN + DO J = 1, N + ROWSUM(J) = (0.0D0, 0.0D0) + ENDDO + DO I = 1, M + DO J = IA2(I), IA2(I + 1) - 1 + ROWSUM(IA1(J)) = ROWSUM(IA1(J)) + + + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) + ENDDO + ENDDO + ENDIF + END + + + diff --git a/base/serial/csr/ccsrsm.f b/base/serial/csr/ccsrsm.f new file mode 100644 index 000000000..ff6605f57 --- /dev/null +++ b/base/serial/csr/ccsrsm.f @@ -0,0 +1,118 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, + * B,LDB,BETA,C,LDC,WORK,LWORK) + use psb_const_mod + use psb_string_mod + complex(psb_spk_) ALPHA, BETA + INTEGER LDB, LDC, LWORK, M, N + CHARACTER UNITD, TRANST + complex(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IA(*), JA(*) + CHARACTER DESCRA*11 + INTEGER I, K + CHARACTER DIAG, UPLO + +C .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5),err_act + + NAME = 'CCSRSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + int_Val(1)=0 + UPLO = '?' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' + IF (UPLO.EQ.'?') THEN + int_val(1) = 7 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' + IF(psb_toupper(UNITD).EQ.'B') THEN + IERROR=5 + int_val(1) = 4 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + IF (psb_toupper(UNITD).EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE + END IF + + if ((alpha.ne.(1.d0,0.d0)) .or.(beta .ne.(0.0d0,0.d0))) then + if (lwork .lt. m) then + int_val(1) = 17 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + DO I = 1, N + CALL CSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) + do k=1,m + c(k,i) = beta*c(k,i) + alpha*work(k) + enddo + enddo + else + DO I = 1, N + CALL CSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),c(1,i)) + enddo + endif + IF (UNITD.EQ.'L') THEN + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/csr/csrmv.f b/base/serial/csr/csrmv.f new file mode 100644 index 000000000..dd0bddf58 --- /dev/null +++ b/base/serial/csr/csrmv.f @@ -0,0 +1,562 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +*********************************************************************** +* CSRMV modified for SPARKER * +* * +* FUNCTION: Driver for routines performing one of the sparse * +* matrix vector operations * +* * +* y = alpha*op(A)*x + beta*y * +* * +* where op(A) is one of: * +* * +* op(A) = A or op(A) = A' or * +* op(A) = conjug(A') or * +* op(A) = lower or upper part of A * +* * +* alpha and beta are scalars. * +* The data structure of the matrix is related * +* to the scalar computer. * +* This is an internal routine called by: * +* ZCSRMM * +* * +* ENTRY-POINT = CSRMV * +* * +* * +* INPUT = * +* * +* * +* SYMBOLIC NAME: TRANS * +* POSITION: PARAMETER NO 1. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'T' 'C' 'L' 'M' 'U' 'V' * +* DESCRIPTION: Specifies the form of op(A) to be used in the * +* matrix vector multiplications as follows: * +* * +* TRANS = 'N' , op( A ) = A. * +* * +* TRANS = 'T' , op( A ) = A'. * +* * +* TRANS = 'C' , OP( A ) = conjug(A') * +* * +* TRANS = 'L' or 'U', op( A ) = lower or * +* upper part of A * +* * +* TRANS = 'M' or 'V', op( A ) = lower or * +* upper part of conjugate of A * +* * +* SYMBOLIC NAME: DIAG * +* POSITION: PARAMETER NO 2. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'U' * +* DESCRIPTION: * +* Specifies whether or not the matrix A has * +* unit diagonal as follows: * +* * +* DIAG = 'N' A is not assumed * +* to have unit diagonal * +* * +* DIAG = 'U' A is assumed * +* to have unit diagonal. * +* * +* WARNING: it is the caller's responsibility * +* to ensure that if the matrix has unit * +* diagonal, there are no elements of the * +* diagonal are stored in the arrays AS and JA. * +* * +* SYMBOLIC NAME: M * +* POSITION: PARAMETER NO 3. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: M >= 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: COMPLEX*16. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: COMPLEX*16: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: COMPLEX*16 ARRAY(N) * +* (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: COMPLEX*16. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: COMPLEX*16 ARRAY(M) * +* (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: COMPLEX*16 ARRAY(M) * +* (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: COMPLEX*16 ARRAY(M) * +* (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** +C + SUBROUTINE CSRMV (TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y,WORK) + use psb_const_mod + use psb_string_mod +C .. Parameters .. + complex(psb_spk_) ONE, ZERO + PARAMETER (ONE=(1.0, 0.0), ZERO=(0.0, 0.0)) +C .. Scalar Arguments .. + complex(psb_spk_) ALPHA, BETA + INTEGER M, N + CHARACTER DIAG, TRANS +C .. Array Arguments .. + complex(psb_spk_) AS(*), WORK(*), X(*), Y(*) + INTEGER IA(*), JA(*) +C .. Local Scalars .. + complex(psb_spk_) ACC + INTEGER I, J, K, NCOLA, NROWA,DUM + LOGICAL SYM, TRA, COTRA, UNI +C .. Executable Statements .. +C + UNI = psb_toupper(DIAG).EQ.'U' +C +C .. Not simmetric matrix + TRA = psb_toupper(TRANS).EQ.'T' + COTRA = psb_toupper(TRANS).EQ.'C' + +C .. Symmetric matrix upper or lower + SYM = (psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U').OR. + + (psb_toupper(TRANS).EQ.'M').OR. + + (psb_toupper(TRANS).EQ.'V') +C + IF (.NOT.(TRA.OR.COTRA)) THEN + NROWA = M + NCOLA = N + ELSE + NROWA = N + NCOLA = M + END IF !(....(CO)TRA) + + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO I = 1, M + Y(I) = ZERO + ENDDO + ELSE + DO 20 I = 1, M + Y(I) = BETA*Y(I) + 20 CONTINUE + ENDIF + RETURN + END IF + +C + IF (SYM) THEN + IF (UNI) THEN +C +C ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + IF (BETA.NE.ZERO) THEN + DO 40 I = 1, M +C +C Product for diagonal elements +C + Y(I) = BETA*Y(I) + ALPHA*X(I) + 40 CONTINUE + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C Product for other elements + IF ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) THEN + DO 80 I = 1, M + ACC = ZERO + DO 60 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ACC = ACC + AS(J)*X(K) + 60 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 80 CONTINUE + ELSE ! Perform computations on conjug(A) + DO 82 I = 1, M + ACC = ZERO + DO 81 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) + ACC = ACC + CONJG(AS(J)) * X(K) + 81 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 82 CONTINUE + ENDIF +C + ELSE IF ( .NOT. UNI) THEN +C +C Check if matrix is lower or upper +C + IF ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'M')) THEN +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + IF (BETA.NE.ZERO) THEN + DO 100 I = 1, M + Y(I) = BETA*Y(I) + 100 CONTINUE + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF + + IF (psb_toupper(TRANS).EQ.'L') THEN + DO 140 I = 1, M + ACC = ZERO + DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 + K = JA(J) +C +C To be optimized +C + IF (K.NE.I) THEN !for symmetric element + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ENDIF + ACC = ACC + AS(J)*X(K) + 120 CONTINUE + + Y(I) = Y(I) + ALPHA*ACC + 140 CONTINUE + ELSE ! Perform computations on conjug(A) + DO 142 I = 1, M + ACC = ZERO + DO 141 J = IA(I), IA(I+1) - 1 ! it was -2 + K = JA(J) +C +C To be optimized +C + IF (K.NE.I) THEN !for symmetric element + Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) + ENDIF + ACC = ACC + CONJG(AS(J)) * X(K) + 141 CONTINUE + Y(I) = Y(I) + ALPHA * ACC + 142 CONTINUE + + ENDIF + + ELSE ! ....Trans<>L, M +C +C UPPER CASE +C ....OK!! +C + IF (BETA.NE.ZERO) THEN + DO 160 I = 1, M + Y(I) = BETA*Y(I) + 160 CONTINUE + ELSE + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF + IF (psb_toupper(TRANS).EQ.'U') THEN + DO 200 I = 1, M + ACC = ZERO + DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 + K = JA(J) +C +C To be optimized +C + IF(K.NE.I) THEN + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ENDIF + ACC = ACC + AS(J)*X(K) + 180 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 200 CONTINUE + ELSE ! Perform computations on conjug(A) + DO 202 I = 1, M + ACC = ZERO + DO 201 J = IA(I) , IA(I+1) - 1 ! removed +1 + K = JA(J) +C +C To be optimized +C + IF(K.NE.I) THEN + Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) + ENDIF + ACC = ACC + CONJG(AS(J)) * X(K) + 201 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 202 CONTINUE + ENDIF + END IF ! ......TRANS=='L' + END IF ! ......Not UNI +C + ELSE IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN !......NOT SYM + + IF ( .NOT. UNI) THEN +C +C .......General Not Unit, No Traspose +C + + IF (BETA.NE.ZERO) THEN + DO 240 I = 1, M + ACC = ZERO + DO 220 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 220 CONTINUE + Y(I) = ALPHA*ACC + BETA*Y(I) + 240 CONTINUE + ELSE + DO I = 1, M + ACC = ZERO + DO J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + ENDDO + Y(I) = ALPHA*ACC + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + IF (BETA.NE.ZERO) THEN + DO 280 I = 1, M + ACC = ZERO + DO 260 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 260 CONTINUE + Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) + 280 CONTINUE + ELSE !(BETA.EQ.ZERO) + DO I = 1, M + ACC = ZERO + DO J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + ENDDO + Y(I) = ALPHA*(ACC+X(I)) + ENDDO + ENDIF + END IF !....End Testing on UNI +C + ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) +C + IF ( .NOT. UNI) THEN +C + IF (BETA.NE.ZERO) THEN + DO 300 I = 1, M + Y(I) = BETA*Y(I) + 300 CONTINUE + ELSE !(BETA.EQ.ZERO) + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.ZERO) THEN + DO 320 I = 1, M + Y(I) = BETA*Y(I) + ALPHA*X(I) + 320 CONTINUE + ELSE !(BETA.EQ.ZERO) + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C + END IF !....UNI +C + IF (ALPHA.EQ.ONE) THEN +C + DO 360 I = 1, N + DO 340 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + AS(J)*X(I) + 340 CONTINUE + 360 CONTINUE +C + ELSE IF (ALPHA.EQ.-ONE) THEN +C + DO 400 I = 1, n + DO 380 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) - AS(J)*X(I) + 380 CONTINUE + 400 CONTINUE +C + ELSE !.....Else on TRA +C +C This work array is used for efficiency +C + DO 420 I = 1, N + WORK(I) = ALPHA*X(I) + 420 CONTINUE +C + DO 460 I = 1, n + DO 440 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + AS(J)*WORK(I) + 440 CONTINUE + 460 CONTINUE +C + END IF !.....End testing on ALPHA + + ELSE IF (COTRA) THEN !....Else on SYM (swapped M and N) +C + IF ( .NOT. UNI) THEN +C + IF (BETA.NE.ZERO) THEN + DO 500 I = 1, M + Y(I) = BETA*Y(I) + 500 CONTINUE + ELSE !(BETA.EQ.ZERO) + DO I = 1, M + Y(I) = ZERO + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.ZERO) THEN + DO 520 I = 1, M + Y(I) = BETA*Y(I) + ALPHA*X(I) + 520 CONTINUE + ELSE !(BETA.EQ.ZERO) + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C + END IF !....UNI +C + IF (ALPHA.EQ.ONE) THEN +C + DO 560 I = 1, N + DO 540 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + CONJG(AS(J))*X(I) + 540 CONTINUE + 560 CONTINUE +C + ELSE IF (ALPHA.EQ.-ONE) THEN +C + DO 600 I = 1, n + DO 580 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) - CONJG(AS(J))*X(I) + 580 CONTINUE + 600 CONTINUE +C + ELSE !.....Else on TRA +C +C This work array is used for efficiency +C + DO 620 I = 1, N + WORK(I) = ALPHA*X(I) + 620 CONTINUE +C + DO 660 I = 1, n + DO 640 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + CONJG(AS(J))*WORK(I) + 640 CONTINUE + 660 CONTINUE +C + END IF !.....End testing on ALPHA + + END IF !.....End testing on SYM +C + RETURN +C +C END OF CSRMV +C + END + diff --git a/base/serial/csr/csrsv.f b/base/serial/csr/csrsv.f new file mode 100644 index 000000000..84f13f528 --- /dev/null +++ b/base/serial/csr/csrsv.f @@ -0,0 +1,176 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C + SUBROUTINE CSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X) + use psb_const_mod + use psb_string_mod + complex(psb_spk_) ZERO + PARAMETER (ZERO = (0.0, 0.0)) + INTEGER N + CHARACTER DIAG, TRANS, UPLO + complex(psb_spk_) AS(*), B(*), X(*) + INTEGER IA(*), JA(*) + complex(psb_spk_) ACC + INTEGER I, J, K + LOGICAL LOW, TRA, COTRA, UNI + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + COTRA = (psb_toupper(TRANS).EQ.'C') + LOW = (psb_toupper(UPLO).EQ.'L') + IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN + IF (LOW) THEN + IF (.NOT.UNI) THEN + DO 40 I = 1, N + ACC = ZERO + DO 20 J = IA(I), IA(I+1) - 2 + ACC = ACC + AS(J)*X(JA(J)) + 20 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I+1)-1) + 40 CONTINUE + ELSE IF (UNI) THEN + DO 80 I = 1, N + ACC = ZERO + DO 60 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 60 CONTINUE + X(I) = B(I) - ACC + 80 CONTINUE + END IF + ELSE IF (.NOT.LOW) THEN + IF (.NOT.UNI) THEN + DO 120 I = N, 1, -1 + ACC = ZERO + DO 100 J = IA(I) + 1, IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 100 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I)) + 120 CONTINUE + ELSE IF (UNI) THEN + DO 160 I = N, 1, -1 + ACC = ZERO + DO 140 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 140 CONTINUE + X(I) = B(I) - ACC + 160 CONTINUE + END IF + END IF + ELSE IF (TRA) THEN + DO 180 I = 1, N + X(I) = B(I) + 180 CONTINUE + IF (LOW) THEN + IF (.NOT.UNI) THEN + DO 220 I = N, 1, -1 + X(I) = X(I)/AS(IA(I+1)-1) + ACC = X(I) + DO 200 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 200 CONTINUE + 220 CONTINUE + ELSE IF (UNI) THEN + DO 260 I = N, 1, -1 + ACC = X(I) + DO 240 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 240 CONTINUE + 260 CONTINUE + END IF + ELSE IF (.NOT.LOW) THEN + IF (.NOT.UNI) THEN + DO 300 I = 1, N + X(I) = X(I)/AS(IA(I)) + ACC = X(I) + DO 280 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 280 CONTINUE + 300 CONTINUE + ELSE IF (UNI) THEN + DO 340 I = 1, N + ACC = X(I) + DO 320 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 320 CONTINUE + 340 CONTINUE + END IF + END IF + ELSE IF (COTRA) THEN + DO 580 I = 1, N + X(I) = B(I) + 580 CONTINUE + IF (LOW) THEN + IF (.NOT.UNI) THEN + DO 620 I = N, 1, -1 + X(I) = X(I)/CONJG(AS(IA(I+1)-1)) + ACC = X(I) + DO 600 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - CONJG(AS(J))*ACC + 600 CONTINUE + 620 CONTINUE + ELSE IF (UNI) THEN + DO 660 I = N, 1, -1 + ACC = X(I) + DO 640 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - CONJG(AS(J))*ACC + 640 CONTINUE + 660 CONTINUE + END IF + ELSE IF (.NOT.LOW) THEN + IF (.NOT.UNI) THEN + DO 700 I = 1, N + X(I) = X(I)/CONJG(AS(IA(I))) + ACC = X(I) + DO 680 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - CONJG(AS(J))*ACC + 680 CONTINUE + 700 CONTINUE + ELSE IF (UNI) THEN + DO 740 I = 1, N + ACC = X(I) + DO 720 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - CONJG(AS(J))*ACC + 720 CONTINUE + 740 CONTINUE + END IF + END IF + END IF + RETURN + END + + + diff --git a/base/serial/csr/dcsrck.f b/base/serial/csr/dcsrck.f index 710befde7..00d0e9733 100644 --- a/base/serial/csr/dcsrck.f +++ b/base/serial/csr/dcsrck.f @@ -88,9 +88,10 @@ C IERROR > 0 error in integrity check SUBROUTINE DCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, - + WORK,LWORK,IERROR) + + WORK,LWORK,IERROR) use psb_const_mod - IMPLICIT NONE + use psb_string_mod + IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK,M, N, IERROR CHARACTER TRANS @@ -109,52 +110,57 @@ C Check #1: Character descriptor have valid values C IERROR = 0 - IF ((DESCRA(1:1).NE.'G').AND.(DESCRA(1:1).NE.'S').AND. - & (DESCRA(1:1).NE.'H').AND.(DESCRA(1:1).NE.'T').AND. - & (DESCRA(1:1).NE.'A').AND.(DESCRA(1:1).NE.'D')) THEN - IERROR = 11 - GOTO 9999 + IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. + + (psb_toupper(DESCRA(1:1)).NE.'S').AND. + + (psb_toupper(DESCRA(1:1)).NE.'H').AND. + + (psb_toupper(DESCRA(1:1)).NE.'T').AND. + + (psb_toupper(DESCRA(1:1)).NE.'A').AND. + + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN + IERROR = 11 + GOTO 9999 END IF - IF ((DESCRA(2:2).NE.'U').AND.(DESCRA(2:2).NE.'L')) THEN - IERROR = 12 - GOTO 9999 + IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. + + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN + IERROR = 12 + GOTO 9999 END IF - IF ((DESCRA(3:3).NE.'U').AND.(DESCRA(3:3).NE.'N')) THEN - IERROR = 13 - GOTO 9999 + IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. + + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN + IERROR = 13 + GOTO 9999 END IF C C Check #2: Pointers have non decreasing order C IF (IA2(1).LE.0) THEN - IERROR = 14 - GOTO 9999 + IERROR = 14 + GOTO 9999 ENDIF NROW = 0 DO 10 I = 1, M - IF (IA2(I) .GT. IA2(I+1)) THEN - NROW = NROW + 1 - END IF + IF (IA2(I) .GT. IA2(I+1)) THEN + NROW = NROW + 1 + END IF 10 CONTINUE IF (NROW .GT. 0) THEN - IERROR = 15 - GOTO 9999 + IERROR = 15 + GOTO 9999 END IF C C Check #3: Indices are within problem dimension C NIND = 0 DO 20 I = 1, M - DO 30 J = IA2(I), IA2(I+1) - 1 - IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN - NIND = NIND + 1 - END IF - 30 CONTINUE + DO 30 J = IA2(I), IA2(I+1) - 1 + IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN + NIND = NIND + 1 + END IF + 30 CONTINUE 20 CONTINUE IF (NIND .GT. 0) THEN - IERROR = 16 - GOTO 9999 + IERROR = 16 + GOTO 9999 END IF 9999 CONTINUE RETURN diff --git a/base/serial/csr/dcsrmm.f b/base/serial/csr/dcsrmm.f index 97b9205f0..01eb908c8 100644 --- a/base/serial/csr/dcsrmm.f +++ b/base/serial/csr/dcsrmm.f @@ -38,6 +38,7 @@ c SUBROUTINE DCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod C .. Scalar Arguments .. real(psb_dpk_) ALPHA, BETA INTEGER K, LDB, LDC, M, N, LWORK,IERROR @@ -62,14 +63,16 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) C - TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' + IF (psb_toupper(DESCRA(1:1)).EQ.'G') TRANS = TRANSA + IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') TRANS = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') TRANS = 'L' c c Does DSRMV manage this case too? c - IF (DESCRA(1:1).EQ.'D') THEN - IF (DESCRA(3:3).EQ.'U') THEN + IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN + IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN DO 40 I = 1, K DO 20 J = 1, M C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) @@ -85,8 +88,8 @@ c RETURN END IF C - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' C C C = A*B OR C=A'*B C diff --git a/base/serial/csr/dcsrmv.f b/base/serial/csr/dcsrmv.f index 6146987eb..db6e15381 100644 --- a/base/serial/csr/dcsrmv.f +++ b/base/serial/csr/dcsrmv.f @@ -168,9 +168,7 @@ C SUBROUTINE DCSRMV(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y, + WORK,LWORK,IERROR) use psb_const_mod -C .. Parameters .. - real(psb_dpk_) ONE, ZERO - PARAMETER (ONE=1.0D0,ZERO=0.0D0) + use psb_string_mod C .. Scalar Arguments .. real(psb_dpk_) ALPHA, BETA INTEGER M, N,LWORK,IERROR @@ -185,11 +183,12 @@ C .. Local Scalars .. C .. Executable Statements .. C IERROR = 0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) C IF ( .NOT. TRA) THEN NROWA = M @@ -199,10 +198,10 @@ C NCOLA = M END IF !(....TRA) - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN + IF (ALPHA.EQ.DZERO) THEN + IF (BETA.EQ.DZERO) THEN DO I = 1, M - Y(I) = ZERO + Y(I) = DZERO ENDDO ELSE DO 20 I = 1, M @@ -220,7 +219,7 @@ C ......Symmetric with unitary diagonal....... C ....OK!! C To be optimized - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 40 I = 1, M C C Product for diagonal elements @@ -235,7 +234,7 @@ C C Product for other elements DO 80 I = 1, M - ACC = ZERO + ACC = DZERO DO 60 J = IA(I), IA(I+1) - 1 K = JA(J) Y(K) = Y(K) + ALPHA*AS(J)*X(I) @@ -248,23 +247,23 @@ C C C Check if matrix is lower or upper C - IF (TRANS.EQ.'L') THEN + IF (PSB_TOUPPER(TRANS).EQ.'L') THEN C C LOWER CASE: diagonal element is the last element of row C ....OK! - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 100 I = 1, M Y(I) = BETA*Y(I) 100 CONTINUE ELSE DO I = 1, M - Y(I) = ZERO + Y(I) = DZERO ENDDO ENDIF DO 140 I = 1, M - ACC = ZERO + ACC = DZERO DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 K = JA(J) C @@ -283,18 +282,18 @@ C C UPPER CASE C ....OK!! C - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 160 I = 1, M Y(I) = BETA*Y(I) 160 CONTINUE ELSE DO I = 1, M - Y(I) = ZERO + Y(I) = DZERO ENDDO ENDIF DO 200 I = 1, M - ACC = ZERO + ACC = DZERO DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 K = JA(J) C @@ -316,18 +315,18 @@ C C C .......General Not Unit, No Traspose C - if (beta == zero) then - if (alpha==one) then + if (beta == dzero) then + if (alpha==done) then do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo y(i) = acc enddo - else if (alpha==-one) then + else if (alpha==-done) then do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc - as(j)*x(ja(j)) enddo @@ -335,7 +334,7 @@ C enddo else do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo @@ -344,9 +343,9 @@ C endif - else if (beta==one) then + else if (beta==done) then - if (alpha==one) then + if (alpha==done) then do i = 1, m acc = y(i) do j = ia(i), ia(i+1) - 1 @@ -354,7 +353,7 @@ C enddo y(i) = acc enddo - else if (alpha==-one) then + else if (alpha==-done) then do i = 1, m acc = y(i) do j = ia(i), ia(i+1) - 1 @@ -364,7 +363,7 @@ C enddo else do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo @@ -372,9 +371,9 @@ C enddo endif - else if (beta==-one) then + else if (beta==-done) then - if (alpha==one) then + if (alpha==done) then do i = 1, m acc = -y(i) do j = ia(i), ia(i+1) - 1 @@ -382,7 +381,7 @@ C enddo y(i) = acc enddo - else if (alpha==-one) then + else if (alpha==-done) then do i = 1, m acc = -y(i) do j = ia(i), ia(i+1) - 1 @@ -392,7 +391,7 @@ C enddo else do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo @@ -400,17 +399,17 @@ C enddo endif else - if (alpha==one) then + if (alpha==done) then do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo y(i) = acc + beta*y(i) enddo - else if (alpha==-one) then + else if (alpha==-done) then do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc - as(j)*x(ja(j)) enddo @@ -418,7 +417,7 @@ C enddo else do i = 1, m - acc = zero + acc = dzero do j = ia(i), ia(i+1) - 1 acc = acc + as(j)*x(ja(j)) enddo @@ -429,17 +428,17 @@ C C ELSE IF (UNI) THEN C - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 280 I = 1, M - ACC = ZERO + ACC = DZERO DO 260 J = IA(I), IA(I+1) - 1 ACC = ACC + AS(J)*X(JA(J)) 260 CONTINUE Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) 280 CONTINUE - ELSE !(BETA.EQ.ZERO) + ELSE !(BETA.EQ.DZERO) DO I = 1, M - ACC = ZERO + ACC = DZERO DO J = IA(I), IA(I+1) - 1 ACC = ACC + AS(J)*X(JA(J)) ENDDO @@ -452,24 +451,24 @@ C C IF ( .NOT. UNI) THEN C - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 300 I = 1, M Y(I) = BETA*Y(I) 300 CONTINUE - ELSE !(BETA.EQ.ZERO) + ELSE !(BETA.EQ.DZERO) DO I = 1, M - Y(I) = ZERO + Y(I) = DZERO ENDDO ENDIF C ELSE IF (UNI) THEN C - IF (BETA.NE.ZERO) THEN + IF (BETA.NE.DZERO) THEN DO 320 I = 1, M Y(I) = BETA*Y(I) + ALPHA*X(I) 320 CONTINUE - ELSE !(BETA.EQ.ZERO) + ELSE !(BETA.EQ.DZERO) DO I = 1, M Y(I) = ALPHA*X(I) ENDDO @@ -478,7 +477,7 @@ C C END IF !....UNI C - IF (ALPHA.EQ.ONE) THEN + IF (ALPHA.EQ.DONE) THEN C DO 360 I = 1, N DO 340 J = IA(I), IA(I+1) - 1 @@ -487,7 +486,7 @@ C 340 CONTINUE 360 CONTINUE C - ELSE IF (ALPHA.EQ.-ONE) THEN + ELSE IF (ALPHA.EQ.-DONE) THEN C DO 400 I = 1, n DO 380 J = IA(I), IA(I+1) - 1 diff --git a/base/serial/csr/dcsrmv2.f b/base/serial/csr/dcsrmv2.f index bda118b6f..1fff2923b 100644 --- a/base/serial/csr/dcsrmv2.f +++ b/base/serial/csr/dcsrmv2.f @@ -168,6 +168,7 @@ C SUBROUTINE DCSRMV2(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + BETA,Y,LDY, WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod integer nb parameter (nb=2) C .. Parameters .. @@ -187,11 +188,12 @@ C .. Local Scalars .. C .. Executable Statements .. C IERROR = 0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) C if ( .not. tra) then nrowa = m diff --git a/base/serial/csr/dcsrmv3.f b/base/serial/csr/dcsrmv3.f index 45bd21eac..3ac345145 100644 --- a/base/serial/csr/dcsrmv3.f +++ b/base/serial/csr/dcsrmv3.f @@ -168,6 +168,7 @@ C SUBROUTINE DCSRMV3(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + BETA,Y,LDY, WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod integer nb parameter (nb=3) C .. Parameters .. @@ -187,11 +188,12 @@ C .. Local Scalars .. C .. Executable Statements .. C IERROR = 0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) C if ( .not. tra) then nrowa = m diff --git a/base/serial/csr/dcsrmv4.f b/base/serial/csr/dcsrmv4.f index 6381c4460..1be6ccc68 100644 --- a/base/serial/csr/dcsrmv4.f +++ b/base/serial/csr/dcsrmv4.f @@ -168,6 +168,7 @@ C SUBROUTINE DCSRMV4(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + BETA,Y,LDY, WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod integer nb parameter (nb=4) C .. Parameters .. @@ -187,11 +188,12 @@ C .. Local Scalars .. C .. Executable Statements .. C IERROR = 0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) C if ( .not. tra) then nrowa = m diff --git a/base/serial/csr/dcsrrws.f b/base/serial/csr/dcsrrws.f index b64160534..9b53b9c50 100644 --- a/base/serial/csr/dcsrrws.f +++ b/base/serial/csr/dcsrrws.f @@ -32,6 +32,7 @@ C SUBROUTINE DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, & INFOA,ROWSUM,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER M,N, IERROR @@ -43,14 +44,15 @@ C .. Array Arguments .. C .. Local scalars .. INTEGER I, J - IF (TRANS.EQ.'N') THEN + IF (psb_toupper(TRANS).EQ.'N') THEN DO I = 1, M ROWSUM(I) = 0.0D0 DO J = IA2(I), IA2(I + 1) - 1 ROWSUM(I) = ROWSUM(I) + ABS(A(J)) ENDDO ENDDO - ELSE IF ((TRANS.EQ.'T').OR.(TRANS.EQ.'C')) THEN + ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. + + (psb_toupper(TRANS).EQ.'C')) THEN DO J = 1, N ROWSUM(J) = 0.0D0 ENDDO diff --git a/base/serial/csr/dcsrsm.f b/base/serial/csr/dcsrsm.f index 7ce445997..aff8c44dd 100644 --- a/base/serial/csr/dcsrsm.f +++ b/base/serial/csr/dcsrsm.f @@ -30,8 +30,9 @@ C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE DCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod real(psb_dpk_) ALPHA, BETA INTEGER LDB, LDC, LWORK, M, N, IERROR CHARACTER UNITD, TRANST @@ -49,28 +50,30 @@ C .. Local Arrays .. CALL FCPSB_ERRACTIONSAVE(ERR_ACT) int_Val(1)=0 UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + int_val(1) = 7 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' IF(UNITD.EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=5 + int_val(1) = 4 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE + IF (psb_toupper(UNITD).EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE END IF if ((alpha.ne.1.d0) .or.(beta .ne.0.0d0)) then if (lwork .lt. m) then @@ -92,17 +95,17 @@ C .. Local Arrays .. 60 CONTINUE endif IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 END IF IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE END IF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -112,8 +115,8 @@ C .. Local Arrays .. 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/csr/dcsrsv.f b/base/serial/csr/dcsrsv.f index 08eb6164e..6037c836d 100644 --- a/base/serial/csr/dcsrsv.f +++ b/base/serial/csr/dcsrsv.f @@ -31,6 +31,7 @@ C C SUBROUTINE DCSRSV(UPLO,TRANS,DIAG,N,AS,JA,IA,B,X,IERROR) use psb_const_mod + use psb_string_mod real(psb_dpk_) ZERO PARAMETER (ZERO=0.0D0) INTEGER N, IERROR @@ -40,90 +41,90 @@ C real(psb_dpk_) ACC INTEGER I, J, K LOGICAL LOW, TRA, UNI - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - LOW = (UPLO.EQ.'L') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + LOW = (psb_toupper(UPLO).EQ.'L') IF ( .NOT. TRA) THEN - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 40 I = 1, N - ACC = ZERO - DO 20 J = IA(I), IA(I+1) - 2 - ACC = ACC + AS(J)*X(JA(J)) - 20 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I+1)-1) - 40 CONTINUE - ELSE IF (UNI) THEN - DO 80 I = 1, N - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 60 CONTINUE - X(I) = B(I) - ACC - 80 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 120 I = N, 1, -1 - ACC = ZERO - DO 100 J = IA(I) + 1, IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 100 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I)) - 120 CONTINUE - ELSE IF (UNI) THEN - DO 160 I = N, 1, -1 - ACC = ZERO - DO 140 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 140 CONTINUE - X(I) = B(I) - ACC - 160 CONTINUE - END IF - END IF + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 40 I = 1, N + ACC = ZERO + DO 20 J = IA(I), IA(I+1) - 2 + ACC = ACC + AS(J)*X(JA(J)) + 20 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I+1)-1) + 40 CONTINUE + ELSE IF (UNI) THEN + DO 80 I = 1, N + ACC = ZERO + DO 60 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 60 CONTINUE + X(I) = B(I) - ACC + 80 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 120 I = N, 1, -1 + ACC = ZERO + DO 100 J = IA(I) + 1, IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 100 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I)) + 120 CONTINUE + ELSE IF (UNI) THEN + DO 160 I = N, 1, -1 + ACC = ZERO + DO 140 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 140 CONTINUE + X(I) = B(I) - ACC + 160 CONTINUE + END IF + END IF ELSE IF (TRA) THEN - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF + DO 180 I = 1, N + X(I) = B(I) + 180 CONTINUE + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 220 I = N, 1, -1 + X(I) = X(I)/AS(IA(I+1)-1) + ACC = X(I) + DO 200 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 200 CONTINUE + 220 CONTINUE + ELSE IF (UNI) THEN + DO 260 I = N, 1, -1 + ACC = X(I) + DO 240 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 240 CONTINUE + 260 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 300 I = 1, N + X(I) = X(I)/AS(IA(I)) + ACC = X(I) + DO 280 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 280 CONTINUE + 300 CONTINUE + ELSE IF (UNI) THEN + DO 340 I = 1, N + ACC = X(I) + DO 320 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 320 CONTINUE + 340 CONTINUE + END IF + END IF END IF RETURN END diff --git a/base/serial/csr/scrnrmi.f b/base/serial/csr/scrnrmi.f new file mode 100644 index 000000000..c39780d33 --- /dev/null +++ b/base/serial/csr/scrnrmi.f @@ -0,0 +1,63 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute Infinity norm for sparse matrix in CSR Format ... + FUNCTION SCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) scrnrmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11 + real(psb_spk_) A(*) +C .. Local scalars .. + INTEGER I, J + real(psb_dpk_) NRMI, SUM + + IERROR=0 + NRMI = 0.0 + DO I = 1, M + SUM = 0.0 + DO J = IA2(I), IA2(I+1)-1 + SUM = SUM + ABS(A(J)) + ENDDO + + IF (SUM.GT.NRMI) THEN + NRMI = SUM + ENDIF + ENDDO + + SCRNRMI = NRMI + END diff --git a/base/serial/csr/scsrmm.f b/base/serial/csr/scsrmm.f new file mode 100644 index 000000000..e378d71f6 --- /dev/null +++ b/base/serial/csr/scsrmm.f @@ -0,0 +1,144 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +c +c What if a wrong DESCRA is passed? +c +c +* +* + SUBROUTINE SCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, + * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER K, LDB, LDC, M, N, LWORK,IERROR + CHARACTER TRANSA +C .. Array Arguments .. + real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) + INTEGER IA(*), JA(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER I, J, K4 + CHARACTER DIAG, TRANS +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + +C +C + NAME = 'SCSRMM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) +C + IF (psb_toupper(DESCRA(1:1)).EQ.'G') TRANS = TRANSA + IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') TRANS = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') TRANS = 'L' +c +c Does DSRMV manage this case too? +c + IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN + IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN + DO 40 I = 1, K + DO 20 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) + 20 CONTINUE + 40 CONTINUE + ELSE + DO 80 I = 1, K + DO 60 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) + 60 CONTINUE + 80 CONTINUE + END IF + RETURN + END IF +C + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' +C +C C = A*B OR C=A'*B +C +C + NB = 4 + K4 = MOD(K,NB) + SELECT CASE(K4) + CASE(1) + IF (K==1) THEN + CALL SCSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,1), + + BETA,C(1,1),WORK,LWORK,IERROR) + ELSE + CALL SCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, + + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) + CALL SCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, + + B(1,3),LDB,BETA,C(1,3),LDC,WORK,LWORK,IERROR) + K4 = K4 + 4 + ENDIF + CASE(2) + CALL SCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, + + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) + CASE(3) + CALL SCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, + + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) + END SELECT + + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + DO I=K4+1,K,NB + CALL SCSRMV4(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, + + B(1,I),LDB,BETA,C(1,I),LDC,WORK,LWORK,IERROR) + ENDDO + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/csr/scsrmv.f b/base/serial/csr/scsrmv.f new file mode 100644 index 000000000..979176b7f --- /dev/null +++ b/base/serial/csr/scsrmv.f @@ -0,0 +1,527 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* DSRMV modified for SPARKER +* * +* FUNCTION: Driver for routines performing one of the sparse * +* matrix vector operations * +* * +* y = alpha*op(A)*x + beta*y * +* * +* where op(A) is one of: * +* * +* op(A) = A or op(A) = A' or * +* op(A) = lower or upper part of A * +* * +* alpha and beta are scalars. * +* The data structure of the matrix is related * +* to the scalar computer. * +* This is an internal routine called by: * +* DSMMV * +* * +* ENTRY-POINT = DSRMV * +* INPUT = * +* * +* * +* SYMBOLIC NAME: TRANS * +* POSITION: PARAMETER NO 1. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'T' 'L' 'U' * +* DESCRIPTION: Specifies the form of op(A) to be used in the * +* matrix vector multiplications as follows: * +* * +* TRANS = 'N' , op( A ) = A. * +* * +* TRANS = 'T' , op( A ) = A'. * +* * +* TRANS = 'L' or 'U', op( A ) = lower or * +* upper part of A * +* * +* SYMBOLIC NAME: DIAG * +* POSITION: PARAMETER NO 2. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'U' * +* DESCRIPTION: * +* Specifies whether or not the matrix A has * +* unit diagonal as follows: * +* * +* DIAG = 'N' A is not assumed * +* to have unit diagonal * +* * +* DIAG = 'U' A is assumed * +* to have unit diagonal. * +* * +* WARNING: it is the caller's responsibility * +* to ensure that if the matrix has unit * +* diagonal, there are no elements of the * +* diagonal are stored in the arrays AS and JA. * +* * +* SYMBOLIC NAME: M * +* POSITION: PARAMETER NO 3. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: M >= 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE SCSRMV(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y, + + WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER M, N,LWORK,IERROR + CHARACTER DIAG, TRANS +C .. Array Arguments .. + real(psb_spk_) AS(*), WORK(*), X(*), Y(*) + INTEGER IA(*), JA(*) +C .. Local Scalars .. + real(psb_dpk_) ACC + INTEGER I, J, K, NCOLA, NROWA + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + IERROR = 0 + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) +C + IF ( .NOT. TRA) THEN + NROWA = M + NCOLA = N + ELSE IF (TRA) THEN + NROWA = N + NCOLA = M + END IF !(....TRA) + + IF (ALPHA.EQ.SZERO) THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, M + Y(I) = SZERO + ENDDO + ELSE + DO 20 I = 1, M + Y(I) = BETA*Y(I) + 20 CONTINUE + ENDIF + RETURN + END IF + +C + IF (SYM) THEN + IF (UNI) THEN +C +C ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + IF (BETA.NE.SZERO) THEN + DO 40 I = 1, M +C +C Product for diagonal elements +C + Y(I) = BETA*Y(I) + ALPHA*X(I) + 40 CONTINUE + ELSE + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C Product for other elements + DO 80 I = 1, M + ACC = SZERO + DO 60 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ACC = ACC + AS(J)*X(K) + 60 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 80 CONTINUE +C + ELSE IF ( .NOT. UNI) THEN +C +C Check if matrix is lower or upper +C + IF (psb_toupper(TRANS).EQ.'L') THEN +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + IF (BETA.NE.SZERO) THEN + DO 100 I = 1, M + Y(I) = BETA*Y(I) + 100 CONTINUE + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF + + DO 140 I = 1, M + ACC = SZERO + DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 + K = JA(J) +C +C To be optimized +C + IF (K.NE.I) THEN !for symmetric element + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ENDIF + ACC = ACC + AS(J)*X(K) + 120 CONTINUE + + Y(I) = Y(I) + ALPHA*ACC + 140 CONTINUE + ELSE ! ....Trans<>L +C +C UPPER CASE +C ....OK!! +C + IF (BETA.NE.SZERO) THEN + DO 160 I = 1, M + Y(I) = BETA*Y(I) + 160 CONTINUE + ELSE + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF + + DO 200 I = 1, M + ACC = SZERO + DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 + K = JA(J) +C +C To be optimized +C + IF(K.NE.I) THEN + Y(K) = Y(K) + ALPHA*AS(J)*X(I) + ENDIF + ACC = ACC + AS(J)*X(K) + 180 CONTINUE + Y(I) = Y(I) + ALPHA*ACC + 200 CONTINUE + END IF ! ......TRANS=='L' + END IF ! ......Not UNI +C + ELSE IF ( .NOT. TRA) THEN !......NOT SYM + + IF ( .NOT. UNI) THEN +C +C .......General Not Unit, No Traspose +C + if (beta == szero) then + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = alpha*acc + enddo + + endif + + else if (beta==sone) then + + if (alpha==sone) then + do i = 1, m + acc = y(i) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = y(i) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = alpha*acc + y(i) + enddo + endif + + else if (beta==-sone) then + + if (alpha==sone) then + do i = 1, m + acc = -y(i) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = -y(i) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j)) + enddo + y(i) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = alpha*acc - y(i) + enddo + endif + else + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = acc + beta*y(i) + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j)) + enddo + y(i) = acc + beta*y(i) + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j)) + enddo + y(i) = alpha*acc + beta*y(i) + enddo + endif + end if +C + ELSE IF (UNI) THEN +C + IF (BETA.NE.SZERO) THEN + DO 280 I = 1, M + ACC = SZERO + DO 260 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 260 CONTINUE + Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) + 280 CONTINUE + ELSE !(BETA.EQ.SZERO) + DO I = 1, M + ACC = SZERO + DO J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + ENDDO + Y(I) = ALPHA*(ACC+X(I)) + ENDDO + ENDIF + END IF !....End Testing on UNI +C + ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) +C + IF ( .NOT. UNI) THEN +C + IF (BETA.NE.SZERO) THEN + DO 300 I = 1, M + Y(I) = BETA*Y(I) + 300 CONTINUE + ELSE !(BETA.EQ.SZERO) + DO I = 1, M + Y(I) = SZERO + ENDDO + ENDIF +C + ELSE IF (UNI) THEN +C + + IF (BETA.NE.SZERO) THEN + DO 320 I = 1, M + Y(I) = BETA*Y(I) + ALPHA*X(I) + 320 CONTINUE + ELSE !(BETA.EQ.SZERO) + DO I = 1, M + Y(I) = ALPHA*X(I) + ENDDO + ENDIF + +C + END IF !....UNI +C + IF (ALPHA.EQ.SONE) THEN +C + DO 360 I = 1, N + DO 340 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + AS(J)*X(I) + 340 CONTINUE + 360 CONTINUE +C + ELSE IF (ALPHA.EQ.-SONE) THEN +C + DO 400 I = 1, n + DO 380 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) - AS(J)*X(I) + 380 CONTINUE + 400 CONTINUE +C + ELSE !.....Else on TRA +C +C This work array is used for efficiency +C + IF (LWORK.LT.N) THEN + IERROR = 60 + WORK(1) = DBLE(N) + RETURN + ENDIF + DO 420 I = 1, N + WORK(I) = ALPHA*X(I) + 420 CONTINUE +C + DO 460 I = 1, n + DO 440 J = IA(I), IA(I+1) - 1 + K = JA(J) + Y(K) = Y(K) + AS(J)*WORK(I) + 440 CONTINUE + 460 CONTINUE +C + END IF !.....End testing on ALPHA + + END IF !.....End testing on SYM +C + RETURN +C +C END OF DSRMV +C + END + diff --git a/base/serial/csr/scsrmv2.f b/base/serial/csr/scsrmv2.f new file mode 100644 index 000000000..6f17508b9 --- /dev/null +++ b/base/serial/csr/scsrmv2.f @@ -0,0 +1,530 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* DSRMV modified for SPARKER +* * +* FUNCTION: Driver for routines performing one of the sparse * +* matrix vector operations * +* * +* y = alpha*op(A)*x + beta*y * +* * +* where op(A) is one of: * +* * +* op(A) = A or op(A) = A' or * +* op(A) = lower or upper part of A * +* * +* alpha and beta are scalars. * +* The data structure of the matrix is related * +* to the scalar computer. * +* This is an internal routine called by: * +* DSMMV * +* * +* ENTRY-POINT = DSRMV * +* INPUT = * +* * +* * +* SYMBOLIC NAME: TRANS * +* POSITION: PARAMETER NO 1. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'T' 'L' 'U' * +* DESCRIPTION: Specifies the form of op(A) to be used in the * +* matrix vector multiplications as follows: * +* * +* TRANS = 'N' , op( A ) = A. * +* * +* TRANS = 'T' , op( A ) = A'. * +* * +* TRANS = 'L' or 'U', op( A ) = lower or * +* upper part of A * +* * +* SYMBOLIC NAME: DIAG * +* POSITION: PARAMETER NO 2. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'U' * +* DESCRIPTION: * +* Specifies whether or not the matrix A has * +* unit diagonal as follows: * +* * +* DIAG = 'N' A is not assumed * +* to have unit diagonal * +* * +* DIAG = 'U' A is assumed * +* to have unit diagonal. * +* * +* WARNING: it is the caller's responsibility * +* to ensure that if the matrix has unit * +* diagonal, there are no elements of the * +* diagonal are stored in the arrays AS and JA. * +* * +* SYMBOLIC NAME: M * +* POSITION: PARAMETER NO 3. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: M >= 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE SCSRMV2(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + + BETA,Y,LDY, WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + integer nb + parameter (nb=2) +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER M, N,LWORK,IERROR,ldx,ldy + CHARACTER DIAG, TRANS +C .. Array Arguments .. + real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) + INTEGER IA(*), JA(*) +C .. Local Scalars .. + real(psb_dpk_) ACC(nb) + INTEGER I, J, K, NCOLA, NROWA + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + IERROR = 0 + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) +C + if ( .not. tra) then + nrowa = m + ncola = n + else if (tra) then + nrowa = n + ncola = m + end if !(....tra) + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do i = 1, m + y(i,1:nb) = szero + enddo + else + do 20 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 20 continue + endif + return + end if + +c + if (sym) then + if (uni) then +c +c ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + if (beta.ne.szero) then + do i = 1, m +C +C Product for diagonal elements +c + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + enddo + else + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +C Product for other elements + do 80 i = 1, m + acc = szero + do 60 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 60 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 80 continue +C + else if ( .not. uni) then +C +C Check if matrix is lower or upper +C + if (psb_toupper(trans).eq.'L') then +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + if (beta.ne.szero) then + do 100 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 100 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 140 i = 1, m + acc = szero + do 120 j = ia(i), ia(i+1) - 1 ! it was -2 + K = ja(j) +C +C To be optimized +C + if (k.ne.i) then !for symmetric element + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 120 continue + + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 140 continue + else ! ....Trans<>L +C +C UPPER CASE +C ....OK!! +C + if (beta.ne.szero) then + do 160 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 160 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 200 i = 1, m + acc = szero + do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 + k = ja(j) +C +C To be optimized +C + if (k.ne.i) then + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 180 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 200 continue + end if ! ......TRANS=='L' + end if ! ......Not UNI +c + else if ( .not. tra) then !......NOT SYM + + if ( .not. uni) then +C +C .......General Not Unit, No Traspose +C + + if (beta == szero) then + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + enddo + + endif + + else if (beta==sone) then + + if (alpha==sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + y(i,1:nb) + enddo + endif + + else if (beta==-sone) then + + if (alpha==sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc - y(i,1:nb) + enddo + endif + else + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + beta*y(i,1:nb) + enddo + endif + end if +c + else if (uni) then +c + if (beta.ne.szero) then + do 280 i = 1, m + acc(1:nb) = szero + do 260 j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + 260 continue + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) + 280 continue + else !(beta.eq.szero) + do i = 1, m + acc(1:nb) = szero + do j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + enddo + endif + end if !....End Testing on UNI +C + else if (tra) then !....Else on SYM (swapped M and N) +C + if ( .not. uni) then +c + if (beta.ne.szero) then + do 300 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 300 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = szero + enddo + endif +c + else if (uni) then +c + + if (beta.ne.szero) then + do 320 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + 320 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +c + end if !....UNI +C + if (alpha.eq.sone) then +c + do 360 i = 1, n + do 340 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) + 340 continue + 360 continue +c + else if (alpha.eq.-sone) then +c + do 400 i = 1, n + do 380 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) + 380 continue + 400 continue +c + else !.....Else on TRA +C +C This work array is used for efficiency +C + if (lwork.lt.n) then + ierror = 60 + work(1) = dble(n) + return + endif +c$$$ do 420 i = 1, n +c$$$ work(i) = alpha*x(i,1:4) +c$$$ 420 continue +c$$$C +c$$$ DO 460 I = 1, n +c$$$ DO 440 J = IA(I), IA(I+1) - 1 +c$$$ K = JA(J) +c$$$ Y(K) = Y(K) + AS(J)*WORK(I) +c$$$ 440 CONTINUE +c$$$ 460 CONTINUE +c + end if !.....end testing on alpha + + end if !.....end testing on sym +c + return +c +c end of dsrmv +c + end + diff --git a/base/serial/csr/scsrmv3.f b/base/serial/csr/scsrmv3.f new file mode 100644 index 000000000..7d2c1f725 --- /dev/null +++ b/base/serial/csr/scsrmv3.f @@ -0,0 +1,530 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* DSRMV modified for SPARKER +* * +* FUNCTION: Driver for routines performing one of the sparse * +* matrix vector operations * +* * +* y = alpha*op(A)*x + beta*y * +* * +* where op(A) is one of: * +* * +* op(A) = A or op(A) = A' or * +* op(A) = lower or upper part of A * +* * +* alpha and beta are scalars. * +* The data structure of the matrix is related * +* to the scalar computer. * +* This is an internal routine called by: * +* DSMMV * +* * +* ENTRY-POINT = DSRMV * +* INPUT = * +* * +* * +* SYMBOLIC NAME: TRANS * +* POSITION: PARAMETER NO 1. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'T' 'L' 'U' * +* DESCRIPTION: Specifies the form of op(A) to be used in the * +* matrix vector multiplications as follows: * +* * +* TRANS = 'N' , op( A ) = A. * +* * +* TRANS = 'T' , op( A ) = A'. * +* * +* TRANS = 'L' or 'U', op( A ) = lower or * +* upper part of A * +* * +* SYMBOLIC NAME: DIAG * +* POSITION: PARAMETER NO 2. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'U' * +* DESCRIPTION: * +* Specifies whether or not the matrix A has * +* unit diagonal as follows: * +* * +* DIAG = 'N' A is not assumed * +* to have unit diagonal * +* * +* DIAG = 'U' A is assumed * +* to have unit diagonal. * +* * +* WARNING: it is the caller's responsibility * +* to ensure that if the matrix has unit * +* diagonal, there are no elements of the * +* diagonal are stored in the arrays AS and JA. * +* * +* SYMBOLIC NAME: M * +* POSITION: PARAMETER NO 3. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: M >= 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE SCSRMV3(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + + BETA,Y,LDY, WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + integer nb + parameter (nb=3) +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER M, N,LWORK,IERROR,ldx,ldy + CHARACTER DIAG, TRANS +C .. Array Arguments .. + real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) + INTEGER IA(*), JA(*) +C .. Local Scalars .. + real(psb_dpk_) ACC(nb) + INTEGER I, J, K, NCOLA, NROWA + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + IERROR = 0 + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) +C + if ( .not. tra) then + nrowa = m + ncola = n + else if (tra) then + nrowa = n + ncola = m + end if !(....tra) + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do i = 1, m + y(i,1:nb) = szero + enddo + else + do 20 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 20 continue + endif + return + end if + +c + if (sym) then + if (uni) then +c +c ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + if (beta.ne.szero) then + do i = 1, m +C +C Product for diagonal elements +c + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + enddo + else + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +C Product for other elements + do 80 i = 1, m + acc = szero + do 60 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 60 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 80 continue +C + else if ( .not. uni) then +C +C Check if matrix is lower or upper +C + if (psb_toupper(trans).eq.'L') then +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + if (beta.ne.szero) then + do 100 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 100 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 140 i = 1, m + acc = szero + do 120 j = ia(i), ia(i+1) - 1 ! it was -2 + K = ja(j) +C +C To be optimized +C + if (k.ne.i) then !for symmetric element + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 120 continue + + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 140 continue + else ! ....Trans<>L +C +C UPPER CASE +C ....OK!! +C + if (beta.ne.szero) then + do 160 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 160 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 200 i = 1, m + acc = szero + do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 + k = ja(j) +C +C To be optimized +C + if (k.ne.i) then + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 180 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 200 continue + end if ! ......TRANS=='L' + end if ! ......Not UNI +c + else if ( .not. tra) then !......NOT SYM + + if ( .not. uni) then +C +C .......General Not Unit, No Traspose +C + + if (beta == szero) then + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + enddo + + endif + + else if (beta==sone) then + + if (alpha==sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + y(i,1:nb) + enddo + endif + + else if (beta==-sone) then + + if (alpha==sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc - y(i,1:nb) + enddo + endif + else + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + beta*y(i,1:nb) + enddo + endif + end if +c + else if (uni) then +c + if (beta.ne.szero) then + do 280 i = 1, m + acc(1:nb) = szero + do 260 j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + 260 continue + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) + 280 continue + else !(beta.eq.szero) + do i = 1, m + acc(1:nb) = szero + do j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + enddo + endif + end if !....End Testing on UNI +C + else if (tra) then !....Else on SYM (swapped M and N) +C + if ( .not. uni) then +c + if (beta.ne.szero) then + do 300 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 300 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = szero + enddo + endif +c + else if (uni) then +c + + if (beta.ne.szero) then + do 320 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + 320 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +c + end if !....UNI +C + if (alpha.eq.sone) then +c + do 360 i = 1, n + do 340 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) + 340 continue + 360 continue +c + else if (alpha.eq.-sone) then +c + do 400 i = 1, n + do 380 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) + 380 continue + 400 continue +c + else !.....Else on TRA +C +C This work array is used for efficiency +C + if (lwork.lt.n) then + ierror = 60 + work(1) = dble(n) + return + endif +c$$$ do 420 i = 1, n +c$$$ work(i) = alpha*x(i,1:4) +c$$$ 420 continue +c$$$C +c$$$ DO 460 I = 1, n +c$$$ DO 440 J = IA(I), IA(I+1) - 1 +c$$$ K = JA(J) +c$$$ Y(K) = Y(K) + AS(J)*WORK(I) +c$$$ 440 CONTINUE +c$$$ 460 CONTINUE +c + end if !.....end testing on alpha + + end if !.....end testing on sym +c + return +c +c end of dsrmv +c + end + diff --git a/base/serial/csr/scsrmv4.f b/base/serial/csr/scsrmv4.f new file mode 100644 index 000000000..0952832ba --- /dev/null +++ b/base/serial/csr/scsrmv4.f @@ -0,0 +1,530 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* DSRMV modified for SPARKER +* * +* FUNCTION: Driver for routines performing one of the sparse * +* matrix vector operations * +* * +* y = alpha*op(A)*x + beta*y * +* * +* where op(A) is one of: * +* * +* op(A) = A or op(A) = A' or * +* op(A) = lower or upper part of A * +* * +* alpha and beta are scalars. * +* The data structure of the matrix is related * +* to the scalar computer. * +* This is an internal routine called by: * +* DSMMV * +* * +* ENTRY-POINT = DSRMV * +* INPUT = * +* * +* * +* SYMBOLIC NAME: TRANS * +* POSITION: PARAMETER NO 1. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'T' 'L' 'U' * +* DESCRIPTION: Specifies the form of op(A) to be used in the * +* matrix vector multiplications as follows: * +* * +* TRANS = 'N' , op( A ) = A. * +* * +* TRANS = 'T' , op( A ) = A'. * +* * +* TRANS = 'L' or 'U', op( A ) = lower or * +* upper part of A * +* * +* SYMBOLIC NAME: DIAG * +* POSITION: PARAMETER NO 2. * +* ATTRIBUTES: CHARACTER*1 * +* VALUES: 'N' 'U' * +* DESCRIPTION: * +* Specifies whether or not the matrix A has * +* unit diagonal as follows: * +* * +* DIAG = 'N' A is not assumed * +* to have unit diagonal * +* * +* DIAG = 'U' A is assumed * +* to have unit diagonal. * +* * +* WARNING: it is the caller's responsibility * +* to ensure that if the matrix has unit * +* diagonal, there are no elements of the * +* diagonal are stored in the arrays AS and JA. * +* * +* SYMBOLIC NAME: M * +* POSITION: PARAMETER NO 3. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: M >= 0 * +* DESCRIPTION: Number of rows of the matrix op(A). * +* * +* SYMBOLIC NAME: N * +* POSITION: PARAMETER NO 4. * +* ATTRIBUTES: INTEGER*4. * +* VALUES: N >= 0 * +* DESCRIPTION: Number of columns of the matrix op(A) * +* * +* SYMBOLIC NAME: ALPHA * +* POSITION: PARAMETER NO 5. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar alpha. * +* * +* * +* SYMBOLIC NAME: AS * +* POSITION: PARAMETER NO 6. * +* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * +* VALUES: ANY * +* DESCRIPTION: Array containing the non zero coefficients of * +* the sparse matrix op(A). * +* * +* SYMBOLIC NAME: JA * +* POSITION: PARAMETER NO 7. * +* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * +* VALUES: 0 < JA(I) <= M * +* DESCRIPTION: Array containing the column number of the * +* nonzero coefficients stored in array AS. * +* * +* SYMBOLIC NAME: IA * +* POSITION: PARAMETER NO 8. * +* ATTRIBUTES: INTEGER*4: ARRAY(*) * +* VALUES: IA(I) > 0 * +* DESCRIPTION: Contains the pointers for the beginning of * +* each rows. * +* * +* * +* SYMBOLIC NAME: X * +* POSITION: PARAMETER NO 9. * +* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* multiplied by the matrix A. * +* * +* SYMBOLIC NAME: BETA * +* POSITION: PARAMETER NO 10. * +* ATTRIBUTES: REAL*8. * +* VALUES: any. * +* DESCRIPTION: Specifies the scalar beta. * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector to be * +* updated by the matrix-vector multiplication. * +* * +* SYMBOLIC NAME: WORK * +* POSITION: PARAMETER NO 12. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Work area available to the program. It is used * +* only when TRANS = 'T'. * +* * +* OUTPUT = * +* * +* * +* SYMBOLIC NAME: Y * +* POSITION: PARAMETER NO 11. * +* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * +* VALUES: any. * +* DESCRIPTION: Contains the values of the vector * +* updated by the matrix-vector multiplication. * +* * +* * +*********************************************************************** + SUBROUTINE SCSRMV4(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, + + BETA,Y,LDY, WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + integer nb + parameter (nb=4) +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER M, N,LWORK,IERROR,ldx,ldy + CHARACTER DIAG, TRANS +C .. Array Arguments .. + real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) + INTEGER IA(*), JA(*) +C .. Local Scalars .. + real(psb_dpk_) ACC(nb) + INTEGER I, J, K, NCOLA, NROWA + LOGICAL SYM, TRA, UNI +C .. Executable Statements .. +C + IERROR = 0 + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + +C Symmetric matrix upper or lower + SYM = ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) +C + if ( .not. tra) then + nrowa = m + ncola = n + else if (tra) then + nrowa = n + ncola = m + end if !(....tra) + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do i = 1, m + y(i,1:nb) = szero + enddo + else + do 20 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 20 continue + endif + return + end if + +c + if (sym) then + if (uni) then +c +c ......Symmetric with unitary diagonal....... +C ....OK!! +C To be optimized + + if (beta.ne.szero) then + do i = 1, m +C +C Product for diagonal elements +c + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + enddo + else + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +C Product for other elements + do 80 i = 1, m + acc = szero + do 60 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 60 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 80 continue +C + else if ( .not. uni) then +C +C Check if matrix is lower or upper +C + if (psb_toupper(trans).eq.'L') then +C +C LOWER CASE: diagonal element is the last element of row +C ....OK! + + if (beta.ne.szero) then + do 100 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 100 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 140 i = 1, m + acc = szero + do 120 j = ia(i), ia(i+1) - 1 ! it was -2 + K = ja(j) +C +C To be optimized +C + if (k.ne.i) then !for symmetric element + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 120 continue + + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 140 continue + else ! ....Trans<>L +C +C UPPER CASE +C ....OK!! +C + if (beta.ne.szero) then + do 160 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 160 continue + else + do i = 1, m + y(i,1:nb) = szero + enddo + endif + + do 200 i = 1, m + acc = szero + do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 + k = ja(j) +C +C To be optimized +C + if (k.ne.i) then + y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) + endif + acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) + 180 continue + y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) + 200 continue + end if ! ......TRANS=='L' + end if ! ......Not UNI +c + else if ( .not. tra) then !......NOT SYM + + if ( .not. uni) then +C +C .......General Not Unit, No Traspose +C + + if (beta == szero) then + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + enddo + + endif + + else if (beta==sone) then + + if (alpha==sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + y(i,1:nb) + enddo + endif + + else if (beta==-sone) then + + if (alpha==sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else if (alpha==-sone) then + do i = 1, m + acc = -y(i,1:nb) + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc - y(i,1:nb) + enddo + endif + else + if (alpha==sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else if (alpha==-sone) then + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc - as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = acc + beta*y(i,1:nb) + enddo + else + do i = 1, m + acc = szero + do j = ia(i), ia(i+1) - 1 + acc = acc + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*acc + beta*y(i,1:nb) + enddo + endif + end if +c + else if (uni) then +c + if (beta.ne.szero) then + do 280 i = 1, m + acc(1:nb) = szero + do 260 j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + 260 continue + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) + 280 continue + else !(beta.eq.szero) + do i = 1, m + acc(1:nb) = szero + do j = ia(i), ia(i+1) - 1 + acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) + enddo + y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + enddo + endif + end if !....End Testing on UNI +C + else if (tra) then !....Else on SYM (swapped M and N) +C + if ( .not. uni) then +c + if (beta.ne.szero) then + do 300 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + 300 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = szero + enddo + endif +c + else if (uni) then +c + + if (beta.ne.szero) then + do 320 i = 1, m + y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) + 320 continue + else !(BETA.EQ.SZERO) + do i = 1, m + y(i,1:nb) = alpha*x(i,1:nb) + enddo + endif + +c + end if !....UNI +C + if (alpha.eq.sone) then +c + do 360 i = 1, n + do 340 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) + 340 continue + 360 continue +c + else if (alpha.eq.-sone) then +c + do 400 i = 1, n + do 380 j = ia(i), ia(i+1) - 1 + k = ja(j) + y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) + 380 continue + 400 continue +c + else !.....Else on TRA +C +C This work array is used for efficiency +C + if (lwork.lt.n) then + ierror = 60 + work(1) = dble(n) + return + endif +c$$$ do 420 i = 1, n +c$$$ work(i) = alpha*x(i,1:4) +c$$$ 420 continue +c$$$C +c$$$ DO 460 I = 1, n +c$$$ DO 440 J = IA(I), IA(I+1) - 1 +c$$$ K = JA(J) +c$$$ Y(K) = Y(K) + AS(J)*WORK(I) +c$$$ 440 CONTINUE +c$$$ 460 CONTINUE +c + end if !.....end testing on alpha + + end if !.....end testing on sym +c + return +c +c end of dsrmv +c + end + diff --git a/base/serial/csr/scsrsm.f b/base/serial/csr/scsrsm.f new file mode 100644 index 000000000..b29a08631 --- /dev/null +++ b/base/serial/csr/scsrsm.f @@ -0,0 +1,123 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, + * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + real(psb_spk_) ALPHA, BETA + INTEGER LDB, LDC, LWORK, M, N, IERROR + CHARACTER UNITD, TRANST + real(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IA(*), JA(*) + CHARACTER DESCRA*11 + INTEGER I, K + CHARACTER DIAG, UPLO +C .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5), err_Act + + NAME = 'DCSRSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + int_Val(1)=0 + UPLO = '?' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' + IF (UPLO.EQ.'?') THEN + int_val(1) = 7 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' + IF(UNITD.EQ.'B') THEN + IERROR=5 + int_val(1) = 4 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + IF (psb_toupper(UNITD).EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE + END IF + if ((alpha.ne.1.d0) .or.(beta .ne.0.0d0)) then + if (lwork .lt. m) then + int_val(1) = 17 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + DO I = 1, N + CALL SCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) + do k=1,m + c(k,i) = beta*c(k,i) + alpha*work(k) + enddo + enddo + + else + DO 60 I = 1, N + CALL SCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),C(1,I)) + 60 CONTINUE + endif + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (UNITD.EQ.'L') THEN + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/csr/scsrsv.f b/base/serial/csr/scsrsv.f new file mode 100644 index 000000000..3c0871d62 --- /dev/null +++ b/base/serial/csr/scsrsv.f @@ -0,0 +1,133 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCSRSV(UPLO,TRANS,DIAG,N,AS,JA,IA,B,X,IERROR) + use psb_const_mod + use psb_string_mod + real(psb_spk_) ZERO + PARAMETER (ZERO=0.0E0) + INTEGER N, IERROR + CHARACTER DIAG, TRANS, UPLO + real(psb_spk_) AS(*), B(*), X(*) + INTEGER IA(*), JA(*) + real(psb_spk_) ACC + INTEGER I, J, K + LOGICAL LOW, TRA, UNI + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + LOW = (psb_toupper(UPLO).EQ.'L') + IF ( .NOT. TRA) THEN + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 40 I = 1, N + ACC = ZERO + DO 20 J = IA(I), IA(I+1) - 2 + ACC = ACC + AS(J)*X(JA(J)) + 20 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I+1)-1) + 40 CONTINUE + ELSE IF (UNI) THEN + DO 80 I = 1, N + ACC = ZERO + DO 60 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 60 CONTINUE + X(I) = B(I) - ACC + 80 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 120 I = N, 1, -1 + ACC = ZERO + DO 100 J = IA(I) + 1, IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 100 CONTINUE + X(I) = (B(I)-ACC)/AS(IA(I)) + 120 CONTINUE + ELSE IF (UNI) THEN + DO 160 I = N, 1, -1 + ACC = ZERO + DO 140 J = IA(I), IA(I+1) - 1 + ACC = ACC + AS(J)*X(JA(J)) + 140 CONTINUE + X(I) = B(I) - ACC + 160 CONTINUE + END IF + END IF + ELSE IF (TRA) THEN + DO 180 I = 1, N + X(I) = B(I) + 180 CONTINUE + IF (LOW) THEN + IF ( .NOT. UNI) THEN + DO 220 I = N, 1, -1 + X(I) = X(I)/AS(IA(I+1)-1) + ACC = X(I) + DO 200 J = IA(I), IA(I+1) - 2 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 200 CONTINUE + 220 CONTINUE + ELSE IF (UNI) THEN + DO 260 I = N, 1, -1 + ACC = X(I) + DO 240 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 240 CONTINUE + 260 CONTINUE + END IF + ELSE IF ( .NOT. LOW) THEN + IF ( .NOT. UNI) THEN + DO 300 I = 1, N + X(I) = X(I)/AS(IA(I)) + ACC = X(I) + DO 280 J = IA(I) + 1, IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 280 CONTINUE + 300 CONTINUE + ELSE IF (UNI) THEN + DO 340 I = 1, N + ACC = X(I) + DO 320 J = IA(I), IA(I+1) - 1 + K = JA(J) + X(K) = X(K) - AS(J)*ACC + 320 CONTINUE + 340 CONTINUE + END IF + END IF + END IF + RETURN + END + + + diff --git a/base/serial/csr/zcrnrmi.f b/base/serial/csr/zcrnrmi.f index 629003473..02f92a91f 100644 --- a/base/serial/csr/zcrnrmi.f +++ b/base/serial/csr/zcrnrmi.f @@ -29,7 +29,8 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE C POSSIBILITY OF SUCH DAMAGE. C FUNCTION ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,IERROR) + & INFOA,IERROR) + use psb_const_mod use psb_const_mod IMPLICIT NONE real(psb_dpk_) zcrnrmi @@ -46,8 +47,8 @@ C .. Local scalars .. NRMI = 0.D0 DO I = 1, M - SUM = 0.D0 - DO J = IA2(I), IA2(I+1)-1 + SUM = 0.D0 + DO J = IA2(I), IA2(I+1)-1 C C .. definition coerent abs C @@ -55,9 +56,9 @@ C SUM = SUM + ABS(A(J)) C C .. essl_way abs C - SUM = SUM + ABS(DBLE(A(J))) + ABS(AIMAG(A(J))) - ENDDO - NRMI = MAX(NRMI, SUM) + SUM = SUM + ABS(DBLE(A(J))) + ABS(AIMAG(A(J))) + ENDDO + NRMI = MAX(NRMI, SUM) ENDDO ZCRNRMI = NRMI diff --git a/base/serial/csr/zcsrck.f b/base/serial/csr/zcsrck.f index 5be40bca4..77961784c 100644 --- a/base/serial/csr/zcsrck.f +++ b/base/serial/csr/zcsrck.f @@ -85,10 +85,10 @@ C IERROR - INTEGER C On exit specify the error code. C IERROR = 0 no errors C IERROR > 0 error in integrity check - - SUBROUTINE ZCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, - + WORK,LWORK,IERROR) + + WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod use psb_const_mod IMPLICIT NONE C .. Scalar Arguments .. @@ -109,52 +109,57 @@ C Check #1: Character descriptor have valid values C IERROR = 0 - IF ((DESCRA(1:1).NE.'G').AND.(DESCRA(1:1).NE.'S').AND. - & (DESCRA(1:1).NE.'H').AND.(DESCRA(1:1).NE.'T').AND. - & (DESCRA(1:1).NE.'A').AND.(DESCRA(1:1).NE.'D')) THEN - IERROR = 11 - GOTO 9999 + IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. + + (psb_toupper(DESCRA(1:1)).NE.'S').AND. + + (psb_toupper(DESCRA(1:1)).NE.'H').AND. + + (psb_toupper(DESCRA(1:1)).NE.'T').AND. + + (psb_toupper(DESCRA(1:1)).NE.'A').AND. + + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN + IERROR = 11 + GOTO 9999 END IF - IF ((DESCRA(2:2).NE.'U').AND.(DESCRA(2:2).NE.'L')) THEN - IERROR = 12 - GOTO 9999 + IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. + + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN + IERROR = 12 + GOTO 9999 END IF - IF ((DESCRA(3:3).NE.'U').AND.(DESCRA(3:3).NE.'N')) THEN - IERROR = 13 - GOTO 9999 + IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. + + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN + IERROR = 13 + GOTO 9999 END IF C C Check #2: Pointers have non decreasing order C IF (IA2(1).LE.0) THEN - IERROR = 14 - GOTO 9999 + IERROR = 14 + GOTO 9999 ENDIF NROW = 0 DO 10 I = 1, M - IF (IA2(I) .GT. IA2(I+1)) THEN - NROW = NROW + 1 - END IF + IF (IA2(I) .GT. IA2(I+1)) THEN + NROW = NROW + 1 + END IF 10 CONTINUE IF (NROW .GT. 0) THEN - IERROR = 15 - GOTO 9999 + IERROR = 15 + GOTO 9999 END IF C C Check #3: Indices are within problem dimension C NIND = 0 DO 20 I = 1, M - DO 30 J = IA2(I), IA2(I+1) - 1 - IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN - NIND = NIND + 1 - END IF - 30 CONTINUE + DO 30 J = IA2(I), IA2(I+1) - 1 + IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN + NIND = NIND + 1 + END IF + 30 CONTINUE 20 CONTINUE IF (NIND .GT. 0) THEN - IERROR = 16 - GOTO 9999 + IERROR = 16 + GOTO 9999 END IF 9999 CONTINUE RETURN diff --git a/base/serial/csr/zcsrmm.f b/base/serial/csr/zcsrmm.f index 02e99ea1c..c9f9d9dc9 100644 --- a/base/serial/csr/zcsrmm.f +++ b/base/serial/csr/zcsrmm.f @@ -135,8 +135,9 @@ C On entry LWORK specifies the dimension of WORK C Unchanged on exit. C SUBROUTINE ZCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) + * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) use psb_const_mod + use psb_string_mod C .. Scalar Arguments .. complex(psb_dpk_) ALPHA, BETA INTEGER K, LDB, LDC, M, N, LWORK @@ -160,54 +161,56 @@ C .. Why to loose TRANSA for H, T, A matrices? C TRANS = TRANSA C - IF ((DESCRA(1:1).EQ.'S').AND.(DESCRA(2:2).EQ.'U')) THEN - IF (TRANSA.EQ.'C') THEN - TRANS = 'V' - ELSE - TRANS = 'U' - ENDIF + IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. + + (psb_toupper(DESCRA(2:2)).EQ.'U')) THEN + IF (psb_toupper(TRANSA).EQ.'C') THEN + TRANS = 'V' + ELSE + TRANS = 'U' + ENDIF ENDIF - IF ((DESCRA(1:1).EQ.'S').AND.(DESCRA(2:2).EQ.'L')) THEN - IF (TRANSA.EQ.'C') THEN - TRANS = 'M' - ELSE - TRANS = 'L' - ENDIF + IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. + + (psb_toupper(DESCRA(2:2)).EQ.'L')) THEN + IF (psb_toupper(TRANSA).EQ.'C') THEN + TRANS = 'M' + ELSE + TRANS = 'L' + ENDIF ENDIF C .. Diagonal matrix - IF (DESCRA(1:1).EQ.'D') THEN + IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN C .. Diagonal matrix with unitary values - IF (DESCRA(3:3).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - RETURN + IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN + DO 40 I = 1, K + DO 20 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) + 20 CONTINUE + 40 CONTINUE + RETURN C .. Diagonal matrix to be conjugated - ELSE IF (TRANSA.EQ.'C') THEN - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + CONJG(AR(J)) * B(J,I) - 60 CONTINUE - 80 CONTINUE - RETURN + ELSE IF (psb_toupper(TRANSA).EQ.'C') THEN + DO 80 I = 1, K + DO 60 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA * + + CONJG(AR(J)) * B(J,I) + 60 CONTINUE + 80 CONTINUE + RETURN C .. Generic diagonal matrix - ELSE - DO 91 I = 1, K - DO 90 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + AR(J) * B(J,I) - 90 CONTINUE - 91 CONTINUE - RETURN - ENDIF + ELSE + DO 91 I = 1, K + DO 90 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA * + + AR(J) * B(J,I) + 90 CONTINUE + 91 CONTINUE + RETURN + ENDIF END IF C - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' C C C = A*B or C=A'*B or C=conjug(A')*B C @@ -226,9 +229,9 @@ C 'N': Generic diagonal. C DO 100 I = 1, K - CALL ZSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,I), - + BETA,C(1,I),WORK) - 100 CONTINUE + CALL ZSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,I), + + BETA,C(1,I),WORK) + 100 CONTINUE RETURN END diff --git a/base/serial/csr/zcsrrws.f b/base/serial/csr/zcsrrws.f index d3d5f3d97..902988f4d 100644 --- a/base/serial/csr/zcsrrws.f +++ b/base/serial/csr/zcsrrws.f @@ -31,6 +31,7 @@ C SUBROUTINE ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, & INFOA,ROWSUM,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER M,N, IERROR @@ -43,7 +44,7 @@ C .. Local scalars .. INTEGER I, J real(psb_dpk_) SUM - IF (TRANS.EQ.'N') THEN + IF (psb_toupper(TRANS).EQ.'N') THEN DO I = 1, M ROWSUM(I) = (0.0D0, 0.0D0) DO J = IA2(I), IA2(I + 1) - 1 @@ -51,7 +52,8 @@ C .. Local scalars .. + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) ENDDO ENDDO - ELSE IF ((TRANS.EQ.'T').OR.(TRANS.EQ.'C')) THEN + ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. + + (psb_toupper(TRANS).EQ.'C')) THEN DO J = 1, N ROWSUM(J) = (0.0D0, 0.0D0) ENDDO diff --git a/base/serial/csr/zcsrsm.f b/base/serial/csr/zcsrsm.f index c3d05a871..72a663a33 100644 --- a/base/serial/csr/zcsrsm.f +++ b/base/serial/csr/zcsrsm.f @@ -30,8 +30,9 @@ C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE ZCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK) + * B,LDB,BETA,C,LDC,WORK,LWORK) use psb_const_mod + use psb_string_mod complex(psb_dpk_) ALPHA, BETA INTEGER LDB, LDC, LWORK, M, N CHARACTER UNITD, TRANST @@ -45,33 +46,35 @@ C .. Local Arrays .. CHARACTER*20 NAME INTEGER INT_VAL(5),err_act - NAME = 'DCSRSM\0' + NAME = 'ZCSRSM\0' IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) int_Val(1)=0 UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + int_val(1) = 7 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' + IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' + IF(psb_toupper(UNITD).EQ.'B') THEN + IERROR=5 + int_val(1) = 4 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE + IF (psb_toupper(UNITD).EQ.'R') THEN + DO 40 I = 1, N + DO 20 K = 1, M + B(K,I) = B(K,I)*D(K) + 20 CONTINUE + 40 CONTINUE END IF if ((alpha.ne.(1.d0,0.d0)) .or.(beta .ne.(0.0d0,0.d0))) then @@ -93,11 +96,11 @@ C .. Local Arrays .. enddo endif IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE + DO 45 I = 1, N + DO 25 K = 1, M + C(K,I) = C(K,I)*D(K) + 25 CONTINUE + 45 CONTINUE END IF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -107,8 +110,8 @@ C .. Local Arrays .. 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/csr/zsrmv.f b/base/serial/csr/zsrmv.f index 0357bf233..87a0eb23b 100644 --- a/base/serial/csr/zsrmv.f +++ b/base/serial/csr/zsrmv.f @@ -179,6 +179,7 @@ C C SUBROUTINE ZSRMV (TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y,WORK) use psb_const_mod + use psb_string_mod C .. Parameters .. complex(psb_dpk_) ONE, ZERO PARAMETER (ONE=(1.0D0, 0.0D0), ZERO=(0.0D0, 0.0D0)) @@ -195,15 +196,17 @@ C .. Local Scalars .. LOGICAL SYM, TRA, COTRA, UNI C .. Executable Statements .. C - UNI = DIAG.EQ.'U' + UNI = psb_toupper(DIAG).EQ.'U' C C .. Not simmetric matrix - TRA = TRANS.EQ.'T' - COTRA = TRANS.EQ.'C' + TRA = psb_toupper(TRANS).EQ.'T' + COTRA = psb_toupper(TRANS).EQ.'C' C .. Symmetric matrix upper or lower - SYM = (TRANS.EQ.'L').OR.(TRANS.EQ.'U').OR. - + (TRANS.EQ.'M').OR.(TRANS.EQ.'V') + SYM = (psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U').OR. + + (psb_toupper(TRANS).EQ.'M').OR. + + (psb_toupper(TRANS).EQ.'V') C IF (.NOT.(TRA.OR.COTRA)) THEN NROWA = M @@ -248,7 +251,8 @@ C ENDIF C Product for other elements - IF ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) THEN + IF ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'U')) THEN DO 80 I = 1, M ACC = ZERO DO 60 J = IA(I), IA(I+1) - 1 @@ -274,7 +278,8 @@ C C C Check if matrix is lower or upper C - IF ((TRANS.EQ.'L').OR.(TRANS.EQ.'M')) THEN + IF ((psb_toupper(TRANS).EQ.'L').OR. + + (psb_toupper(TRANS).EQ.'M')) THEN C C LOWER CASE: diagonal element is the last element of row C ....OK! @@ -289,7 +294,7 @@ C ....OK! ENDDO ENDIF - IF (TRANS.EQ.'L') THEN + IF (psb_toupper(TRANS).EQ.'L') THEN DO 140 I = 1, M ACC = ZERO DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 @@ -337,7 +342,7 @@ C Y(I) = ZERO ENDDO ENDIF - IF (TRANS.EQ.'U') THEN + IF (psb_toupper(TRANS).EQ.'U') THEN DO 200 I = 1, M ACC = ZERO DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 diff --git a/base/serial/csr/zsrsv.f b/base/serial/csr/zsrsv.f index da414aba2..6458e73f4 100644 --- a/base/serial/csr/zsrsv.f +++ b/base/serial/csr/zsrsv.f @@ -30,6 +30,7 @@ C POSSIBILITY OF SUCH DAMAGE. C SUBROUTINE ZSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X) use psb_const_mod + use psb_string_mod complex(psb_dpk_) ZERO PARAMETER (ZERO = (0.0D0, 0.0D0)) INTEGER N @@ -39,10 +40,10 @@ C complex(psb_dpk_) ACC INTEGER I, J, K LOGICAL LOW, TRA, COTRA, UNI - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - COTRA = (TRANS.EQ.'C') - LOW = (UPLO.EQ.'L') + UNI = (psb_toupper(DIAG).EQ.'U') + TRA = (psb_toupper(TRANS).EQ.'T') + COTRA = (psb_toupper(TRANS).EQ.'C') + LOW = (psb_toupper(UPLO).EQ.'L') IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN IF (LOW) THEN IF (.NOT.UNI) THEN diff --git a/base/serial/dp/Makefile b/base/serial/dp/Makefile index 972e21b84..6c47ea404 100644 --- a/base/serial/dp/Makefile +++ b/base/serial/dp/Makefile @@ -7,6 +7,8 @@ FOBJS = dcrcr.o dcrjd.o dgblock.o partition.o \ dgindex.o djadrp.o djadrp1.o dcsrrp.o dcsrp1.o check_dim.o \ Max_nnzero.o dcoco.o dcocr.o dcrco.o djdcox.o djdco.o dvtfg.o dgind_tri.o \ gen_block.o reordvn.o\ + scrjd.o scrco.o scrcr.o scocr.o scoco.o sgindex.o sgind_tri.o\ + ccoco.o ccocr.o ccrco.o ccrcr.o ccrjd.o cgindex.o cgind_tri.o\ zcoco.o zcocr.o zcrco.o zcrcr.o zcrjd.o zgindex.o zgind_tri.o # diff --git a/base/serial/dp/ccoco.f b/base/serial/dp/ccoco.f new file mode 100644 index 000000000..6e8805a50 --- /dev/null +++ b/base/serial/dp/ccoco.f @@ -0,0 +1,302 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +c covert matrix from COO format to COO format +c + subroutine ccoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, + * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, + * lia2n,aux,laux,ierror) + use psb_error_mod + use psb_const_mod + use psb_spmat_type + use psb_string_mod + implicit none + +c .. scalar arguments .. + integer larn, laux, lia1n, lia2n, + + m, n, ierror + character trans,unitd +c .. array arguments .. + complex(psb_spk_) :: ar(*), arn(*), d(*) + integer aux(0:laux-1) + integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), + * infon(*), p1(*), p2(*) + character descra*11, descrn*11 +c .. local scalars .. + integer ipx, ip1, ip2, check_flag, err_act + integer nnz, k, i, j, nzl, iret + integer elem_in, elem_out + logical scale + integer max_nnzero + integer :: debug_level, debug_unit +c .. local arrays .. + character*20 name + integer int_val(5) +c +c ...common variables... +c this flag describe the action to do + +c .. external subroutines .. + external max_nnzero +c .. executable statements .. +c + + name = 'ccoco' + ierror = 0 + call fcpsb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + + if (psb_toupper(trans).eq.'N') then + scale = (psb_toupper(unitd).eq.'L') ! meaningless + p1(1) = 0 + p2(1) = 0 + + call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),': on entry nnz laux ', + + nnz,laux,larn,lia1n,lia2n + endif + if (laux.lt.nnz+2) then + ierror = 60 + int_val(1) = 22 + int_val(2) = nnz+2 + int_val(3) = laux + else if (larn.lt.nnz) then + ierror = 60 + int_val(1) = 18 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia1n.lt.nnz) then + ierror = 60 + int_val(1) = 19 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia2n.lt.m+1) then + ierror = 60 + int_val(1) = 20 + int_val(2) = nnz+2 + int_val(3) = laux + endif + +c +c error handling +c + if(ierror.ne.0) then + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + end if + + if (psb_toupper(descra(1:1)).eq.'G') then +c +c sort COO data structure +c + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': first sort',nnz + do k=1, nnz + arn(k) = ar(k) + ia1n(k) = ia1(k) + ia2n(k) = ia2(k) + enddo + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': second sort' + + if ((lia2n.ge.(2*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 + enddo + ip1 = nnz+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ia2n(ip1+psb_ip2_) = ip2 + ia2n(ip1+psb_iflag_) = check_flag + ia2n(ip1+psb_nnzt_) = nnz + ia2n(ip1+psb_nnz_) = 0 + ia2n(ip1+psb_ichk_) = nnz+check_flag + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': build check :',ia2n(ip1+psb_nnzt_) + +c .... order with key ia1n ... + call msort_up(nnz,ia1n,aux,iret) + if (iret.eq.0) + + call creordvn3(nnz,arn,ia1n,ia2n,aux(ipx),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 creordvn3(nzl,arn(i),ia1n(i),ia2n(i), + + aux(ipx+i-1),aux) + i = j + enddo + + ia2n(ip2+aux(ipx+1-1)-1) = 1 + +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + 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 first duplicated element ... + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo + + else + +c .... order with key ia1n ... + call msort_up(nnz,ia1n,aux,iret) + if (iret.eq.0) call creordvn(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 creordvn(nzl,arn(i),ia1n(i),ia2n(i), + + aux) + i = j + enddo +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + 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 first duplicated element ... + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo + endif + infon(psb_nnz_) = elem_out + infon(psb_srtd_) = psb_isrtdcoo_ + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': done rebuild COO',infon(1) + + else if (psb_toupper(descra(1:1)).eq.'S' .and. + + psb_toupper(descra(2:2)).eq.'U') then + + do 20 k = 1, m + p2(k) = k + 20 continue + + else if (psb_toupper(descra(1:1)).eq.'T' .and. + + psb_toupper(descra(2:2)).eq.'U') then + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + + else if (psb_toupper(descra(1:1)).eq.'T' .and. + + psb_toupper(descra(2:2)).eq.'L') then + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + end if +c + else if (psb_toupper(trans).ne.'N') then +c +c to do +c + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + end if + + call fcpsb_erractionrestore(err_act) + return + + 9999 continue + call fcpsb_erractionrestore(err_act) + + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif + + return + end diff --git a/base/serial/dp/ccocr.f b/base/serial/dp/ccocr.f new file mode 100644 index 000000000..aa6efc6d7 --- /dev/null +++ b/base/serial/dp/ccocr.f @@ -0,0 +1,516 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C Covert matrix from COO format to CSR Format +C Note: this never sets IP1 and P2! +C + SUBROUTINE CCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, + * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, + * LIAN2,AUX,LAUX,IERROR) + + use psb_const_mod + use psb_error_mod + use psb_spmat_type + use psb_string_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, + + N, IUPDUP, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + complex(psb_spk_) AR(*), ARN(*), D(*) + INTEGER AUX(0:LAUX-1) + INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), + * 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,regen_flag + logical scale + integer max_nnzero + integer, allocatable :: itmp(:) +c .. local arrays .. + character*20 name + integer int_val(5) + integer :: debug_level, debug_unit + +C +C ...Common variables... + +C .. External Subroutines .. + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + NAME = 'CCOCR' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) + + IF (psb_toupper(TRANS).EQ.'N') THEN + + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + P1(1) = 0 + P2(1) = 0 + nnz = info(1) + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),': On entry NNZ LAUX ', + + nnz,laux,larn,lian1,lian2 + endif + IF (LAUX.LT.NNZ+2) THEN + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ELSE IF (LARN.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NNZ + INT_VAL(3) = LARN + ELSE IF (LIAN1.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN1 + ELSE IF (LIAN2.LT.M+1) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = M+1 + INT_VAL(3) = LIAN2 + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + 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 (psb_toupper(descra(1:1)).EQ.'G') THEN +C +C Sort COO data structure +C + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': First sort',nnz + + 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 + enddo + ip1 = m+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ian2(ip1+psb_ip2_) = ip2 + ian2(ip1+psb_iflag_) = check_flag + ian2(ip1+psb_nnzt_) = nnz + ian2(ip1+psb_nnz_) = 0 + ian2(ip1+psb_ichk_) = nnz+check_flag + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': Build check :',ian2(ip1+psb_nnzt_) + +C .... Order with key IA ... + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) + + call creordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) + if (debug_level >= psb_debug_serial_) then + do i=1, nnz-1 + if (itmp(i).gt.itmp(i+1)) then + write(debug_unit,*) trim(name), + + 'Sorting error:',i,itmp(i),itmp(i+1) + endif + enddo + write(debug_unit,*) trim(name), + + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) + endif + +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 creordvn3(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, itmp(1) + ian2(row) = 1 + enddo + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': Rebuild CSR',ia(1),elem_csr + + 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 = 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) + ian2(ip2+aux(ipx+elem-1)-1) = elem_csr + 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) = 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) + 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 .... Order with key IA ... + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call creordvn(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 creordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + endif + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': Done Rebuild CSR', + + ian2(m+1),ia(elem) + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN + + do 20 k = 1, m + p2(k) = k + 20 continue + + else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call creordvn(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 creordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + + else if (psb_toupper(descra(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call creordvn(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 creordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': Done Rebuild CSR', + + ian2(m+1),ia(elem) + + + end if +c + else if (psb_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 + + call fcpsb_erractionrestore(err_act) + return + + 9999 continue + call fcpsb_erractionrestore(err_act) + + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif + + return + end diff --git a/base/serial/dp/ccrco.f b/base/serial/dp/ccrco.f new file mode 100644 index 000000000..7767eed67 --- /dev/null +++ b/base/serial/dp/ccrco.f @@ -0,0 +1,168 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, + * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, + * LIAN2,AUX,LAUX,IERROR) + + use psb_const_mod + use psb_spmat_type + use psb_string_mod + use psb_error_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + complex(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) + INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), + * INFON(*), IP1(*), IP2(*) + CHARACTER DESCRA*11, DESCRN*11 +C .. Local Scalars .. + INTEGER NNZ, K, ROW, J + INTEGER ELEM, ERR_ACT + LOGICAL SCALE + INTEGER MAX_NNZERO +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + integer :: debug_level, debug_unit +C .. External Subroutines .. + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + + NAME = 'CCRCO' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF (psb_toupper(TRANS).EQ.'N') THEN + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + IP1(1) = 0 + IP2(1) = 0 + NNZ = IA2(M+1)-1 + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': entry',m,n,nnz, + + ' : ',descra,' : ',descrn + + IF (LARN.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NNZ + INT_VAL(3) = LARN + ELSE IF (LIAN1.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN1 + ELSE IF (LIAN2.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN2 + ENDIF + + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN +C ... Construct COO Representation... + ELEM = 0 + + DO ROW = 1, M + DO J = IA2(ROW), IA2(ROW+1)-1 + ELEM = ELEM + 1 + IAN1(ELEM) = ROW + IAN2(ELEM) = IA1(J) + ARN(ELEM) = AR(J) + ENDDO + ENDDO + INFON(psb_nnz_) = elem + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': endloop',m,elem + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_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 + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN + +C + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') THEN + + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + END IF +C + ELSE IF (psb_toupper(TRANS).NE.'N') THEN +C +C TO DO +C + IERROR = 3021 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/dp/ccrcr.f b/base/serial/dp/ccrcr.f new file mode 100644 index 000000000..9f42e05a4 --- /dev/null +++ b/base/serial/dp/ccrcr.f @@ -0,0 +1,315 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE CCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, +C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, +C WORK,LWORK,IERROR) +C +C Purpose: CSR to CSR format conversion +C ======= +C +C Parameter: +C ========= +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine will convert +C matrix A or the transpose of A as follows: +C TRANS = 'N' -> convert matrix A +C TRANS = 'T' or 'C' -> convert A' (the transpose of A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') +C and number of rows of matrix H +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A (A') +C and number of columns of matrix H +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - DOUBLE PRECISION array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IP1 - INTEGER array of dimension (M) +C On exit IP1 specifies the row permutation of matrix AN +C (IP1(1) == 0 if no permutation). +C +C DESCRN - CHARACTER*1 array of DIMENSION (9) +C On exit DESCRN describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C AN - DOUBLE PRECISION array of DIMENSION (LAN) +C On exit AN specifies the values of the output sparse +C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN +C satisfying DSPDP memory requirements. +C +C IAN1 - INTEGER array of dimension (LIAN1) +C On exit IAN1 holds integer information on output sparse +C matrix. Actual information will depend on data format used. +C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 +C satisfying DSPDP memory requirements. +C +C IAN2 - INTEGER array of dimension (LIAN2) +C On exit IAN2 holds integer information on output sparse +C matrix. Actual information will depend on data format used. +C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 +C satisfying DSPDP memory requirements. +C +C INFON - INTEGER array of dimension (10) +C On exit can hold auxiliary information on output matrices +C formats or environment of subsequent calls. +C +C IP2 - INTEGER array of dimension (M) +C On exit IP2 specifies the column permutation of matrix AN +C (IP2(1) == 0 if no permutation). +C +C LAN - INTEGER +C On entry LAN specifies the dimension of AN +C LAN must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C LIAN1 - INTEGER +C On entry LH1 specifies the dimension of IAN1 +C LH1 must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C LIAN2 - INTEGER +C On entry LIAN2 specifies the dimension of IAN2 +C LIAN2 must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSPDP memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK must satisfy memory necessary for the data conversion. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 error +C +C + SUBROUTINE CCRCR(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_const_mod + use psb_string_mod + IMPLICIT NONE +C +C .. Scalar Arguments .. + INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR + CHARACTER TRANS, UNITD +C .. Array Arguments .. + complex(psb_spk_) A(*), AN(*), D(*), WORK(LWORK) + INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), + * 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) + +C .. Intrinsic Functions .. + INTRINSIC DBLE, DSQRT + +C .. Executable Statements .. +C + EXIT=.FALSE. + NAME = 'CCRCR' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) +C +C Check for argument errors +C + idescra=psb_toupper(descra) + IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .NE. 'B')).OR. + & (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR. + + (IDESCRA(3:3).EQ.'U'))) .OR. + + psb_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) = REAL(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 + ENDIF + IF(LIAN2.LT.(M+1)) THEN + IF (LAN.LE.0) THEN + EXIT=.TRUE. + IAN2(1) = M+1 + ELSE + IERROR = 23 + ENDIF + ENDIF + IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (psb_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 + ENDIF +C +C Error handling +C + 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) = IDESCRA(1:3) + + IP1(1)=0 + IP2(1)=0 +C +C Compute output matrix +C + DO 20 I = 1, M+1 + IAN2(I) = IA2(I) + 20 CONTINUE + IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) THEN + DO 30 I = 1, M + WORK(I) = REAL(SQRT(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 (psb_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 (psb_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 (psb_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 + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + + diff --git a/base/serial/dp/ccrjd.f b/base/serial/dp/ccrjd.f new file mode 100644 index 000000000..59d87c3d4 --- /dev/null +++ b/base/serial/dp/ccrjd.f @@ -0,0 +1,315 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, + * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, + * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) +C +C Purpose +C ======= +C +C CCRJD converts a CSR matrix into a Jagged Diagonal. +C +C +C Notes +C ===== +C +C Parameters +C ========== +C +C TRANS Whether the transpose should be converted. +C +C M,N Size of input matrix A +C +C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight +C D(*) +C +C DESCRA Input matrix A. +C AR,IA1, +C IA2,INFO +C +C DESCRN Output matrix in JAD format +C ARN,IAN1 +C IAN2,INFON, IP1, IP2 +C + use psb_const_mod + use psb_spmat_type + use psb_string_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, + * SIZE_REQ, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + complex(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) + INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), + * INFON(*), IP1(*), IP2(*) + CHARACTER DESCRA*11, DESCRN*11 +C .. Local Scalars .. + INTEGER IOFF, ISTROW, NJA, NZ, PIA, + + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT + LOGICAL SCALE + CHARACTER UPLO + INTEGER MAX_NNZERO +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5), IERRV(5) + +C .. External Subroutines .. + EXTERNAL DVTFG + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + NAME = 'CCRJD' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (LAUX.LT.4) THEN + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = 4 + INT_VAL(3) = LAUX + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IF (psb_toupper(TRANS).EQ.'N') THEN +C + NJA = 3*M + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + IOFF = 5 +C +C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX +C + PNG = IOFF + PIA = PNG + 1 + PJA = PIA + 3*(M+2) + + IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN + +C +C CHECK ON DIMENSION OF IAN2 AND AUX +C + MAX_NG = M/PSB_MINJDROWS_+1 + + IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN +C ... If I haven't sufficent memory to compute NG in IAN2 ... + IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN +C ... If I haven't sufficent memory to compute NG in AUX ... + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 + INT_VAL(3) = LAUX + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ELSE +C ... I have sufficent memory to compute NG in AUX ... + CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX) + CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + IF (IERRV(1).NE.0) THEN + SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) + + GOTO 9998 + ENDIF + ENDIF + END IF + + NZ = IA2(M+1) - 1 +C +C ... Initialize Permutation Matrix ... +C + DO 10 K = 1, M + IP1(K) = K + 10 CONTINUE + + IP2(1) = 0 + + CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX) + + PJA = PIA + 3*(IAN2(PNG)+1) +C +C CHECK FOR ARRAY DIMENSIONS +C + CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + IF (IERRV(1) .NE.0) THEN + SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) + GOTO 9998 + ENDIF + + LJA = LIAN2-PJA + CALL CGINDEX(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 + ENDIF + + DESCRN(1:1) = 'G' + DESCRN(2:2) = 'U' + DESCRN(3:3) = 'N' + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN +C + ISTROW = 1 + NZ = 2*(IA2(M+1)-1) - M +C +C CHECK ON DIMENSION OF IAN1 AND ARN +C + IF (NZ .GT. LIAN1) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NZ + INT_VAL(3) = LAUX + LIAN1 = NZ + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (NZ .GT. LARN) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NZ + INT_VAL(3) = LAUX + LIAN1 = NZ + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + DO 20 K = 1, M + IP2(K) = K + 20 CONTINUE + +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 (psb_toupper(DESCRA(1:1)).EQ.'T') THEN +C +C Only unit diagonal so far for triangular matrices. +C + + + IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN + IERROR=3022 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + UPLO = DESCRA(2:2) + NZ = IA2(M+1) - 1 +C +C ...Compute levels... +C Each level correspond to a block +C IAN1 is used as a work area + + CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, + + AUX,AUX(M+1),AUX(2*(M+1))) + +C Generate IA(1,*) + DO K = 1, IAN2(PNG)+1 + IAN2(PIA+3*(K-1)) = IAN1(K) + ENDDO + + CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) + + PJA = PIA + 3*(IAN2(PNG)+1) + +C +C CHECK FOR ARRAY DIMENSIONS +C + + CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + + IF (IERRV(1).NE.0) THEN + size_req = max(ierrv(2),ierrv(3),ierrv(4)) +c$$$ write(0,*) "error 2",ierrv(1) + GOTO 9998 + endif + LJA = LIAN2-PJA + + CALL CGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), + + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX, IERROR) + + IF (IERROR.NE.0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + DESCRN(1:1) = 'T' + DESCRN(2:3) = psb_toupper(DESCRA(2:3)) + + END IF +C +C SET THE OUTPUT PARAMETER +C + IAN2(1) = PNG + IAN2(2) = PIA + IAN2(3) = PJA + LARN = NZ + LIAN1 = NZ + LIAN2 = 3*M + 10 + LAUX2 = 4*M + 2 +C + ELSE IF (psb_toupper(TRANS).NE.'N') THEN +C +C TO BE DONE +C + IERROR = 3021 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + + 9998 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/dp/cgind_tri.f b/base/serial/dp/cgind_tri.f new file mode 100644 index 000000000..fa3bc9719 --- /dev/null +++ b/base/serial/dp/cgind_tri.f @@ -0,0 +1,237 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, + + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) + + use psb_const_mod + IMPLICIT NONE + +C ... Scalar arguments ... + + INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR + +C ... Array arguments ... + + complex(psb_spk_) A(*), ARN(*), WORK(*) + INTEGER IA1(*), IA2(*), KA(*), + + IA(3,*), IPERM(M), JA(*) + +C .... Local scalars ... + INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, + + DIM_BLOCK, LIMIT, ERR_ACT + LOGICAL CSR +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + + NAME = 'CGIND_TRI\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + POINT_AR = 1 + POINT_JA = 0 + 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 + ENDIF + +C .... Invert Permutation Matrix... + IF (IPERM(1).NE.0) THEN + 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 +C ... If current block is not empty ... +C ... For each Column belonging to Block ... + 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 + +C ... If the current row is too short ... + 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 +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 + ENDIF + ENDDO + + IF (CSR) GOTO 998 + + 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 + + JA(POINT_JA) = POINT_AR + ENDDO + ENDDO + + IA(2,N_BLOCKS+1) = POINT_JA + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + diff --git a/base/serial/dp/cgindex.f b/base/serial/dp/cgindex.f new file mode 100644 index 000000000..43a3a0d13 --- /dev/null +++ b/base/serial/dp/cgindex.f @@ -0,0 +1,463 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CGINDEX(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 + IMPLICIT NONE + +C ... Scalar arguments ... + INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, + + SIZE_REQ,IERROR + +C ... Array arguments ... + + complex(psb_spk_) A(*), ARN(*) + INTEGER IA1(*), IA2(*), KA(*), + + 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, ix, regen_flag + LOGICAL CSR +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + + NAME = 'CGINDEX\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + 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 + ENDIF + + 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 + ENDIF + + 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 + + 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 + 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) +c$$$ write(0,*) 'CGINDEX: 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 +C ... If current block is not empty ... +C ... For each Column belonging to Block ... + 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 + +C ... If the current row is too short ... + 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 + + 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 + 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 + +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 + + 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 + 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.) +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 ... If the current row is too short ... + 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) +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 + 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 + +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 + 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 + + infon(1)=point_ar-1 + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + diff --git a/base/serial/dp/reordvn.f b/base/serial/dp/reordvn.f index f8e88ef54..a1c683945 100644 --- a/base/serial/dp/reordvn.f +++ b/base/serial/dp/reordvn.f @@ -37,6 +37,42 @@ C integer lp, kk, swapia1, swapia2, lswap real(psb_dpk_) swapar + LP = IDX(0) + KK = 1 + 500 CONTINUE + IF ((LP.EQ.0).OR.(KK.GT.NNZ)) GOTO 800 + 600 CONTINUE + IF (LP.GE.KK) GOTO 700 + LP = IDX(LP) + GOTO 600 + 700 CONTINUE +C ... Swap of vectors IA2, IA1, AR ... + SWAPIA2 = IA2(KK) + SWAPIA1 = IA1(KK) + SWAPAR = AR(KK) + IA2(KK) = IA2(LP) + IA1(KK) = IA1(LP) + AR(KK) = AR(LP) + IA2(LP) = SWAPIA2 + IA1(LP) = SWAPIA1 + AR(LP) = SWAPAR + LSWAP = IDX(LP) + IDX(LP) = IDX(KK) + IDX(KK) = LP + LP = LSWAP + KK = KK+1 + GOTO 500 + 800 CONTINUE + return + end + subroutine sreordvn(nnz,ar,ia1,ia2,idx) + use psb_const_mod + integer nnz + integer ia1(*),ia2(*),idx(0:*) + real(psb_spk_) ar(*) + integer lp, kk, swapia1, swapia2, lswap + real(psb_spk_) swapar + LP = IDX(0) KK = 1 500 CONTINUE @@ -121,6 +157,45 @@ C ... Swap of vectors IA2, IA1, AR ... LP = LSWAP KK = KK+1 GOTO 500 + 800 CONTINUE + return + end + subroutine sreordvn3(nnz,ar,ia1,ia2,ia3,idx) + use psb_const_mod + integer nnz + integer ia1(*),ia2(*),ia3(*),idx(0:*) + real(psb_spk_) ar(*) + integer lp, kk, swapia1, swapia2, swapia3,lswap + real(psb_spk_) swapar + + LP = IDX(0) + KK = 1 + 500 CONTINUE + IF ((LP.EQ.0).OR.(KK.GT.NNZ)) GOTO 800 + 600 CONTINUE + IF (LP.GE.KK) GOTO 700 + LP = IDX(LP) + GOTO 600 + 700 CONTINUE +C ... Swap of vectors IA2, IA1, AR ... + SWAPIA3 = IA3(KK) + SWAPIA2 = IA2(KK) + SWAPIA1 = IA1(KK) + SWAPAR = AR(KK) + IA3(KK) = IA3(LP) + IA2(KK) = IA2(LP) + IA1(KK) = IA1(LP) + AR(KK) = AR(LP) + IA3(LP) = SWAPIA3 + IA2(LP) = SWAPIA2 + IA1(LP) = SWAPIA1 + AR(LP) = SWAPAR + LSWAP = IDX(LP) + IDX(LP) = IDX(KK) + IDX(KK) = LP + LP = LSWAP + KK = KK+1 + GOTO 500 800 CONTINUE return end @@ -132,6 +207,81 @@ C ... Swap of vectors IA2, IA1, AR ... integer lp, kk, swapia1, swapia2, swapia3,lswap real(psb_dpk_) swapar + LP = IDX(0) + KK = 1 + 500 CONTINUE + IF ((LP.EQ.0).OR.(KK.GT.NNZ)) GOTO 800 + 600 CONTINUE + IF (LP.GE.KK) GOTO 700 + LP = IDX(LP) + GOTO 600 + 700 CONTINUE +C ... Swap of vectors IA2, IA1, AR ... + SWAPIA3 = IA3(KK) + SWAPIA2 = IA2(KK) + SWAPIA1 = IA1(KK) + SWAPAR = AR(KK) + IA3(KK) = IA3(LP) + IA2(KK) = IA2(LP) + IA1(KK) = IA1(LP) + AR(KK) = AR(LP) + IA3(LP) = SWAPIA3 + IA2(LP) = SWAPIA2 + IA1(LP) = SWAPIA1 + AR(LP) = SWAPAR + LSWAP = IDX(LP) + IDX(LP) = IDX(KK) + IDX(KK) = LP + LP = LSWAP + KK = KK+1 + GOTO 500 + 800 CONTINUE + return + end + subroutine creordvn(nnz,ar,ia1,ia2,idx) + use psb_const_mod + integer nnz + integer ia1(*),ia2(*),idx(0:*) + complex(psb_spk_) ar(*) + integer lp, kk, swapia1, swapia2, lswap + complex(psb_spk_) swapar + + LP = IDX(0) + KK = 1 + 500 CONTINUE + IF ((LP.EQ.0).OR.(KK.GT.NNZ)) GOTO 800 + 600 CONTINUE + IF (LP.GE.KK) GOTO 700 + LP = IDX(LP) + GOTO 600 + 700 CONTINUE +C ... Swap of vectors IA2, IA1, AR ... + SWAPIA2 = IA2(KK) + SWAPIA1 = IA1(KK) + SWAPAR = AR(KK) + IA2(KK) = IA2(LP) + IA1(KK) = IA1(LP) + AR(KK) = AR(LP) + IA2(LP) = SWAPIA2 + IA1(LP) = SWAPIA1 + AR(LP) = SWAPAR + LSWAP = IDX(LP) + IDX(LP) = IDX(KK) + IDX(KK) = LP + LP = LSWAP + KK = KK+1 + GOTO 500 + 800 CONTINUE + return + end + subroutine creordvn3(nnz,ar,ia1,ia2,ia3,idx) + use psb_const_mod + integer nnz + integer ia1(*),ia2(*),ia3(*),idx(0:*) + complex(psb_spk_) ar(*) + integer lp, kk, swapia1, swapia2, swapia3,lswap + complex(psb_spk_) swapar + LP = IDX(0) KK = 1 500 CONTINUE diff --git a/base/serial/dp/scoco.f b/base/serial/dp/scoco.f new file mode 100644 index 000000000..9a436f520 --- /dev/null +++ b/base/serial/dp/scoco.f @@ -0,0 +1,303 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +c covert matrix from COO format to COO format +c + subroutine scoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, + * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, + * lia2n,aux,laux,ierror) + use psb_error_mod + use psb_const_mod + use psb_spmat_type + use psb_string_mod + implicit none + +c .. scalar arguments .. + integer larn, laux, lia1n, lia2n, + + m, n, ierror + character trans,unitd +c .. array arguments .. + real(psb_spk_) ar(*), arn(*), d(*) + integer aux(0:laux-1) + integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), + * infon(*), p1(*), p2(*) + character descra*11, descrn*11 +c .. local scalars .. + integer ipx, ip1, ip2, check_flag, err_act + integer nnz, k, i, j, nzl, iret + integer elem_in, elem_out + logical scale + integer max_nnzero + integer :: debug_level, debug_unit +c .. local arrays .. + character*20 name + integer int_val(5) +c +c ...common variables... +c this flag describe the action to do + +c .. external subroutines .. + external max_nnzero +c .. executable statements .. +c + + name = 'scoco' + ierror = 0 + call fcpsb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + + if (psb_toupper(trans).eq.'N') then + scale = (psb_toupper(unitd).eq.'L') ! meaningless + p1(1) = 0 + p2(1) = 0 + + call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),': on entry nnz laux ', + + nnz,laux,larn,lia1n,lia2n + endif + if (laux.lt.nnz+2) then + ierror = 60 + int_val(1) = 22 + int_val(2) = nnz+2 + int_val(3) = laux + else if (larn.lt.nnz) then + ierror = 60 + int_val(1) = 18 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia1n.lt.nnz) then + ierror = 60 + int_val(1) = 19 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia2n.lt.m+1) then + ierror = 60 + int_val(1) = 20 + int_val(2) = nnz+2 + int_val(3) = laux + endif + +c +c error handling +c + if(ierror.ne.0) then + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + end if + + if (psb_toupper(descra(1:1)).eq.'G') then +c +c sort COO data structure +c + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': first sort',nnz + do k=1, nnz + arn(k) = ar(k) + ia1n(k) = ia1(k) + ia2n(k) = ia2(k) + enddo + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': second sort' + + if ((lia2n.ge.(2*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 + enddo + ip1 = nnz+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ia2n(ip1+psb_ip2_) = ip2 + ia2n(ip1+psb_iflag_) = check_flag + ia2n(ip1+psb_nnzt_) = nnz + ia2n(ip1+psb_nnz_) = 0 + ia2n(ip1+psb_ichk_) = nnz+check_flag + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': build check :',ia2n(ip1+psb_nnzt_) + +c .... order with key ia1n ... + call msort_up(nnz,ia1n,aux,iret) + if (iret.eq.0) + + call sreordvn3(nnz,arn,ia1n,ia2n,aux(ipx),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 sreordvn3(nzl,arn(i),ia1n(i),ia2n(i), + + aux(ipx+i-1),aux) + i = j + enddo + + ia2n(ip2+aux(ipx+1-1)-1) = 1 + +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + 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 first duplicated element ... + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) + ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo + + else + +c .... order with key ia1n ... + call msort_up(nnz,ia1n,aux,iret) + if (iret.eq.0) call sreordvn(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 sreordvn(nzl,arn(i),ia1n(i),ia2n(i),aux) + i = j + enddo +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + 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 first duplicated element ... + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo + endif + infon(psb_nnz_) = elem_out + infon(psb_srtd_) = psb_isrtdcoo_ + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': done rebuild COO',infon(1) + + else if (psb_toupper(descra(1:1)).eq.'S' .and. + + psb_toupper(descra(2:2)).eq.'U') then + + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + else if (psb_toupper(descra(1:1)).eq.'T' .and. + + psb_toupper(descra(2:2)).eq.'U') then + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + + else if (psb_toupper(descra(1:1)).eq.'T' .and. + + psb_toupper(descra(2:2)).eq.'L') then + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + end if +c + else if (psb_toupper(trans).ne.'N') then +c +c to do +c + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + end if + + call fcpsb_erractionrestore(err_act) + return + + 9999 continue + call fcpsb_erractionrestore(err_act) + + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif + + return + end diff --git a/base/serial/dp/scocr.f b/base/serial/dp/scocr.f new file mode 100644 index 000000000..28e89d106 --- /dev/null +++ b/base/serial/dp/scocr.f @@ -0,0 +1,518 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C Covert matrix from COO format to CSR Format +C Note: this never sets IP1 and P2! +C + SUBROUTINE SCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, + * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, + * LIAN2,AUX,LAUX,IERROR) + + use psb_const_mod + use psb_error_mod + use psb_spmat_type + use psb_string_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LIAN1, LIAN2, M, + + N, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + real(psb_spk_) AR(*), ARN(*), D(*) + INTEGER AUX(0:LAUX-1) + INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), + * 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,regen_flag + logical scale + integer max_nnzero + integer, allocatable :: itmp(:) +c .. local arrays .. + character*20 name + integer int_val(5) + integer :: debug_level, debug_unit + +c +C ...Common variables... + +C .. External Subroutines .. + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + + NAME = 'SCOCR' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) + + IF (psb_toupper(TRANS).EQ.'N') THEN + + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + P1(1) = 0 + P2(1) = 0 + nnz = info(1) + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),': On entry NNZ LAUX ', + + nnz,laux,larn,lian1,lian2 + endif + IF (LAUX.LT.NNZ+2) THEN + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ELSE IF (LARN.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NNZ + INT_VAL(3) = LARN + ELSE IF (LIAN1.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN1 + ELSE IF (LIAN2.LT.M+1) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = M+1 + INT_VAL(3) = LIAN2 + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + 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 (psb_toupper(descra(1:1)).EQ.'G') THEN +C +C Sort COO data structure +C + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': First sort',nnz + + 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 + enddo + ip1 = m+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ian2(ip1+psb_ip2_) = ip2 + ian2(ip1+psb_iflag_) = check_flag + ian2(ip1+psb_nnzt_) = nnz + ian2(ip1+psb_nnz_) = 0 + ian2(ip1+psb_ichk_) = nnz+check_flag + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': Build check :',ian2(ip1+psb_nnzt_) + +C .... Order with key IA ... + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) + + call sreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) + if (debug_level >= psb_debug_serial_) then + do i=1, nnz-1 + if (itmp(i).gt.itmp(i+1)) then + write(debug_unit,*) trim(name), + + 'Sorting error:',i,itmp(i),itmp(i+1) + endif + enddo + write(debug_unit,*) trim(name), + + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) + endif + +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 sreordvn3(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, itmp(1) + ian2(row) = 1 + enddo + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': Rebuild CSR',ia(1),elem_csr + + 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 = 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) + ian2(ip2+aux(ipx+elem-1)-1) = elem_csr + 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) = 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) + 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 .... Order with key IA ... + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call sreordvn(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 sreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + endif + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': Done Rebuild CSR', + + ian2(m+1),ia(elem) + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN + + do 20 k = 1, m + p2(k) = k + 20 continue + + else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call sreordvn(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 sreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + + else if (psb_toupper(descra(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call sreordvn(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 sreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + 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_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name), + + ': 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) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': Done Rebuild CSR', + + ian2(m+1),ia(elem) + + + end if +c + else if (psb_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 + + call fcpsb_erractionrestore(err_act) + return + + 9999 continue + call fcpsb_erractionrestore(err_act) + + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif + + return + end diff --git a/base/serial/dp/scrco.f b/base/serial/dp/scrco.f new file mode 100644 index 000000000..e42327e9c --- /dev/null +++ b/base/serial/dp/scrco.f @@ -0,0 +1,193 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, + * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, + * LIAN2,AUX,LAUX,IERROR) + + use psb_const_mod + use psb_spmat_type + use psb_string_mod + use psb_error_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + real(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) + INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), + * INFON(*), IP1(*), IP2(*) + CHARACTER DESCRA*11, DESCRN*11 +C .. Local Scalars .. + INTEGER NNZ, K, ROW, J + INTEGER ELEM, ERR_ACT + LOGICAL SCALE + INTEGER MAX_NNZERO +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + integer :: debug_level, debug_unit +C .. External Subroutines .. + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + + NAME = 'SCRCO' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF (psb_toupper(TRANS).EQ.'N') THEN + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + IP1(1) = 0 + IP2(1) = 0 + NNZ = IA2(M+1)-1 + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': entry',m,n,nnz, + + ' : ',descra,' : ',descrn + + IF (LARN.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NNZ + INT_VAL(3) = LARN + ELSE IF (LIAN1.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN1 + ELSE IF (LIAN2.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN2 + ENDIF + + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN +C ... Construct COO Representation... + ELEM = 0 + + DO ROW = 1, M + DO J = IA2(ROW), IA2(ROW+1)-1 + ELEM = ELEM + 1 + IAN1(ELEM) = ROW + IAN2(ELEM) = IA1(J) + ARN(ELEM) = AR(J) + ENDDO + ENDDO + INFON(psb_nnz_) = elem + + if (debug_level >= psb_debug_serial_) + + write(debug_unit,*) trim(name),': endloop',m,elem + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_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 (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_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)) +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) +C + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_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 (psb_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 + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/dp/scrcr.f b/base/serial/dp/scrcr.f new file mode 100644 index 000000000..808abf90a --- /dev/null +++ b/base/serial/dp/scrcr.f @@ -0,0 +1,317 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, +C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, +C WORK,LWORK,IERROR) +C +C Purpose: CSR to CSR format conversion +C ======= +C +C Parameter: +C ========= +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine will convert +C matrix A or the transpose of A as follows: +C TRANS = 'N' -> convert matrix A +C TRANS = 'T' or 'C' -> convert A' (the transpose of A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') +C and number of rows of matrix H +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A (A') +C and number of columns of matrix H +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - DOUBLE PRECISION array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IP1 - INTEGER array of dimension (M) +C On exit IP1 specifies the row permutation of matrix AN +C (IP1(1) == 0 if no permutation). +C +C DESCRN - CHARACTER*1 array of DIMENSION (9) +C On exit DESCRN describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C AN - DOUBLE PRECISION array of DIMENSION (LAN) +C On exit AN specifies the values of the output sparse +C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN +C satisfying DSPDP memory requirements. +C +C IAN1 - INTEGER array of dimension (LIAN1) +C On exit IAN1 holds integer information on output sparse +C matrix. Actual information will depend on data format used. +C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 +C satisfying DSPDP memory requirements. +C +C IAN2 - INTEGER array of dimension (LIAN2) +C On exit IAN2 holds integer information on output sparse +C matrix. Actual information will depend on data format used. +C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 +C satisfying DSPDP memory requirements. +C +C INFON - INTEGER array of dimension (10) +C On exit can hold auxiliary information on output matrices +C formats or environment of subsequent calls. +C +C IP2 - INTEGER array of dimension (M) +C On exit IP2 specifies the column permutation of matrix AN +C (IP2(1) == 0 if no permutation). +C +C LAN - INTEGER +C On entry LAN specifies the dimension of AN +C LAN must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C LIAN1 - INTEGER +C On entry LH1 specifies the dimension of IAN1 +C LH1 must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C LIAN2 - INTEGER +C On entry LIAN2 specifies the dimension of IAN2 +C LIAN2 must satisfy memory required from the new data structure. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSPDP memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK must satisfy memory necessary for the data conversion. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 error +C +C + SUBROUTINE SCRCR(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_const_mod + use psb_string_mod + IMPLICIT NONE +C +C .. Scalar Arguments .. + INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR + CHARACTER TRANS, UNITD +C .. Array Arguments .. + real(psb_spk_) A(*), AN(*), D(*), WORK(LWORK) + INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), + * 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) + + +C .. Executable Statements .. +C + EXIT=.FALSE. + NAME = 'SCRCR' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) +C +C Check for argument errors +C + idescra=psb_toupper(descra) + IF (((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. (psb_toupper(unitd) .NE. 'B')) + + .OR. + & (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR. + + (idescra(3:3).EQ.'U'))) + + .OR. + + psb_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) = REAL(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 + ENDIF + IF(LIAN2.LT.(M+1)) THEN + IF (LAN.LE.0) THEN + EXIT=.TRUE. + IAN2(1) = M+1 + ELSE + IERROR = 23 + ENDIF + ENDIF + IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. + + (psb_toupper(UNITD) .EQ. 'B')) THEN + IF (LWORK.LT.M) THEN + IF (LWORK.LE.0) THEN + EXIT=.TRUE. + ELSE + IERROR = 25 + ENDIF + WORK(1) = REAL(M) + ENDIF + ELSE + 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 (EXIT) goto 9998 +C +C Set DESCRN, IP1, IP2 +C + DESCRN(1:3) = idescra(1:3) + + IP1(1)=0 + IP2(1)=0 +C +C Compute output matrix +C + DO 20 I = 1, M+1 + IAN2(I) = IA2(I) + 20 CONTINUE + IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. + + (psb_toupper(UNITD) .EQ. 'B')) THEN + DO 30 I = 1, M + WORK(I) = SQRT(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 (psb_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 (psb_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 (psb_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 + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + + diff --git a/base/serial/dp/scrjd.f b/base/serial/dp/scrjd.f new file mode 100644 index 000000000..9827d2037 --- /dev/null +++ b/base/serial/dp/scrjd.f @@ -0,0 +1,315 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, + * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, + * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) +C +C Purpose +C ======= +C +C DCRJD converts a CSR matrix into a Jagged Diagonal. +C +C +C Notes +C ===== +C +C Parameters +C ========== +C +C TRANS Whether the transpose should be converted. +C +C M,N Size of input matrix A +C +C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight +C D(*) +C +C DESCRA Input matrix A. +C AR,IA1, +C IA2,INFO +C +C DESCRN Output matrix in JAD format +C ARN,IAN1 +C IAN2,INFON, IP1, IP2 +C + use psb_const_mod + use psb_spmat_type + use psb_string_mod + IMPLICIT NONE + +C +C .. Scalar Arguments .. + INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, + * SIZE_REQ, IERROR + CHARACTER TRANS,UNITD +C .. Array Arguments .. + real(psb_spk_) 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, + + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT + LOGICAL SCALE + CHARACTER UPLO + INTEGER MAX_NNZERO +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5), IERRV(5) + +C .. External Subroutines .. + EXTERNAL DVTFG + EXTERNAL MAX_NNZERO +C .. Executable Statements .. +C + NAME = 'SCRJD' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (LAUX.LT.4) THEN + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = 4 + INT_VAL(3) = LAUX + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IF (psb_toupper(TRANS).EQ.'N') THEN +C + NJA = 3*M + SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless + IOFF = 5 +C +C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX +C + PNG = IOFF + PIA = PNG + 1 + PJA = PIA + 3*(M+2) + + IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN + +C +C CHECK ON DIMENSION OF IAN2 AND AUX +C + MAX_NG = M/PSB_MINJDROWS_+1 + + IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN +C ... If I haven't sufficent memory to compute NG in IAN2 ... + IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN +C ... If I haven't sufficent memory to compute NG in AUX ... + IERROR = 60 + INT_VAL(1) = 22 + INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 + INT_VAL(3) = LAUX + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ELSE +C ... I have sufficent memory to compute NG in AUX ... + CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX) + CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + IF (IERRV(1).NE.0) THEN + SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) + + GOTO 9998 + ENDIF + ENDIF + END IF + + NZ = IA2(M+1) - 1 +C +C ... Initialize Permutation Matrix ... +C + DO 10 K = 1, M + IP1(K) = K + 10 CONTINUE + + IP2(1) = 0 + + CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX) + + PJA = PIA + 3*(IAN2(PNG)+1) +C +C CHECK FOR ARRAY DIMENSIONS +C + CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + IF (IERRV(1) .NE.0) THEN + SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) + GOTO 9998 + ENDIF + + LJA = LIAN2-PJA + CALL SGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, + + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, + + LARN,LIAN1, LJA,IP1, + + AUX, LAUX, SIZE_REQ,IERROR) + + IF (IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + DESCRN(1:1) = 'G' + DESCRN(2:2) = 'U' + DESCRN(3:3) = 'N' + + ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') THEN +C + ISTROW = 1 + NZ = 2*(IA2(M+1)-1) - M +C +C CHECK ON DIMENSION OF IAN1 AND ARN +C + IF (NZ .GT. LIAN1) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NZ + INT_VAL(3) = LAUX + LIAN1 = NZ + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + IF (NZ .GT. LARN) THEN + IERROR = 60 + INT_VAL(1) = 18 + INT_VAL(2) = NZ + INT_VAL(3) = LAUX + LIAN1 = NZ + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + DO 20 K = 1, M + IP2(K) = K + 20 CONTINUE + +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 (psb_toupper(DESCRA(1:1)).EQ.'T') THEN +C +C Only unit diagonal so far for triangular matrices. +C + + + IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN + IERROR=3022 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + UPLO = DESCRA(2:2) + NZ = IA2(M+1) - 1 +C +C ...Compute levels... +C Each level correspond to a block +C IAN1 is used as a work area + + CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, + + AUX,AUX(M+1),AUX(2*(M+1))) + +C Generate IA(1,*) + DO K = 1, IAN2(PNG)+1 + IAN2(PIA+3*(K-1)) = IAN1(K) + ENDDO + + CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) + + PJA = PIA + 3*(IAN2(PNG)+1) + +C +C CHECK FOR ARRAY DIMENSIONS +C + + CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, + + NZ,LARN,LIAN1,LIAN2,IERRV) + + IF (IERRV(1).NE.0) THEN + size_req = max(ierrv(2),ierrv(3),ierrv(4)) +c$$$ write(0,*) "error 2",ierrv(1) + GOTO 9998 + endif + LJA = LIAN2-PJA + + CALL SGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), + + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX, IERROR) + + IF (IERROR.NE.0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + DESCRN(1:1) = 'T' + DESCRN(2:3) = psb_toupper(DESCRA(2:3)) + + END IF +C +C SET THE OUTPUT PARAMETER +C + IAN2(1) = PNG + IAN2(2) = PIA + IAN2(3) = PJA + LARN = NZ + LIAN1 = NZ + LIAN2 = 3*M + 10 + LAUX2 = 4*M + 2 +C + ELSE IF (psb_toupper(TRANS).NE.'N') THEN +C +C TO BE DONE +C + IERROR = 3021 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + + 9998 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/dp/sgind_tri.f b/base/serial/dp/sgind_tri.f new file mode 100644 index 000000000..3a8e15cbe --- /dev/null +++ b/base/serial/dp/sgind_tri.f @@ -0,0 +1,237 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, + + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) + + use psb_const_mod + IMPLICIT NONE + +C ... Scalar arguments ... + + INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR + +C ... Array arguments ... + + real(psb_spk_) A(*), ARN(*), WORK(*) + INTEGER IA1(*), IA2(*), KA(*), + + IA(3,*), IPERM(M), JA(*) + +C .... Local scalars ... + INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, + + DIM_BLOCK, LIMIT, ERR_ACT + LOGICAL CSR +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + + NAME = 'SGIND_TRI' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + POINT_AR = 1 + POINT_JA = 0 + 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 + ENDIF + +C .... Invert Permutation Matrix... + IF (IPERM(1).NE.0) THEN + 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 +C ... If current block is not empty ... +C ... For each Column belonging to Block ... + 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 + +C ... If the current row is too short ... + 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 +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 + ENDIF + ENDDO + + IF (CSR) GOTO 998 + + 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 + + JA(POINT_JA) = POINT_AR + ENDDO + ENDDO + + IA(2,N_BLOCKS+1) = POINT_JA + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + diff --git a/base/serial/dp/sgindex.f b/base/serial/dp/sgindex.f new file mode 100644 index 000000000..7112a6dcc --- /dev/null +++ b/base/serial/dp/sgindex.f @@ -0,0 +1,463 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SGINDEX(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 + IMPLICIT NONE + +C ... Scalar arguments ... + INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, + + SIZE_REQ,IERROR + +C ... Array arguments ... + + real(psb_spk_) 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, ix, regen_flag + LOGICAL CSR +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) + + NAME = 'DGINDEX\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + 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 + ENDIF + + 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 + ENDIF + + 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 + + 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 + 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) +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 +C ... If current block is not empty ... +C ... For each Column belonging to Block ... + 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 + +C ... If the current row is too short ... + 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 + + 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 + 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 + +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 + + 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 + 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.) +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 ... If the current row is too short ... + 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) +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 + 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 + +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 + 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 + + infon(1)=point_ar-1 + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + diff --git a/base/serial/f77/Makefile b/base/serial/f77/Makefile index 18b1d713f..2fc6fbcb1 100644 --- a/base/serial/f77/Makefile +++ b/base/serial/f77/Makefile @@ -6,6 +6,10 @@ include ../../../Make.inc FOBJS = daxpby.o dcsmm.o dcsnmi.o dcsrp.o dcssm.o \ dgelp.o dlpupd.o dswmm.o \ dswsm.o smmp.o dcsrws.o \ + saxpby.o slpupd.o scsmm.o sswmm.o scsnmi.o scsrws.o\ + sswsm.o scssm.o sgelp.o\ + caxpby.o clpupd.o ccsmm.o cswmm.o ccsnmi.o ccsrws.o\ + cswsm.o ccssm.o cgelp.o\ zcsnmi.o zaxpby.o zcsmm.o zcssm.o zswmm.o zswsm.o\ zcsrws.o zgelp.o zlpupd.o diff --git a/base/serial/f77/caxpby.f b/base/serial/f77/caxpby.f new file mode 100644 index 000000000..b807acacf --- /dev/null +++ b/base/serial/f77/caxpby.f @@ -0,0 +1,200 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + complex(psb_spk_), parameter :: one=(1.0,0.0) + complex(psb_spk_), parameter :: zero=(0.0,0.0) + integer n, m, lldx, lldy, info + complex(psb_spk_) X(lldx,*), Y(lldy,*) + complex(psb_spk_) alpha, beta + integer i, j + integer int_err(5) + character name*20 + name='caxpby' + + +C +C Error handling +C + info = 0 + if (m.lt.0) then + info=10 + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=10 + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=50 + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=50 + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.zero) then + if (beta.eq.zero) then + do j=1, n + do i=1,m + y(i,j) = zero + enddo + enddo + else if (beta.eq.one) then +c$$$ +c$$$ Do nothing! +c$$$ + + else if (beta.eq.-one) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.one) then + + if (beta.eq.zero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.one) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-one) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-one) then + + if (beta.eq.zero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.one) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-one) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.zero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.one) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-one) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + + 9999 continue + call fcpsb_serror() + return + + end diff --git a/base/serial/f77/ccsmm.f b/base/serial/f77/ccsmm.f new file mode 100644 index 000000000..e867a852c --- /dev/null +++ b/base/serial/f77/ccsmm.f @@ -0,0 +1,380 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, +C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C Purpose +C ======= +C +C Computing matrix-matrix product +C C <-- ALPHA PL A PR B + BETA C or +C C <-- ALPHA PL At PR B + BETA C or +C C <-- ALPHA PL Atc PR B + BETA C +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' -> use A' (transpose of matrix A) +C TRANS = 'C' -> use conjugate transpose of A +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C K - INTEGER +C On entry: number of columns of matrix A (A') and +C number of rows of matrix B +C Unchanged on exit. +C +C ALPHA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C PL - INTEGER array of dimension (M) +C On entry PL specifies the row permutation of matrix A +C (PL(1) == 0 if no permutation). +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - COMPLEX*16 array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C PR - INTEGER array of dimension (K) +C On entry PR specifies the column permutation of matrix A +C (PR(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - COMPLEX*16 matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B +C Unchanged on exit. +C +C BETA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - COMPLEX*16 matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated with the matrix-matrix product. +C +C LDC - INTEGER +C On entry: leading dimension of C +C Unchanged on exit. +C +C WORK - COMPLEX*16 array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying CCSMM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N +C where Pr íPlù = 1 if right íleftù permutation has to +C be performed, 0 otherwise. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Local Variables +C =============== +C +C LWORKM - INTEGER +C Minimum work area dimension for CCSMM +C +C LWORKB - INTEGER +C Work area dimension for matrix B in subroutine DLPUPD +C +C LWORKC - INTEGER +C Work area dimension for matrix C in subroutine DLPUPD +C +C LWORKS - INTEGER +C Work area dimension for subroutine DSWMM +C +C P - INTEGER +C Pointer to work area +C +C LP - LOGICAL +C LP is true if left permutation is required +C +C RP - LOGICAL +C RP is true if right permutation is required +C +C Notes +C ===== +C Some tests have shown that it is more efficient to divide the +C sparse matrix-dense matrix multiplication step and the dense +C matrix permutation step, and it is more efficient to put +C together the left permutation and update (C <- xxx + BETA C) +C steps. So, the sequence of operations is: +C Right permutation ZLPUPD +C Matrix-Matrix product ZSWMM +C Left permutation and update ZLPUPD +C In order to avoid useless memory transfer, the above scheme is +C simplified according to whether right and left permutation have to +C be performed. If left permutation is not required, the update step +C is performed in the sparse matrix-dense matrix multiplication kernel. +C +C It is not possible to call this subroutine with LWORK=0 to get # +C the minimal value for LWORK. This functionality needs a better # +C connection with DxxxMM # +C +C + SUBROUTINE CCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, + & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N,K,LDB,LDC,LWORK, IERROR + CHARACTER TRANS + complex(psb_spk_) ALPHA,BETA +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) + CHARACTER DESCRA*11, FIDA*5 + complex(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) +C .. Local Scalars .. + INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT + LOGICAL LP, RP +C .. Local Array.. + INTEGER INT_VAL(5) + CHARACTER*30 NAME, STRINGS(2) +C .. External Subroutines .. + EXTERNAL ZSWMM, ZLPUPD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, IDINT +C .. Executable Statements .. +C +C Check for argument errors +C + NAME = 'CCSMM\0' + IERROR=0 + + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (K.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 4 + INT_VAL(2) = K + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ELSE IF (LDB.LT.K) THEN + IERROR = 50 + INT_VAL(1) = 15 + INT_VAL(2) = 4 + INT_VAL(3) = LDB + INT_VAL(4) = K + ELSE IF (LDC.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 18 + INT_VAL(2) = 2 + INT_VAL(3) = LDC + INT_VAL(4) = M + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + +C +C Inizializations +C + LP = PL(1).NE.0 + RP = PR(1).NE.0 + LWORKB = K*N + LWORKC = M*N + LWORKM = 0 + IF (RP) LWORKM = LWORKB + IF (LP) LWORKM = LWORKM + LWORKC + IF (LWORK.LT.LWORKM) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = LWORKM + INT_VAL(3) = LWORK + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + LWORKS = LWORK - LWORKM + +C +C Check for M, N, K +C + IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN + GOTO 9999 + ENDIF +C +C Switching on PR and PL +C + IF (LP .AND. RP) THEN +C +C Both right and left permutation required +C + P=LWORKB+1 + CALL CLPUPD(K,N,PR,B,LDB,ZZERO,WORK,K) + CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & WORK,K,ZZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) + LWORKS = INT(REAL(WORK(P+LWORKC))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDA//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL CLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) + ELSE IF(.NOT.LP .AND. RP) THEN +C +C Only right permutation required +C + P=LWORKB+1 + CALL CLPUPD(K,N,PR,B,LDB,ZZERO,WORK,K) + CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) + LWORKS = INT(REAL(WORK(P))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDA//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ELSE IF(.NOT.RP .AND. LP) THEN +C +C Only left permutation required +C + P=LWORKC+1 + CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & B,LDB,ZZERO,WORK,M,WORK(P),LWORKS,IERROR) + LWORKS = INT(REAL(WORK(P))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDA//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + + CALL CLPUPD(M,N,PL,WORK,M,BETA,C,LDC) + ELSE IF(.NOT.RP .AND. .NOT.LP) THEN +C +C No permutations required +C + CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) + LWORKS = INT(REAL(WORK(1))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDA//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + + GOTO 9999 + ENDIF + ENDIF + ENDIF +C +C Return minimum workarea dimension +C + LWORKM = LWORKM + LWORKS + WORK(1) = REAL(LWORKM) + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + + RETURN + END + + diff --git a/base/serial/f77/ccsnmi.f b/base/serial/f77/ccsnmi.f new file mode 100644 index 000000000..f35d7d5f2 --- /dev/null +++ b/base/serial/f77/ccsnmi.f @@ -0,0 +1,184 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C DOUBLE PRECISION FUNCTION CCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & +C & INFOA,IERROR) +C Purpose +C ======= +C +C Computing matrix infinity norm +C nrmi <-- ||A||infty or +C nrmi <-- ||At||infty +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Notes +C ===== +C + FUNCTION CCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, + & INFOA,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE + real(psb_spk_) ccsnmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11, FIDA*5 + complex(psb_spk_) A(*) +C .. Local Array.. + INTEGER INT_VAL(5), ERR_ACT + CHARACTER*30 NAME, STRINGS(2) +C .. External Subroutines .. + real(psb_spk_) CCRNRMI, CCOONRMI + EXTERNAL CCRNRMI, CCOONRMI +C .. Executable Statements .. +C +C Check for argument errors +C + IERROR = 0 + NAME = 'CCSNMI\0' + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + +C +C Check for M, N, K +C + IF(M.LE.0 .OR. N.LE.0) THEN + CCSNMI = 0.D0 + GOTO 9999 + ENDIF + +C ... Compute infinity norm for matrix A ... + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + CCSNMI = CCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) +c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN +c$$$ CCSNMI = CJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, +c$$$ + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + CCSNMI = CCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + RETURN + END diff --git a/base/serial/f77/ccsrws.f b/base/serial/f77/ccsrws.f new file mode 100644 index 000000000..d8ef9f20a --- /dev/null +++ b/base/serial/f77/ccsrws.f @@ -0,0 +1,189 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & +C & INFOA,ROWSUM,IERROR) +C Purpose +C ======= +C +C Computing sum of absolute values for rows of distributed matrix +C ROWSUM(IX) = ASUM(A(IX, 1..N)) +C IX = 1..M +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C ROWSUM - DOUBLE PRECISION array of dimension (*) +C On exit this vector contains the sum of absolute values +C of elements of a row (AMAX of row array). +C It is required that it has dimension: +C ROWSUM(M) if the subroutine in called with the 'N' option +C ROWSUM(N) in other cases ('T' or 'C' options). +C + SUBROUTINE CCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, + & INFOA,ROWSUM,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11, FIDA*5 + complex(psb_spk_) A(*), ROWSUM(*) +C .. Local Array.. + INTEGER INT_VAL(5), ERR_ACT + CHARACTER*30 NAME,STRINGS(2) +C .. Executable Statements .. +C +C Check for argument errors +C + + IERROR = 0 + NAME = 'CCSRWS\0' + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IF(M.LE.0 .OR. N.LE.0) THEN + GOTO 9999 + ENDIF + + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + CALL CCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + CALL CCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) +c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN +c$$$ CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, +c$$$ + INFOA,ROWSUM,IERROR) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + strings(1) = fida//'\0' + ENDIF + + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END + + diff --git a/base/serial/f77/ccssm.f b/base/serial/f77/ccssm.f new file mode 100644 index 000000000..7c0e99aa9 --- /dev/null +++ b/base/serial/f77/ccssm.f @@ -0,0 +1,376 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, +C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C +C Solving triangular systems of equations with multiple right-hand sides +C C <-- ALPHA PL D T-1 PR B + BETA C or +C C <-- ALPHA PL D T-t PR B + BETA C or +C C <-- ALPHA PL T-1 D PR B + BETA C or +C C <-- ALPHA PL T-t D PR B + BETA C +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine operates with +C matrix T or with the transpose of T as follows: +C TRANS = 'N' -> use matrix T +C TRANS = 'T' -> use T' (transpose of matrix T) +C TRANS = 'C' -> use conjugate transpose of T +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows and columns of matrix Ty +C and number of rows of matrices B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrices B and C +C (number of right-hand sides). +C Unchanged on exit. +C +C ALPHA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - COMPLEX*16 array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C PL - INTEGER array of dimension (M) +C On entry PL specifies the row permutation of matrix T +C (PL(1) == 0 if no permutation). +C Unchanged on exit. +C +C FIDT - CHARACTER*5 +C On entry FIDT defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRT - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRT describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C +C T - CONPLEX*16 array of DIMENSION (*) +C On entry T specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IT1 - INTEGER array of dimension (*) +C On entry IT1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IT2 - INTEGER array of dimension (*) +C On entry IT2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOT - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C PR - INTEGER array of dimension (M) +C On entry PR specifies the column permutation of matrix T +C (PR(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - COMPLEX*16 array of dimension (LDB,*) +C On entry: matrix of right-hand sides +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C BETA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - COMPLEX*16 array of dimension (LDC,*) +C On exit: solutions of triangular systems +C +C LDC - INTEGER +C On entry: leading dimension of C. +C Unchanged on exit. +C +C WORK - COMPLEX*16 array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DCSSM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N +C where Pr íPlù = 1 if right íleftù permutation has to +C be performed, 0 otherwise. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Local Variables +C =============== +C +C LWORKM - INTEGER +C Minimum work area dimension for CCSSM +C +C LWORKB - INTEGER +C Work area dimension for matrices B, C in subroutines ZLPUPD +C +C LWORKS - INTEGER +C Work area dimension for subroutine ZSWSM +C +C P - INTEGER +C Pointer to work area +C +C LP - LOGICAL +C LP is true if left permutation is required +C +C RP - LOGICAL +C RP is true if right permutation is required +C +C Notes +C ===== +C Some tests have shown that it is more efficient to divide the +C sparse matrix-dense matrix multiplication step and the dense +C matrix permutation and update (C <- xxx + BETA C) step. +C So, the sequence of operations is: +C Right permutation ZLPUPD +C Matrix-Matrix product ZSWSM +C Left permutation and update ZLPUPD +C In order to avoid useless memory transfer, the above scheme is +C simplified according to whether right and left permutation +C have to be performed. +C +C + SUBROUTINE CCSSM(TRANS,M,N,ALPHA,UNITD,D,PL, + + FIDT,DESCRT,T,IT1,IT2,INFOT,PR,B,LDB,BETA,C,LDC, + + WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + IMPLICIT NONE + complex(psb_spk_) ALPHA, BETA + INTEGER N, LDB, LDC, M, LWORK, IERROR + CHARACTER UNITD, TRANS +C .. Array Arguments .. + complex(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) + CHARACTER DESCRT*11, FIDT*5 +C .. Local Scalars .. + INTEGER LWORKM, LWORKB, LWORKS, P + complex(psb_spk_) ZERO + LOGICAL LP, RP +C .. Local Array.. + INTEGER INT_VAL(5), ERR_ACT + CHARACTER*30 NAME, STRINGS(2) +C .. Parameters .. + PARAMETER (ZERO = (0.0, 0.0)) +C .. Executable Statements .. +C +C Check for argument errors +C + NAME = 'CCSSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ELSE IF (psb_toupper(UNITD).NE.'U' .AND. + + psb_toupper(UNITD).NE.'L' .AND. + + psb_toupper(UNITD).NE.'R' .AND. + + psb_toupper(UNITD).NE.'B') THEN + IERROR = 40 + INT_VAL(1) = 5 + STRINGS(1) = UNITD//'\0' + ELSE IF (LDB.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 16 + INT_VAL(2) = 2 + INT_VAL(3) = LDB + INT_VAL(4) = M + ELSE IF (LDC.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 19 + INT_VAL(2) = 2 + INT_VAL(3) = LDC + INT_VAL(4) = M + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + +C +C Inizializations +C + LP = PL(1).NE.0 + RP = PR(1).NE.0 + LWORKB = M*N + LWORKM = 0 + IF (RP) LWORKM = LWORKB + IF (LP) LWORKM = LWORKM + LWORKB + P = LWORKB+1 + IF (LWORK.LT.LWORKM) THEN + IERROR = 60 + INT_VAL(1) = 21 + INT_VAL(2) = LWORKM + INT_VAL(3) = LWORK + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + LWORKS = LWORK - LWORKM + +C Check for M, N +C + IF (M.LE.0 .OR. N.LE.0) THEN + GOTO 9999 + ENDIF +C +C Switching on xP +C + IF (LP .AND. RP) THEN +C +C Both right and left permutations required +C + CALL CLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),lworks,IERROR) + LWORKS = INT(REAL(WORK(P+LWORKB))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDT//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL CLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) + ELSE IF(.NOT.LP .AND. RP) THEN +C +C Only right permutation required +C + CALL CLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,ZERO,C,LDC,WORK(P),lworks,IERROR) + LWORKS = INT(REAL(WORK(P))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDT//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ELSE IF(.NOT.RP .AND. LP) THEN +C +C Only left permutation required +C + CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,WORK,M,WORK(P),lworks,IERROR) + LWORKS = INT(REAL(WORK(P))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDT//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL CLPUPD(M,N,PL,WORK,M,BETA,C,LDC) + ELSE IF(.NOT.RP .AND. .NOT.LP) THEN +C +C Only triangular systems solver required +C + CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,C,LDC,WORK,lworks,IERROR) + LWORKS = INT(REAL(WORK(1))) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + STRINGS(1) = FIDT//'\0' + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ENDIF +C +C Return minimum workarea dimension +C + LWORKM = LWORKM + LWORKS + WORK(1) = REAL(LWORKM) + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + RETURN + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + ENDIF + RETURN + + END + diff --git a/base/serial/f77/cgelp.f b/base/serial/f77/cgelp.f new file mode 100644 index 000000000..2e9d9959c --- /dev/null +++ b/base/serial/f77/cgelp.f @@ -0,0 +1,204 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C Computing +C B <-- op(P) B +C where op(P) is permutation matrix P or its transpose. +C Notice: when B is a diagonal matrix and it is stored as +C a vector whose entry i is B(i,i), this routine computes +C B <-- P B P(-1) +C where P(-1) is the inverse of P. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whetherif the routine operates with +C matrix P or with the transpose of P as follows: +C TRANS = 'N' -> use matrix P +C TRANS = 'T' OR 'C' -> use the transpose of matrix P +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix B. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B. +C Unchanged on exit. +C +C P - INTEGER array of dimension (M) +C On entry P specifies the row permutation of matrix B +C (P(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - DOUBLE PRECISION array of dimension (LDB,*) +C On entry: dense matrix. +C On exit: permuted matrix. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DGELP memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = M +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C + SUBROUTINE CGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER LDB, M, N, LWORK, IERROR + CHARACTER TRANS +C .. Array Arguments .. + complex(psb_spk_) B(LDB,*), WORK(*) + INTEGER P(*) +C .. Local Scalars .. + INTEGER I, J, ERR_ACT + logical istran,isnotran +C .. Local Arrays.. + INTEGER INT_VAL +C .. Intrinsic Functions .. + INTRINSIC DBLE + logical psb_lsame + external psb_lsame + + character*20 name +c +C .. Executable Statements .. +C +C +C Check on M, N, LDB, LWORK, TRANS +C + NAME = 'CGELP\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + isnotran = psb_lsame(psb_toupper(trans),'N') + istran = psb_lsame(psb_toupper(trans),'T') .or. + + psb_lsame(psb_toupper(trans),'C') + IF (M.LT.0) THEN + IERROR = 7 + ELSE IF(N.LT.0) THEN + IERROR = 3 + ELSE IF(M.GT.LDB) THEN + IERROR = -6 + ELSE IF (LWORK.LT.M) THEN + IF (LWORK.EQ.0) THEN +C +C Return minimum LWORK +C + IERROR = 8 + WORK(1) = REAL(M) + GOTO 9998 + ELSE IF(LWORK.NE.0) THEN + IERROR = -8 + ENDIF + ELSE IF (.not.istran.and..not.isnotran) THEN + IERROR = -1 + ENDIF +C +C Error handling +C + IF(IERROR.LT.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF +C +C Check for M, N, P +C + IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF +C +C Switch on TRANS +C + IF (isnotran) THEN +C +C Permuting with P +C + DO 60 J = 1, N + DO 20 I = 1, M + WORK(I) = B(P(I),J) + 20 CONTINUE + DO 40 I = 1, M + B(I,J) = WORK(I) + 40 CONTINUE + 60 CONTINUE + ELSE IF (istran) THEN +C +C Permuting with the transpose of P. +C + DO 160 J = 1, N + DO 120 I = 1, M + WORK(P(I)) = B(I,J) + 120 CONTINUE + DO 140 I = 1, M + B(I,J) = WORK(I) + 140 CONTINUE + 160 CONTINUE + END IF + + 9998 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/clpupd.f b/base/serial/f77/clpupd.f new file mode 100644 index 000000000..87768b3e1 --- /dev/null +++ b/base/serial/f77/clpupd.f @@ -0,0 +1,116 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C Subroutine CLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) +C Purpose +C ======= +C +C Computing C <-- PERM B + BETA C +C where PERM is a permutation matrix. +C +C Parameters +C ========== +C +C M - INTEGER +C On entry M specifies the number of rows of matrices +C B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry N specifies the number of columns of matrices +C B and C. +C Unchanged on exit. +C +C PERM - INTEGER array of dimension (N) +C On entry PERM specifies the values of a permutation matrix. +C Unchanged on exit. +C +C B - DOUBLE PRECISION matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry LDB holds the value of the leading dimension of B +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated as shown above. +C +C LDC - INTEGER +C On entry LDC holds the value of the leading dimension of C +C Unchanged on exit. +C +C Note +C ==== +C All checks on argument are performed in the calling routines. +C +C + SUBROUTINE CLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) + use psb_const_mod +C .. Scalar Arguments .. + INTEGER M, N, LDB, LDC + complex(psb_spk_) BETA +C .. Array Arguments .. + INTEGER PERM(*) + complex(psb_spk_) B(LDB,*), C(LDC,*) +C .. Local Scalars .. + INTEGER I,J +C +C .. Executable Statements .. +C +C Switching on BETA +C + IF (BETA.NE.CZERO) THEN +C +C Performing left permutation and update +C + DO 40 J = 1, N + DO 30 I = 1, M + C(I,J) = B(PERM(I),J) + BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE IF(BETA.EQ.CZERO) THEN +C +C Performing right or left permutation +C + DO 160 J = 1, N + DO 150 I = 1, M + C(I,J) = B(PERM(I),J) + 150 CONTINUE + 160 CONTINUE + ENDIF + RETURN + END diff --git a/base/serial/f77/cswmm.f b/base/serial/f77/cswmm.f new file mode 100644 index 000000000..620ac7aa5 --- /dev/null +++ b/base/serial/f77/cswmm.f @@ -0,0 +1,219 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, +C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C Purpose +C ======= +C +C Computing C <-- ALPHA A B + BETA C or +C C <-- ALPHA At B + BETA C or +C C <-- ALPHA Atc B + BETA C +C Called by ZCSMM +C Actual computing performed by sparse Toolkit kernels. +C This routine selects the proper kernel for each +C data structure. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' -> use A' (transpose of matrix A) +C TRANS = 'C' -> use conjugate transpose of A +C Unchanged on exit. +C +C N.B.: M, N for C matrix +C M, K for A matrix +C K, N for B matrix +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C K - INTEGER +C On entry: number of columns of matrix A (A') and +C number of rows of matrix B +C Unchanged on exit. +C +C ALPHA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - COMPLEX*16 array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C B - COMPLEX*16 matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B +C Unchanged on exit. +C +C BETA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - COMPLEX*16 matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated with the matrix-matrix product. +C +C LDC - INTEGER +C On entry: leading dimension of C +C Unchanged on exit. +C +C WORK - COMPLEX*16 array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying CSWMM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Note +C ==== +C All checks on argument are performed in the calling routine. +C +C + SUBROUTINE CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, + & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + INTEGER M,N,K,LDB,LDC,LWORK,IERROR + CHARACTER TRANS + complex(psb_spk_) ALPHA,BETA +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11, FIDA*5 + complex(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) +C .. Local Array .. + INTEGER INT_VAL(5), ERR_ACT + CHARACTER*30 NAME, STRINGS(2) +C .. External Subroutines .. + EXTERNAL CCSRMM +C + ZJADMM +C .. Executable Statements .. +C +C Switching on FIDA: proper sparse BLAS routine is selected +C according to data structure +C + NAME = 'CSWMM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN +C +C A, IA1, IA2 ---> AR, JA, IA +C VAL, INDX, PNTR +C INFOA(*) not used + CALL CCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + & IA2,B,LDB,BETA,C,LDC,WORK,LWORK) +C +C JAD format not jet implemented +C + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN +C +C INFOA(*) not used +C + CALL CCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + + IA2,INFOA,B,LDB,BETA,C,LDC,WORK) + ELSE IF ((psb_toupper(FIDA(1:3)).EQ.'JAD').AND.(.FALSE.)) THEN +C +C INFOA(*) not used +C +C CALL ZJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, +C & IA2,B,LDB,BETA,C,LDC,WORK) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + STRINGS(1) = FIDA(1:4) + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + END + diff --git a/base/serial/f77/cswsm.f b/base/serial/f77/cswsm.f new file mode 100644 index 000000000..48442149f --- /dev/null +++ b/base/serial/f77/cswsm.f @@ -0,0 +1,229 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, +C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C +C Solving triangular systems of equations with multiple right-hand sides +C C <-- ALPHA D T-1 B + BETA C or +C C <-- ALPHA D T-t B + BETA C or +C C <-- ALPHA T-1 D B + BETA C or +C C <-- ALPHA T-t D B + BETA C +C Actual computing performed by sparse Toolkit kernels. +C This routine selects the proper kernel for each +C data structure. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine operates with +C matrix T or with the transpose of T as follows: +C TRANS = 'N' -> use matrix T +C TRANS = 'T' -> use T' (transpose of matrix T) +C TRANS = 'C' -> use conjugate transpose of T +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows and columns of matrix T +C and number of rows of matrices B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrices B and C +C (number of right-hand sides). +C Unchanged on exit. +C +C ALPHA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - COMPLEX*16 array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C FIDT - CHARACTER*5 +C On entry FIDT defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRT - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRT describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C +C T - COMPLEX*16 array of DIMENSION (*) +C On entry T specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IT1 - INTEGER array of dimension (*) +C On entry IT1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IT2 - INTEGER array of dimension (*) +C On entry IT2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOT - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C B - COMPLEX*16 array of dimension (LDB,*) +C On entry: matrix of right-hand sides +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C BETA - COMPLEX*16 +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - COMPLEX*16 array of dimension (LDC,*) +C On exit: solutions of triangular systems +C +C LDC - INTEGER +C On entry: leading dimension of C. +C Unchanged on exit. +C +C WORK - COMPLEX*16 array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSWSM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Note +C ==== +C All checks on argument are performed in the calling routine. +C +C + SUBROUTINE CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod +C .. Scalar Arguments .. + INTEGER M, N, LDB, LDC, LWORK, IERROR + CHARACTER UNITD, TRANS + complex(psb_spk_) ALPHA, BETA +C .. Array Arguments .. + INTEGER IT1(*), IT2(*), INFOT(*) + CHARACTER DESCRT*11, FIDT*5 + complex(psb_spk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + integer ERR_ACT +C .. Local Scalars .. + INTEGER ONE +C .. Parameters .. + PARAMETER (ONE=1) +C .. External Subroutines .. + EXTERNAL CCSRSM, CCOPY + CHARACTER*20 NAME + +C .. Executable Statements .. + NAME = 'CSWSM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) +C +C Check for identity matrix +C + IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. + + psb_toupper(DESCRT(3:3)).EQ.'U') THEN + CALL CCOPY(M,B,ONE,C,ONE) + GOTO 9999 + ENDIF +C +C Switching on FIDT: proper sparse BLAS routine is selected +C according to data structure +C + IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN +C +C T, IT1, IT2 ---> AR, JA, IA +C VAL, INDX, PNTR +C INFOT(*) not used +C + CALL CCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, + & IT2,B,LDB,BETA,C,LDC,WORK,LWORK) + ELSE IF ((psb_toupper(FIDT(1:3)).EQ.'JAD') + + .AND.(.FALSE.)) THEN +C +C .. JAD format not yet supported +C +C CALL CJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2,0, +C & B,LDB,BETA,C,LDC,WORK) +C + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + ENDIF + + RETURN + END + + diff --git a/base/serial/f77/daxpby.f b/base/serial/f77/daxpby.f index 016c4a704..24d9d729f 100644 --- a/base/serial/f77/daxpby.f +++ b/base/serial/f77/daxpby.f @@ -31,8 +31,6 @@ C C subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod - real(psb_dpk_) one, zero - parameter (one=1.d0,zero=0.d0) integer n, m, lldx, lldy, info real(psb_dpk_) X(lldx,*), Y(lldy,*) real(psb_dpk_) alpha, beta @@ -76,19 +74,19 @@ C goto 9999 endif - if (alpha.eq.zero) then - if (beta.eq.zero) then + if (alpha.eq.dzero) then + if (beta.eq.dzero) then do j=1, n do i=1,m - y(i,j) = zero + y(i,j) = dzero enddo enddo - else if (beta.eq.one) then + else if (beta.eq.done) then c$$$ c$$$ Do nothing! c$$$ - else if (beta.eq.-one) then + else if (beta.eq.-done) then do j=1,n do i=1,m y(i,j) = - y(i,j) @@ -102,22 +100,22 @@ c$$$ enddo endif - else if (alpha.eq.one) then + else if (alpha.eq.done) then - if (beta.eq.zero) then + if (beta.eq.dzero) then do j=1,n do i=1,m y(i,j) = x(i,j) enddo enddo - else if (beta.eq.one) then + else if (beta.eq.done) then do j=1,n do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-one) then + else if (beta.eq.-done) then do j=1,n do i=1,m y(i,j) = x(i,j) - y(i,j) @@ -131,22 +129,22 @@ c$$$ enddo endif - else if (alpha.eq.-one) then + else if (alpha.eq.-done) then - if (beta.eq.zero) then + if (beta.eq.dzero) then do j=1,n do i=1,m y(i,j) = -x(i,j) enddo enddo - else if (beta.eq.one) then + else if (beta.eq.done) then do j=1,n do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-one) then + else if (beta.eq.-done) then do j=1,n do i=1,m y(i,j) = -x(i,j) - y(i,j) @@ -162,20 +160,20 @@ c$$$ else - if (beta.eq.zero) then + if (beta.eq.dzero) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) enddo enddo - else if (beta.eq.one) then + else if (beta.eq.done) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-one) then + else if (beta.eq.-done) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) diff --git a/base/serial/f77/dcsmm.f b/base/serial/f77/dcsmm.f index 64becd9ef..482be0031 100644 --- a/base/serial/f77/dcsmm.f +++ b/base/serial/f77/dcsmm.f @@ -190,8 +190,9 @@ C connection with DxxxMM # C C SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, - & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. @@ -234,7 +235,9 @@ C IERROR = 10 INT_VAL(1) = 3 INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN IERROR = 40 INT_VAL(1) = 1 STRINGS(1) = TRANS//'\0' @@ -256,8 +259,8 @@ C C Error handling C IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 END IF C @@ -301,12 +304,12 @@ C P=LWORKB+1 CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) + & WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) LWORKS = IDINT(WORK(P+LWORKC)) IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF CALL DLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) ELSE IF(.NOT.LP .AND. RP) THEN @@ -316,12 +319,12 @@ C P=LWORKB+1 CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) + & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) LWORKS = IDINT(WORK(P)) IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF ELSE IF(.NOT.RP .AND. LP) THEN C @@ -329,12 +332,12 @@ C Only left permutation required C P=LWORKC+1 CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR) + & B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR) LWORKS = IDINT(WORK(P)) IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF CALL DLPUPD(M,N,PL,WORK,M,BETA,C,LDC) @@ -343,12 +346,12 @@ C C No permutations required C CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) + & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) LWORKS = IDINT(WORK(1)) IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF ENDIF 9998 CONTINUE @@ -365,8 +368,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/f77/dcsnmi.f b/base/serial/f77/dcsnmi.f index 89f16449f..20b534932 100644 --- a/base/serial/f77/dcsnmi.f +++ b/base/serial/f77/dcsnmi.f @@ -95,7 +95,9 @@ C Notes C ===== C FUNCTION DCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) + & INFOA,IERROR) + use psb_const_mod + use psb_string_mod use psb_const_mod IMPLICIT NONE real(psb_dpk_) dcsnmi @@ -126,49 +128,49 @@ C CALL FCPSB_ERRACTIONSAVE(ERR_ACT) IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 + IERROR = 40 + INT_VAL(1) = 1 ENDIF C C Error handling C IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Check for M, N, K C IF(M.LE.0 .OR. N.LE.0) THEN - DCSNMI = 0.D0 - GOTO 9999 + DCSNMI = 0.D0 + GOTO 9999 ENDIF C ... Compute infinity norm for matrix A ... - IF (FIDA(1:3).EQ.'CSR') THEN - DCSNMI = DCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (FIDA(1:3).EQ.'JAD') THEN - DCSNMI = DJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (FIDA(1:3).EQ.'COO') THEN - DCSNMI = DCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + DCSNMI = DCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN + DCSNMI = DJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + DCSNMI = DCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) ELSE C C This data structure not yet considered C - IERROR = 3010 + IERROR = 3010 ENDIF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -178,8 +180,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/f77/dcsrp.f b/base/serial/f77/dcsrp.f index 546ddbc15..cce602437 100644 --- a/base/serial/f77/dcsrp.f +++ b/base/serial/f77/dcsrp.f @@ -121,6 +121,7 @@ C + P,WORK,LWORK,IERROR) use psb_const_mod use psb_error_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK, M, N, IERROR @@ -148,45 +149,47 @@ C CALL FCPSB_ERRACTIONSAVE(ERR_ACT) IF (M.LE.0) THEN - IERROR = 1 + IERROR = 1 ELSE IF(N.LE.0) THEN - IERROR = 3 - ELSE IF(TRANS.NE.'N' .AND. TRANS.NE.'T' .AND. TRANS.NE.'C') THEN - IERROR = -1 + IERROR = 3 + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = -1 ENDIF C C Error handling C IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Check for M, N, P C IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - GOTO 9999 + GOTO 9999 ENDIF C C Switching on FIDA C - IF (FIDA(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN C C Permuting CSR structure C - CALL DCSRRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) - ELSE IF (FIDA(1:3).EQ.'JAD') THEN + CALL DCSRRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN if (debug_level >= psb_debug_serial_comp_) + write(debug_unit,*) trim(name), + ': Calling djadrp',m,p(1),lwork - CALL DJADRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) + CALL DJADRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) ELSE C C This data structure not yet considered C - IERROR = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 4 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -196,8 +199,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/f77/dcsrws.f b/base/serial/f77/dcsrws.f index fce7aeb0b..6354c38d1 100644 --- a/base/serial/f77/dcsrws.f +++ b/base/serial/f77/dcsrws.f @@ -101,7 +101,9 @@ C ROWSUM(M) if the subroutine in called with the 'N' option C ROWSUM(N) in other cases ('T' or 'C' options). C SUBROUTINE DCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) + & INFOA,ROWSUM,IERROR) + use psb_const_mod + use psb_string_mod use psb_const_mod IMPLICIT NONE C .. Scalar Arguments .. @@ -110,7 +112,7 @@ C .. Scalar Arguments .. C .. Array Arguments .. INTEGER IA1(*),IA2(*),INFOA(*) CHARACTER DESCRA*11, FIDA*5 - real(psb_dpk_) A(*), ROWSUM(*) + real(psb_dpk_) A(*), ROWSUM(*) C .. Local Array.. INTEGER INT_VAL(5), ERR_ACT CHARACTER*30 NAME,STRINGS(2) @@ -123,46 +125,48 @@ C IERROR = 0 NAME = 'DCSRWS\0' IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' ENDIF C C Error handling C IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF IF(M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 + GOTO 9999 ENDIF - IF (FIDA(1:3).EQ.'CSR') THEN - CALL DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (FIDA(1:3).EQ.'COO') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + CALL DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN CALL DCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (FIDA(1:3).EQ.'JAD') THEN + + INFOA,ROWSUM,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) + + INFOA,ROWSUM,IERROR) ELSE C C This data structure not yet considered C - IERROR = 3010 - strings(1) = fida//'\0' + IERROR = 3010 + strings(1) = fida//'\0' ENDIF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -172,8 +176,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/f77/dcssm.f b/base/serial/f77/dcssm.f index 74d194bc8..cd3d60316 100644 --- a/base/serial/f77/dcssm.f +++ b/base/serial/f77/dcssm.f @@ -194,11 +194,12 @@ C have to be performed. C C SUBROUTINE DCSSM(TRANS,M,N,ALPHA,UNITD,D, - + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, + + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) C .. Scalar Arguments .. use psb_const_mod use psb_error_mod + use psb_string_mod IMPLICIT NONE real(psb_dpk_) ALPHA, BETA INTEGER N, LDB, LDC, M, LWORK, IERROR @@ -209,7 +210,6 @@ C .. Array Arguments .. CHARACTER DESCRT*11, FIDT*5 C .. Local Scalars .. INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT - real(psb_dpk_) ZERO LOGICAL LP, RP C .. Local Array.. INTEGER INT_VAL(5) @@ -217,8 +217,7 @@ C .. Local Array.. CHARACTER NAME*20 integer :: debug_level, debug_unit -C .. Parameters .. - PARAMETER (ZERO=0.D0) + C .. External Subroutines .. EXTERNAL DSWSM, DLPUPD C .. Intrinsic Functions .. @@ -234,42 +233,46 @@ C debug_level = psb_get_debug_level() IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (UNITD.NE.'U' .AND. UNITD.NE.'L' .AND. UNITD.NE.'R' & - & .AND. UNITD.NE.'B') THEN - IERROR = 40 - INT_VAL(1) = 5 - STRINGS(1) = UNITD//'\0' + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ELSE IF (psb_toupper(UNITD).NE.'U' .AND. + + psb_toupper(UNITD).NE.'L' .AND. + + psb_toupper(UNITD).NE.'R' .AND. + + psb_toupper(UNITD).NE.'B') THEN + IERROR = 40 + INT_VAL(1) = 5 + STRINGS(1) = UNITD//'\0' ELSE IF (LDB.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 16 - INT_VAL(2) = 2 - INT_VAL(3) = LDB - INT_VAL(4) = M + IERROR = 50 + INT_VAL(1) = 16 + INT_VAL(2) = 2 + INT_VAL(3) = LDB + INT_VAL(4) = M ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 19 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M + IERROR = 50 + INT_VAL(1) = 19 + INT_VAL(2) = 2 + INT_VAL(3) = LDC + INT_VAL(4) = M ENDIF C C Error handling C IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C @@ -283,19 +286,19 @@ C IF (LP) LWORKM = LWORKM + LWORKB P = LWORKB+1 IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 60 + INT_VAL(1) = 21 + INT_VAL(2) = LWORKM + INT_VAL(3) = LWORK + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF LWORKS = LWORK - LWORKM C Check for M, N C IF (M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 + GOTO 9999 ENDIF C C Switching on xP @@ -307,17 +310,17 @@ C if (debug_level >= psb_debug_serial_comp_) + write(debug_unit,*) trim(name),': RP LP ',m,n,ierror - CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) - LWORKS = IDINT(WORK(P+LWORKB)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL DLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) + CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,DZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) + LWORKS = IDINT(WORK(P+LWORKB)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL DLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) ELSE IF(.NOT.LP .AND. RP) THEN C C Only right permutation required @@ -325,48 +328,48 @@ C if (debug_level >= psb_debug_serial_comp_) + write(debug_unit,*) trim(name),': RP NLP ',m,n,ierror - CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,C,LDC,WORK(P),LWORK,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - NAME = 'DCSSM\0' - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF + CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,DZERO,C,LDC,WORK(P),LWORK,IERROR) + LWORKS = IDINT(WORK(P)) + IF(IERROR .NE. 0) THEN + NAME = 'DCSSM\0' + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF ELSE IF(.NOT.RP .AND. LP) THEN C C Only left permutation required C if (debug_level >= psb_debug_serial_comp_) + write(debug_unit,*) trim(name),': NRP LP ',m,n,ierror - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL DLPUPD(M,N,PL,WORK,M,BETA,C,LDC) + CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) + LWORKS = IDINT(WORK(P)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL DLPUPD(M,N,PL,WORK,M,BETA,C,LDC) ELSE IF(.NOT.RP .AND. .NOT.LP) THEN C C Only triangular systems solver required C if (debug_level >= psb_debug_serial_comp_) + write(debug_unit,*) trim(name),': NRP NLP ',m,n,ierror - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - LWORKS = IDINT(WORK(1)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF + CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + LWORKS = IDINT(WORK(1)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF ENDIF C @@ -381,8 +384,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/f77/dgelp.f b/base/serial/f77/dgelp.f index c256b9f5d..bf3cdf0e7 100644 --- a/base/serial/f77/dgelp.f +++ b/base/serial/f77/dgelp.f @@ -92,6 +92,7 @@ C C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LDB, M, N, LWORK, IERROR @@ -120,42 +121,43 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - isnotran = psb_lsame(trans,'N') - istran = psb_lsame(trans,'T') .or. psb_lsame(trans,'C') + isnotran = psb_lsame(psb_toupper(trans),'N') + istran = psb_lsame(psb_toupper(trans),'T') .or. + + psb_lsame(psb_toupper(trans),'C') IF (M.LT.0) THEN - IERROR = 7 + IERROR = 7 ELSE IF(N.LT.0) THEN - IERROR = 3 + IERROR = 3 ELSE IF(M.GT.LDB) THEN - IERROR = -6 + IERROR = -6 ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN + IF (LWORK.EQ.0) THEN C C Return minimum LWORK C - IERROR = 8 - WORK(1) = DBLE(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF + IERROR = 8 + WORK(1) = DBLE(M) + GOTO 9998 + ELSE IF(LWORK.NE.0) THEN + IERROR = -8 + ENDIF ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 + IERROR = -1 ENDIF C C Error handling C IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Check for M, N, P C IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Switch on TRANS @@ -164,26 +166,26 @@ C C C Permuting with P C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE + DO 60 J = 1, N + DO 20 I = 1, M + WORK(I) = B(P(I),J) + 20 CONTINUE + DO 40 I = 1, M + B(I,J) = WORK(I) + 40 CONTINUE + 60 CONTINUE ELSE IF (istran) THEN C C Permuting with the transpose of P. C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE + DO 160 J = 1, N + DO 120 I = 1, M + WORK(P(I)) = B(I,J) + 120 CONTINUE + DO 140 I = 1, M + B(I,J) = WORK(I) + 140 CONTINUE + 160 CONTINUE END IF 9998 CONTINUE @@ -194,8 +196,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/f77/dlpupd.f b/base/serial/f77/dlpupd.f index f0c18d192..4ab7b4771 100644 --- a/base/serial/f77/dlpupd.f +++ b/base/serial/f77/dlpupd.f @@ -97,20 +97,20 @@ C C C Performing left permutation and update C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE + DO 40 J = 1, N + DO 30 I = 1, M + C(I,J) = B(PERM(I),J) + BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE ELSE IF(BETA.EQ.0.D0) THEN C C Performing right or left permutation C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE + DO 160 J = 1, N + DO 150 I = 1, M + C(I,J) = B(PERM(I),J) + 150 CONTINUE + 160 CONTINUE ENDIF RETURN END diff --git a/base/serial/f77/dswmm.f b/base/serial/f77/dswmm.f index 34c509821..160fc4851 100644 --- a/base/serial/f77/dswmm.f +++ b/base/serial/f77/dswmm.f @@ -142,6 +142,7 @@ C SUBROUTINE DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, & & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod C .. Scalar Arguments .. INTEGER M,N,K,LDB,LDC,LWORK,IERROR CHARACTER TRANS @@ -165,7 +166,7 @@ C C Switching on FIDA: proper sparse BLAS routine is selected C according to data structure C - IF (FIDA(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN C C A, IA1, IA2 ---> AR, JA, IA C VAL, INDX, PNTR @@ -174,14 +175,14 @@ C INFOA(*) not used CALL DCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + IA2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE IF (FIDA(1:3).EQ.'JAD') THEN + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN C C INFOA(*) not used C CALL DJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + IA2,B,LDB,BETA,C,LDC,WORK,IERROR) - ELSE IF (FIDA(1:3).EQ.'COO') THEN + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN C C CALL DCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, diff --git a/base/serial/f77/dswsm.f b/base/serial/f77/dswsm.f index d32d0fd4f..656138426 100644 --- a/base/serial/f77/dswsm.f +++ b/base/serial/f77/dswsm.f @@ -153,9 +153,11 @@ C All checks on argument are performed in the calling routine. C C SUBROUTINE DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod use psb_const_mod use psb_error_mod + use psb_string_mod implicit none C .. Scalar Arguments .. INTEGER M, N, LDB, LDC, LWORK, IERROR @@ -185,9 +187,10 @@ C .. Executable Statements .. C C Check for identity matrix C - IF(DESCRT(1:1).EQ.'D' .AND. DESCRT(3:3).EQ.'U') THEN - CALL DCOPY(M,B,ONE,C,ONE) - GOTO 9998 + IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. + + psb_toupper(DESCRT(3:3)).EQ.'U') THEN + CALL DCOPY(M,B,ONE,C,ONE) + GOTO 9998 ENDIF if (debug_level >= psb_debug_serial_comp_) @@ -196,31 +199,31 @@ C C Switching on FIDT: proper sparse BLAS routine is selected C according to data structure C - IF (FIDT(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN C C T, IT1, IT2 ---> AR, JA, IA C VAL, INDX, PNTR C INFOT(*) not used C - CALL DCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, - & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE IF (FIDT(1:3).EQ.'JAD') THEN - - CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, + CALL DCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, + & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + ELSE IF (psb_toupper(FIDT(1:3)).EQ.'JAD') THEN + + CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, + 0,B,LDB,BETA,C,LDC,WORK) - - ELSE IF (FIDT(1:3).EQ.'COO') THEN + + ELSE IF (psb_toupper(FIDT(1:3)).EQ.'COO') THEN CALL DCOOSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1,IT2,INFOT, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) ELSE C C This data structure not yet considered C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 END IF @@ -232,8 +235,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/f77/saxpby.f b/base/serial/f77/saxpby.f new file mode 100644 index 000000000..0a2134161 --- /dev/null +++ b/base/serial/f77/saxpby.f @@ -0,0 +1,199 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + + integer n, m, lldx, lldy, info + real(psb_spk_) X(lldx,*), Y(lldy,*) + real(psb_spk_) alpha, beta + integer i, j + integer int_err(5) + character name*20 + name='saxpby' + + +C +C Error handling +C + info = 0 + if (m.lt.0) then + info=10 + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=10 + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=50 + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=50 + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do j=1, n + do i=1,m + y(i,j) = szero + enddo + enddo + else if (beta.eq.sone) then +c$$$ +c$$$ Do nothing! +c$$$ + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + + 9999 continue + call fcpsb_serror() + return + + end diff --git a/base/serial/f77/scsmm.f b/base/serial/f77/scsmm.f new file mode 100644 index 000000000..f3880c16a --- /dev/null +++ b/base/serial/f77/scsmm.f @@ -0,0 +1,371 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE SCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, +C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C Purpose +C ======= +C +C Computing matrix-matrix product +C C <-- ALPHA PL A PR B + BETA C or +C C <-- ALPHA PL At PR B + BETA C +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C K - INTEGER +C On entry: number of columns of matrix A (A') and +C number of rows of matrix B +C Unchanged on exit. +C +C ALPHA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C PL - INTEGER array of dimension (M) +C On entry PL specifies the row permutation of matrix A +C (PL(1) == 0 if no permutation). +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C PR - INTEGER array of dimension (K) +C On entry PR specifies the column permutation of matrix A +C (PR(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - DOUBLE PRECISION matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated with the matrix-matrix product. +C +C LDC - INTEGER +C On entry: leading dimension of C +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying SCSMM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N +C where Pr (Pl) = 1 if right (left) permutation has to +C be performed, 0 otherwise. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Local Variables +C =============== +C +C LWORKM - INTEGER +C Minimum work area dimension for SCSMM +C +C LWORKB - INTEGER +C Work area dimension for matrix B in subroutine DLPUPD +C +C LWORKC - INTEGER +C Work area dimension for matrix C in subroutine DLPUPD +C +C LWORKS - INTEGER +C Work area dimension for subroutine DSWMM +C +C P - INTEGER +C Pointer to work area +C +C LP - LOGICAL +C LP is true if left permutation is required +C +C RP - LOGICAL +C RP is true if right permutation is required +C +C Notes +C ===== +C Some tests have shown that it is more efficient to divide the +C sparse matrix-dense matrix multiplication step and the dense +C matrix permutation step, and it is more efficient to put +C together the left permutation and update (C <- xxx + BETA C) +C steps. So, the sequence of operations is: +C Right permutation DLPUPD +C Matrix-Matrix product DSWMM +C Left permutation and update DLPUPD +C In order to avoid useless memory transfer, the above scheme is +C simplified according to whether right and left permutation have to +C be performed. If left permutation is not required, the update step +C is performed in the sparse matrix-dense matrix multiplication kernel. +C +C It is not possible to call this subroutine with LWORK=0 to get # +C the minimal value for LWORK. This functionality needs a better # +C connection with DxxxMM # +C +C + SUBROUTINE SCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, + & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + IMPLICIT NONE + +C .. Scalar Arguments .. + INTEGER M,N,K,LDB,LDC,LWORK, IERROR + CHARACTER TRANS + real(psb_spk_) ALPHA,BETA +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) + CHARACTER DESCRA*11, FIDA*5 + real(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) +C .. Local Scalars .. + INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT + LOGICAL LP, RP +C .. Local Array.. + INTEGER INT_VAL(5) + CHARACTER*20 NAME + CHARACTER*30 STRINGS(2) +C .. External Subroutines .. + EXTERNAL SSWMM, SLPUPD, SSCAL + +C .. Executable Statements .. +C +C Check for argument errors +C + NAME = 'SCSMM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (K.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 4 + INT_VAL(2) = K + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ELSE IF (LDB.LT.K) THEN + IERROR = 50 + INT_VAL(1) = 15 + INT_VAL(2) = 4 + INT_VAL(3) = LDB + INT_VAL(4) = K + ELSE IF (LDC.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 18 + INT_VAL(2) = 2 + INT_VAL(3) = LDC + INT_VAL(4) = M + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + +C +C Inizializations +C + LP = PL(1).NE.0 + RP = PR(1).NE.0 + LWORKB = K*N + LWORKC = M*N + LWORKM = 0 + IF (RP) LWORKM = LWORKB + IF (LP) LWORKM = LWORKM + LWORKC + IF (LWORK.LT.LWORKM) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = LWORKM + INT_VAL(3) = LWORK + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + LWORKS = LWORK - LWORKM + +C +C Check for M, N, K +C + IF(M.GT.0 .AND. N.GT.0 .AND. K.EQ.0) THEN +C +C Only C <-- BETA C required +C +C CALL SSCAL(M,BETA,C,IONE) + ELSE IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN + GOTO 9998 + ENDIF +C +C Switching on PR and PL +C + IF (LP .AND. RP) THEN +C +C Both right and left permutation required +C + P=LWORKB+1 + CALL SLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) + CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) + LWORKS = INT(WORK(P+LWORKC)) + IF(IERROR .NE. 0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + CALL SLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) + ELSE IF(.NOT.LP .AND. RP) THEN +C +C Only right permutation required +C + P=LWORKB+1 + CALL SLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) + CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) + LWORKS = INT(WORK(P)) + IF(IERROR .NE. 0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ELSE IF(.NOT.RP .AND. LP) THEN +C +C Only left permutation required +C + P=LWORKC+1 + CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR) + LWORKS = INT(WORK(P)) + IF(IERROR .NE. 0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + CALL SLPUPD(M,N,PL,WORK,M,BETA,C,LDC) + ELSE IF(.NOT.RP .AND. .NOT.LP) THEN +C +C No permutations required +C + CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, + & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) + LWORKS = INT(WORK(1)) + IF(IERROR .NE. 0) THEN + IERROR=4011 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + 9998 CONTINUE +C +C Return minimum workarea dimension +C + LWORKM = LWORKM + LWORKS + WORK(1) = REAL(LWORKM) + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/scsnmi.f b/base/serial/f77/scsnmi.f new file mode 100644 index 000000000..756eedfd1 --- /dev/null +++ b/base/serial/f77/scsnmi.f @@ -0,0 +1,185 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C DOUBLE PRECISION FUNCTION DCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & +C & INFOA,IERROR) +C Purpose +C ======= +C +C Computing matrix infinity norm +C nrmi <-- ||A||infty or +C nrmi <-- ||At||infty +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix A. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Notes +C ===== +C + FUNCTION SCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, + & INFOA,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE + real(psb_spk_) scsnmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11, FIDA*5 + real(psb_spk_) A(*) +C .. Local Scalars.. + INTEGER ERR_ACT +C .. Local Array.. + INTEGER INT_VAL(5) +C .. External Subroutines .. + real(psb_spk_) SCRNRMI, SJDNRMI, SCOONRMI + EXTERNAL SCRNRMI, SJDNRMI, SCOONRMI + + CHARACTER*20 NAME +C .. Executable Statements .. +C +C Check for argument errors +C + IERROR = 0 + NAME = 'SCSNMI\0' + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + +C +C Check for M, N, K +C + IF(M.LE.0 .OR. N.LE.0) THEN + SCSNMI = SZERO + GOTO 9999 + ENDIF + +C ... Compute infinity norm for matrix A ... + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + SCSNMI = SCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN + SCSNMI = SJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + SCSNMI = SCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + ENDIF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/scsrws.f b/base/serial/f77/scsrws.f new file mode 100644 index 000000000..18b58d432 --- /dev/null +++ b/base/serial/f77/scsrws.f @@ -0,0 +1,183 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & +C & INFOA,ROWSUM,IERROR) +C Purpose +C ======= +C +C Computing sum of absolute values for rows of distributed matrix +C ROWSUM(IX) = ASUM(A(IX, 1..N)) +C IX = 1..M +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C ROWSUM - DOUBLE PRECISION array of dimension (*) +C On exit this vector contains the sum of absolute values +C of elements of a row (AMAX of row array). +C It is required that it has dimension: +C ROWSUM(M) if the subroutine in called with the 'N' option +C ROWSUM(N) in other cases ('T' or 'C' options). +C + SUBROUTINE SCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, + & INFOA,ROWSUM,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*) + CHARACTER DESCRA*11, FIDA*5 + real(psb_spk_) A(*), ROWSUM(*) +C .. Local Array.. + INTEGER INT_VAL(5), ERR_ACT + CHARACTER*30 NAME,STRINGS(2) +C .. Intrinsic Functions .. + INTRINSIC DBLE, IDINT +C .. Executable Statements .. +C +C Check for argument errors +C + IERROR = 0 + NAME = 'SCSRWS\0' + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IF(M.LE.0 .OR. N.LE.0) THEN + GOTO 9999 + ENDIF + + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + CALL SCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + CALL SCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN + CALL SJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,ROWSUM,IERROR) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + strings(1) = fida//'\0' + ENDIF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/scssm.f b/base/serial/f77/scssm.f new file mode 100644 index 000000000..6fa4342cc --- /dev/null +++ b/base/serial/f77/scssm.f @@ -0,0 +1,387 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, +C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C +C Solving triangular systems of equations with multiple right-hand sides +C C <-- ALPHA PL D T-1 PR B + BETA C or +C C <-- ALPHA PL D T-t PR B + BETA C or +C C <-- ALPHA PL T-1 D PR B + BETA C or +C C <-- ALPHA PL T-t D PR B + BETA C +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine operates with +C matrix T or with the transpose of T as follows: +C TRANS = 'N' -> use matrix T +C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows and columns of matrix Ty +C and number of rows of matrices B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrices B and C +C (number of right-hand sides). +C Unchanged on exit. +C +C ALPHA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - DOUBLE PRECISION array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C PL - INTEGER array of dimension (M) +C On entry PL specifies the row permutation of matrix T +C (PL(1) == 0 if no permutation). +C Unchanged on exit. +C +C FIDT - CHARACTER*5 +C On entry FIDT defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRT - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRT describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C +C T - DOUBLE PRECISION array of DIMENSION (*) +C On entry T specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IT1 - INTEGER array of dimension (*) +C On entry IT1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IT2 - INTEGER array of dimension (*) +C On entry IT2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOT - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C PR - INTEGER array of dimension (M) +C On entry PR specifies the column permutation of matrix T +C (PR(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - DOUBLE PRECISION array of dimension (LDB,*) +C On entry: matrix of right-hand sides +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION array of dimension (LDC,*) +C On exit: solutions of triangular systems +C +C LDC - INTEGER +C On entry: leading dimension of C. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DCSSM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N +C where Pr íPlù = 1 if right íleftù permutation has to +C be performed, 0 otherwise. +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Local Variables +C =============== +C +C LWORKM - INTEGER +C Minimum work area dimension for DCSSM +C +C LWORKB - INTEGER +C Work area dimension for matrices B, C in subroutines DLPUPD +C +C LWORKS - INTEGER +C Work area dimension for subroutine DSWSM +C +C P - INTEGER +C Pointer to work area +C +C LP - LOGICAL +C LP is true if left permutation is required +C +C RP - LOGICAL +C RP is true if right permutation is required +C +C Notes +C ===== +C Some tests have shown that it is more efficient to divide the +C sparse matrix-dense matrix multiplication step and the dense +C matrix permutation and update (C <- xxx + BETA C) step. +C So, the sequence of operations is: +C Right permutation DLPUPD +C Matrix-Matrix product DSWSM +C Left permutation and update DLPUPD +C In order to avoid useless memory transfer, the above scheme is +C simplified according to whether right and left permutation +C have to be performed. +C +C + SUBROUTINE SCSSM(TRANS,M,N,ALPHA,UNITD,D, + + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, + + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C .. Scalar Arguments .. + use psb_const_mod + use psb_error_mod + use psb_string_mod + IMPLICIT NONE + real(psb_spk_) ALPHA, BETA + INTEGER N, LDB, LDC, M, LWORK, IERROR + CHARACTER UNITD, TRANS +C .. Array Arguments .. + real(psb_spk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) + INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) + CHARACTER DESCRT*11, FIDT*5 +C .. Local Scalars .. + INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT + LOGICAL LP, RP +C .. Local Array.. + INTEGER INT_VAL(5) + CHARACTER*30 STRINGS(2) + CHARACTER NAME*20 + integer :: debug_level, debug_unit + + +C +C Check for argument errors +C + IERROR = 0 + NAME = 'DCSSM' + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF (M.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M + ELSE IF (N.LT.0) THEN + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' + ELSE IF (psb_toupper(UNITD).NE.'U' .AND. + + psb_toupper(UNITD).NE.'L' .AND. + + psb_toupper(UNITD).NE.'R' .AND. + + psb_toupper(UNITD).NE.'B') THEN + IERROR = 40 + INT_VAL(1) = 5 + STRINGS(1) = UNITD//'\0' + ELSE IF (LDB.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 16 + INT_VAL(2) = 2 + INT_VAL(3) = LDB + INT_VAL(4) = M + ELSE IF (LDC.LT.M) THEN + IERROR = 50 + INT_VAL(1) = 19 + INT_VAL(2) = 2 + INT_VAL(3) = LDC + INT_VAL(4) = M + ENDIF + +C +C Error handling +C + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + +C +C Inizializations +C + LP = PL(1).NE.0 + RP = PR(1).NE.0 + LWORKB = M*N + LWORKM = 0 + IF (RP) LWORKM = LWORKB + IF (LP) LWORKM = LWORKM + LWORKB + P = LWORKB+1 + IF (LWORK.LT.LWORKM) THEN + IERROR = 60 + INT_VAL(1) = 21 + INT_VAL(2) = LWORKM + INT_VAL(3) = LWORK + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + LWORKS = LWORK - LWORKM + +C Check for M, N +C + IF (M.LE.0 .OR. N.LE.0) THEN + GOTO 9999 + ENDIF +C +C Switching on xP +C + IF (LP .AND. RP) THEN +C +C Both right and left permutations required +C + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': RP LP ',m,n,ierror + + CALL SLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,SZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) + LWORKS = INT(WORK(P+LWORKB)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL SLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) + ELSE IF(.NOT.LP .AND. RP) THEN +C +C Only right permutation required +C + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': RP NLP ',m,n,ierror + + CALL SLPUPD(M,N,PR,B,LDB,BETA,WORK,M) + CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,WORK,M,SZERO,C,LDC,WORK(P),LWORK,IERROR) + LWORKS = INT(WORK(P)) + IF(IERROR .NE. 0) THEN + NAME = 'DCSSM\0' + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ELSE IF(.NOT.RP .AND. LP) THEN +C +C Only left permutation required +C + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NRP LP ',m,n,ierror + CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) + LWORKS = INT(WORK(P)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + CALL SLPUPD(M,N,PL,WORK,M,BETA,C,LDC) + ELSE IF(.NOT.RP .AND. .NOT.LP) THEN +C +C Only triangular systems solver required +C + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': NRP NLP ',m,n,ierror + CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + LWORKS = INT(WORK(1)) + IF(IERROR .NE. 0) THEN + IF (IERROR.EQ.3010) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ENDIF + +C +C Return minimum workarea dimension +C + LWORKM = LWORKM + LWORKS + WORK(1) = REAL(LWORKM) + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/sgelp.f b/base/serial/f77/sgelp.f new file mode 100644 index 000000000..d52ac1b74 --- /dev/null +++ b/base/serial/f77/sgelp.f @@ -0,0 +1,204 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C Computing +C B <-- op(P) B +C where op(P) is permutation matrix P or its transpose. +C Notice: when B is a diagonal matrix and it is stored as +C a vector whose entry i is B(i,i), this routine computes +C B <-- P B P(-1) +C where P(-1) is the inverse of P. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whetherif the routine operates with +C matrix P or with the transpose of P as follows: +C TRANS = 'N' -> use matrix P +C TRANS = 'T' OR 'C' -> use the transpose of matrix P +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix B. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B. +C Unchanged on exit. +C +C P - INTEGER array of dimension (M) +C On entry P specifies the row permutation of matrix B +C (P(1) == 0 if no permutation). +C Unchanged on exit. +C +C B - DOUBLE PRECISION array of dimension (LDB,*) +C On entry: dense matrix. +C On exit: permuted matrix. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DGELP memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C LWORK should be set as follows: +C LWORK = M +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C + SUBROUTINE SGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER LDB, M, N, LWORK, IERROR + CHARACTER TRANS +C .. Array Arguments .. + real(psb_spk_) B(LDB,*), WORK(*) + INTEGER P(*) +C .. Local Scalars .. + INTEGER I, J, ERR_ACT + logical istran,isnotran +C .. Local Arrays.. + INTEGER INT_VAL +C .. Intrinsic Functions .. + INTRINSIC DBLE + logical psb_lsame + external psb_lsame + + character*20 name +c +C .. Executable Statements .. +C +C +C Check on M, N, LDB, LWORK, TRANS +C + NAME = 'SGELP\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + isnotran = psb_lsame(psb_toupper(trans),'N') + istran = psb_lsame(psb_toupper(trans),'T') .or. + + psb_lsame(psb_toupper(trans),'C') + IF (M.LT.0) THEN + IERROR = 7 + ELSE IF(N.LT.0) THEN + IERROR = 3 + ELSE IF(M.GT.LDB) THEN + IERROR = -6 + ELSE IF (LWORK.LT.M) THEN + IF (LWORK.EQ.0) THEN +C +C Return minimum LWORK +C + IERROR = 8 + WORK(1) = REAL(M) + GOTO 9998 + ELSE IF(LWORK.NE.0) THEN + IERROR = -8 + ENDIF + ELSE IF (.not.istran.and..not.isnotran) THEN + IERROR = -1 + ENDIF +C +C Error handling +C + IF(IERROR.LT.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF +C +C Check for M, N, P +C + IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF +C +C Switch on TRANS +C + IF (isnotran) THEN +C +C Permuting with P +C + DO 60 J = 1, N + DO 20 I = 1, M + WORK(I) = B(P(I),J) + 20 CONTINUE + DO 40 I = 1, M + B(I,J) = WORK(I) + 40 CONTINUE + 60 CONTINUE + ELSE IF (istran) THEN +C +C Permuting with the transpose of P. +C + DO 160 J = 1, N + DO 120 I = 1, M + WORK(P(I)) = B(I,J) + 120 CONTINUE + DO 140 I = 1, M + B(I,J) = WORK(I) + 140 CONTINUE + 160 CONTINUE + END IF + + 9998 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/slpupd.f b/base/serial/f77/slpupd.f new file mode 100644 index 000000000..a688273ea --- /dev/null +++ b/base/serial/f77/slpupd.f @@ -0,0 +1,116 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C Subroutine SLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) +C Purpose +C ======= +C +C Computing C <-- PERM B + BETA C +C where PERM is a permutation matrix. +C +C Parameters +C ========== +C +C M - INTEGER +C On entry M specifies the number of rows of matrices +C B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry N specifies the number of columns of matrices +C B and C. +C Unchanged on exit. +C +C PERM - INTEGER array of dimension (N) +C On entry PERM specifies the values of a permutation matrix. +C Unchanged on exit. +C +C B - DOUBLE PRECISION matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry LDB holds the value of the leading dimension of B +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated as shown above. +C +C LDC - INTEGER +C On entry LDC holds the value of the leading dimension of C +C Unchanged on exit. +C +C Note +C ==== +C All checks on argument are performed in the calling routines. +C +C + SUBROUTINE SLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) + use psb_const_mod +C .. Scalar Arguments .. + INTEGER M, N, LDB, LDC + real(psb_spk_) BETA +C .. Array Arguments .. + INTEGER PERM(*) + real(psb_spk_) B(LDB,*), C(LDC,*) +C .. Local Scalars .. + INTEGER I,J +C +C .. Executable Statements .. +C +C Switching on BETA +C + IF (BETA.NE.SZERO) THEN +C +C Performing left permutation and update +C + DO 40 J = 1, N + DO 30 I = 1, M + C(I,J) = B(PERM(I),J) + BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + ELSE IF(BETA.EQ.SZERO) THEN +C +C Performing right or left permutation +C + DO 160 J = 1, N + DO 150 I = 1, M + C(I,J) = B(PERM(I),J) + 150 CONTINUE + 160 CONTINUE + ENDIF + RETURN + END diff --git a/base/serial/f77/smmp.f b/base/serial/f77/smmp.f index ce6f2546c..5c055f623 100644 --- a/base/serial/f77/smmp.f +++ b/base/serial/f77/smmp.f @@ -129,6 +129,75 @@ c$$$ write(iunit,*) length,' : ',jc(ic(i):ic(i)+length-1) c$$$ close(iunit) c$$$ iunit = iunit + 1 c$$$ write(0,*) 'SYMBMM: on exit',ic(n+1)-1,jc(ic(n+1)-1) + return + end + subroutine snumbmm(n, m, l, + * ia, ja, diaga, a, + * ib, jb, diagb, b, + * ic, jc, diagc, c, + * temp) + use psb_const_mod +c + integer ia(*), ja(*), diaga, + * ib(*), jb(*), diagb, + * ic(*), jc(*), diagc +c + real(psb_spk_) a(*), b(*), c(*), temp(*),ajj +c +c numeric matrix multiply c=a*b +c + maxlmn = max(l,m,n) + do 10 i = 1,maxlmn + temp(i) = 0. + 10 continue + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) +c +c c = a*b +c + do 50 i = 1,n + do 30 jj = ia(i),ia(i+1) +c a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) goto 30 + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif +c b = d + ... + if (diagb.eq.1 .and. j.le.minlm) + * temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(0,*) ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do 20 k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(0,*) ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + 20 continue + 30 continue +c c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif +c$$$ if (mod(i,100)==1) +c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 + do 40 j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(0,*) ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + 40 continue + 50 continue return end subroutine numbmm(n, m, l, @@ -188,6 +257,75 @@ c c = d + ... temp(i) = 0. endif c$$$ if (mod(i,100)==1) +c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 + do 40 j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(0,*) ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + 40 continue + 50 continue + return + end + subroutine cnumbmm(n, m, l, + * ia, ja, diaga, a, + * ib, jb, diagb, b, + * ic, jc, diagc, c, + * temp) +c + use psb_const_mod + integer ia(*), ja(*), diaga, + * ib(*), jb(*), diagb, + * ic(*), jc(*), diagc +c + complex(psb_spk_) a(*), b(*), c(*), temp(*),ajj +c +c numeric matrix multiply c=a*b +c + maxlmn = max(l,m,n) + do 10 i = 1,maxlmn + temp(i) = 0. + 10 continue + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) +c +c c = a*b +c + do 50 i = 1,n + do 30 jj = ia(i),ia(i+1) +c a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) goto 30 + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif +c b = d + ... + if (diagb.eq.1 .and. j.le.minlm) + * temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(0,*) ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do 20 k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(0,*) ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + 20 continue + 30 continue +c c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif +c$$$ if (mod(i,100)==1) c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 do 40 j = ic(i),ic(i+1)-1 if((jc(j)<1).or. (jc(j) > maxlmn)) then diff --git a/base/serial/f77/sswmm.f b/base/serial/f77/sswmm.f new file mode 100644 index 000000000..da02a2dc8 --- /dev/null +++ b/base/serial/f77/sswmm.f @@ -0,0 +1,211 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, +C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C Purpose +C ======= +C +C Computing C <-- ALPHA A B + BETA C or +C C <-- ALPHA At B + BETA C +C Called by DCSMM +C Actual computing performed by sparse Toolkit kernels. +C This routine selects the proper kernel for each +C data structure. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies if the routine operates with matrix A +C or with the transpose of A as follows: +C TRANS = 'N' -> use matrix A +C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows of matrix A (A') and +C number of rows of matrix C +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrix B +C and number of columns of matrix C. +C Unchanged on exit. +C +C K - INTEGER +C On entry: number of columns of matrix A (A') and +C number of rows of matrix B +C Unchanged on exit. +C +C ALPHA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C FIDA - CHARACTER*5 +C On entry FIDA defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRA - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRA describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C A - DOUBLE PRECISION array of DIMENSION (*) +C On entry A specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IA1 - INTEGER array of dimension (*) +C On entry IA1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IA2 - INTEGER array of dimension (*) +C On entry IA2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOA - INTEGER array of length 10. +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C B - DOUBLE PRECISION matrix of dimension (LDB,*) +C On entry: dense matrix. +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION matrix of dimension (LDC,*) +C On entry: dense matrix. +C On exit is updated with the matrix-matrix product. +C +C LDC - INTEGER +C On entry: leading dimension of C +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSWMM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Note +C ==== +C All checks on argument are performed in the calling routine. +C +C + SUBROUTINE SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, & + & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod +C .. Scalar Arguments .. + INTEGER M,N,K,LDB,LDC,LWORK,IERROR + CHARACTER TRANS + real(psb_spk_) ALPHA,BETA +C .. Array Arguments .. + INTEGER IA1(*),IA2(*),INFOA(*), INT_VAL(5) + CHARACTER DESCRA*11, FIDA*5 + real(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) +C .. External Subroutines .. + EXTERNAL SCSRMM + + CHARACTER*20 NAME + +C .. Executable Statements .. +C + + NAME = 'DSWMM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + +C Switching on FIDA: proper sparse BLAS routine is selected +C according to data structure +C + IF (FIDA(1:3).EQ.'CSR') THEN +C +C A, IA1, IA2 ---> AR, JA, IA +C VAL, INDX, PNTR +C INFOA(*) not used + + CALL SCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + + IA2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + + ELSE IF (FIDA(1:3).EQ.'JAD') THEN +C +C INFOA(*) not used +C + CALL SJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + + IA2,B,LDB,BETA,C,LDC,WORK,IERROR) + + ELSE IF (FIDA(1:3).EQ.'COO') THEN +C +C + CALL SCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + + IA2,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/sswsm.f b/base/serial/f77/sswsm.f new file mode 100644 index 000000000..dff7e4784 --- /dev/null +++ b/base/serial/f77/sswsm.f @@ -0,0 +1,242 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C SUBROUTINE DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, +C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) +C +C Purpose +C ======= +C +C Solving triangular systems of equations with multiple right-hand sides +C C <-- ALPHA D T-1 B + BETA C or +C C <-- ALPHA D T-t B + BETA C or +C C <-- ALPHA T-1 D B + BETA C or +C C <-- ALPHA T-t D B + BETA C +C Actual computing performed by sparse Toolkit kernels. +C This routine selects the proper kernel for each +C data structure. +C +C Parameters +C ========== +C +C TRANS - CHARACTER*1 +C On entry TRANS specifies whether the routine operates with +C matrix T or with the transpose of T as follows: +C TRANS = 'N' -> use matrix T +C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) +C Unchanged on exit. +C +C M - INTEGER +C On entry: number of rows and columns of matrix T +C and number of rows of matrices B and C. +C Unchanged on exit. +C +C N - INTEGER +C On entry: number of columns of matrices B and C +C (number of right-hand sides). +C Unchanged on exit. +C +C ALPHA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C UNITD - CHARACTER*1 +C On entry UNITD specifies whether the diagonal matrix is unit +C or whether row or column scaling has to be performed, as follows: +C UNITD = 'U' -> unit matrix (no scaling) +C UNITD = 'L' -> scale on the left (row scaling) +C UNITD = 'R' -> scale on the right (column scaling) +C UNITD = 'B' -> scale on the right and on the left +C with D^1/2 +C Unchanged on exit. +C +C D - DOUBLE PRECISION array of dimension (M) +C On entry D specifies the main diagonal of the matrix used +C for scaling. +C Unchanged on exit. +C +C FIDT - CHARACTER*5 +C On entry FIDT defines the format of the input sparse matrix. +C Unchanged on exit. +C +C DESCRT - CHARACTER*1 array of DIMENSION (9) +C On entry DESCRT describes the characteristics of the input +C sparse matrix. +C Unchanged on exit. +C +C +C T - DOUBLE PRECISION array of DIMENSION (*) +C On entry T specifies the values of the input sparse +C matrix. +C Unchanged on exit. +C +C IT1 - INTEGER array of dimension (*) +C On entry IT1 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C IT2 - INTEGER array of dimension (*) +C On entry IT2 holds integer information on input sparse +C matrix. Actual information will depend on data format used. +C Unchanged on exit. +C +C INFOT - INTEGER array of dimension (10) +C On entry can hold auxiliary information on input matrices +C formats or environment of subsequent calls. +C Might be changed on exit. +C +C B - DOUBLE PRECISION array of dimension (LDB,*) +C On entry: matrix of right-hand sides +C Unchanged on exit. +C +C LDB - INTEGER +C On entry: leading dimension of B. +C Unchanged on exit. +C +C BETA - DOUBLE PRECISION +C On entry: multiplicative constant. +C Unchanged on exit. +C +C C - DOUBLE PRECISION array of dimension (LDC,*) +C On exit: solutions of triangular systems +C +C LDC - INTEGER +C On entry: leading dimension of C. +C Unchanged on exit. +C +C WORK - DOUBLE PRECISION array of dimension (LWORK) +C On entry: work area. +C On exit INT(WORK(1)) contains the minimum value +C for LWORK satisfying DSWSM memory requirements. +C +C LWORK - INTEGER +C On entry LWORK specifies the dimension of WORK +C Unchanged on exit. +C +C IERROR - INTEGER +C On exit IERROR contains the value of error flag as follows: +C IERROR = 0 no error +C IERROR > 0 warning +C IERROR < 0 fatal error +C +C Note +C ==== +C All checks on argument are performed in the calling routine. +C +C + SUBROUTINE SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, + & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_error_mod + use psb_string_mod + implicit none +C .. Scalar Arguments .. + INTEGER M, N, LDB, LDC, LWORK, IERROR + CHARACTER UNITD, TRANS + real(psb_dpk_) ALPHA, BETA +C .. Array Arguments .. + INTEGER IT1(*), IT2(*), INFOT(*) + CHARACTER DESCRT*11, FIDT*5 + real(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) +C .. Local Scalars .. + INTEGER ONE +C .. Parameters .. + PARAMETER (ONE=1) +C .. External Subroutines .. + EXTERNAL DCSRSM, DCOPY + integer debug_level, debug_unit, err_act, int_val(5) + CHARACTER*20 NAME + +C .. Executable Statements .. + + NAME = 'DSWSM' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + +C +C Check for identity matrix +C + IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. + + psb_toupper(DESCRT(3:3)).EQ.'U') THEN + CALL SCOPY(M,B,ONE,C,ONE) + GOTO 9998 + ENDIF + + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': entry ',m,n,ierror,' ',unitd +C +C Switching on FIDT: proper sparse BLAS routine is selected +C according to data structure +C + IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN +C +C T, IT1, IT2 ---> AR, JA, IA +C VAL, INDX, PNTR +C INFOT(*) not used +C + CALL SCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, + & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + ELSE IF (psb_toupper(FIDT(1:3)).EQ.'JAD') THEN + + CALL SJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, + + 0,B,LDB,BETA,C,LDC,WORK) + + ELSE IF (psb_toupper(FIDT(1:3)).EQ.'COO') THEN + + CALL SCOOSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1,IT2,INFOT, + + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + + ELSE +C +C This data structure not yet considered +C + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF + + 9998 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/f77/zcsmm.f b/base/serial/f77/zcsmm.f index 8850b6c09..8dd52ca99 100644 --- a/base/serial/f77/zcsmm.f +++ b/base/serial/f77/zcsmm.f @@ -193,6 +193,7 @@ C SUBROUTINE ZCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER M,N,K,LDB,LDC,LWORK, IERROR @@ -233,7 +234,9 @@ C IERROR = 10 INT_VAL(1) = 3 INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN IERROR = 40 INT_VAL(1) = 1 STRINGS(1) = TRANS//'\0' diff --git a/base/serial/f77/zcsnmi.f b/base/serial/f77/zcsnmi.f index ed268e682..34262d121 100644 --- a/base/serial/f77/zcsnmi.f +++ b/base/serial/f77/zcsnmi.f @@ -94,7 +94,9 @@ C Notes C ===== C FUNCTION ZCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) + & INFOA,IERROR) + use psb_const_mod + use psb_string_mod use psb_const_mod IMPLICIT NONE real(psb_dpk_) zcsnmi @@ -120,52 +122,54 @@ C CALL FCPSB_ERRACTIONSAVE(ERR_ACT) IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M + IERROR = 10 + INT_VAL(1) = 2 + INT_VAL(2) = M ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' + IERROR = 10 + INT_VAL(1) = 3 + INT_VAL(2) = N + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN + IERROR = 40 + INT_VAL(1) = 1 + STRINGS(1) = TRANS//'\0' ENDIF C C Error handling C IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Check for M, N, K C IF(M.LE.0 .OR. N.LE.0) THEN - ZCSNMI = 0.D0 - GOTO 9999 + ZCSNMI = 0.D0 + GOTO 9999 ENDIF C ... Compute infinity norm for matrix A ... - IF (FIDA(1:3).EQ.'CSR') THEN - ZCSNMI = ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) -c$$$ ELSE IF (FIDA(1:3).EQ.'JAD') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN + ZCSNMI = ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) +c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN c$$$ ZCSNMI = ZJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, c$$$ + INFOA,IERROR) - ELSE IF (FIDA(1:3).EQ.'COO') THEN - ZCSNMI = ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN + ZCSNMI = ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, + + INFOA,IERROR) ELSE C C This data structure not yet considered C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 3010 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) RETURN @@ -174,8 +178,8 @@ C CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF RETURN END diff --git a/base/serial/f77/zcsrws.f b/base/serial/f77/zcsrws.f index 8027739b3..d220e97f7 100644 --- a/base/serial/f77/zcsrws.f +++ b/base/serial/f77/zcsrws.f @@ -102,6 +102,7 @@ C SUBROUTINE ZCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & INFOA,ROWSUM,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER M,N, IERROR @@ -132,7 +133,9 @@ C IERROR = 10 INT_VAL(1) = 3 INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN IERROR = 40 INT_VAL(1) = 1 STRINGS(1) = TRANS//'\0' @@ -150,13 +153,13 @@ C GOTO 9999 ENDIF - IF (FIDA(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN CALL ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, + INFOA,ROWSUM,IERROR) - ELSE IF (FIDA(1:3).EQ.'COO') THEN + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN CALL ZCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, + INFOA,ROWSUM,IERROR) -c$$$ ELSE IF (FIDA(1:3).EQ.'JAD') THEN +c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN c$$$ CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, c$$$ + INFOA,ROWSUM,IERROR) ELSE diff --git a/base/serial/f77/zcssm.f b/base/serial/f77/zcssm.f index 1b7169fab..97e5094f6 100644 --- a/base/serial/f77/zcssm.f +++ b/base/serial/f77/zcssm.f @@ -197,6 +197,7 @@ C + FIDT,DESCRT,T,IT1,IT2,INFOT,PR,B,LDB,BETA,C,LDC, + WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod C .. Scalar Arguments .. IMPLICIT NONE complex(psb_dpk_) ALPHA, BETA @@ -216,7 +217,7 @@ C .. Local Array.. C .. Parameters .. PARAMETER (ZERO = (0.D0, 0.D0)) C .. External Subroutines .. - EXTERNAL ZSWSM, ZLPUPD, XERBLA + EXTERNAL ZSWSM, ZLPUPD C .. Intrinsic Functions .. INTRINSIC DBLE, IDINT C .. Executable Statements .. @@ -234,12 +235,16 @@ C IERROR = 10 INT_VAL(1) = 3 INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN + ELSE IF (psb_toupper(TRANS).NE.'T' .AND. + + psb_toupper(TRANS).NE.'N' .AND. + + psb_toupper(TRANS).NE.'C') THEN IERROR = 40 INT_VAL(1) = 1 STRINGS(1) = TRANS//'\0' - ELSE IF (UNITD.NE.'U' .AND. UNITD.NE.'L' .AND. UNITD.NE.'R' & - & .AND. UNITD.NE.'B') THEN + ELSE IF (psb_toupper(UNITD).NE.'U' .AND. + + psb_toupper(UNITD).NE.'L' .AND. + + psb_toupper(UNITD).NE.'R' .AND. + + psb_toupper(UNITD).NE.'B') THEN IERROR = 40 INT_VAL(1) = 5 STRINGS(1) = UNITD//'\0' @@ -261,9 +266,7 @@ C C Error handling C IF(IERROR.NE.0) THEN - write(0,*) 'zcssm ierror',ierror CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 ENDIF @@ -369,9 +372,9 @@ C IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() + CALL FCPSB_SERROR() ENDIF RETURN - + END diff --git a/base/serial/f77/zgelp.f b/base/serial/f77/zgelp.f index 46687cae2..1b7b807e7 100644 --- a/base/serial/f77/zgelp.f +++ b/base/serial/f77/zgelp.f @@ -92,6 +92,7 @@ C C SUBROUTINE ZGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LDB, M, N, LWORK, IERROR @@ -116,46 +117,47 @@ C C C Check on M, N, LDB, LWORK, TRANS C - NAME = 'DGELP\0' + NAME = 'ZGELP\0' IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - isnotran = psb_lsame(trans,'N') - istran = psb_lsame(trans,'T') .or. psb_lsame(trans,'C') + isnotran = psb_lsame(psb_toupper(trans),'N') + istran = psb_lsame(psb_toupper(trans),'T') .or. + + psb_lsame(psb_toupper(trans),'C') IF (M.LT.0) THEN - IERROR = 7 + IERROR = 7 ELSE IF(N.LT.0) THEN - IERROR = 3 + IERROR = 3 ELSE IF(M.GT.LDB) THEN - IERROR = -6 + IERROR = -6 ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN + IF (LWORK.EQ.0) THEN C C Return minimum LWORK C - IERROR = 8 - WORK(1) = DBLE(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF + IERROR = 8 + WORK(1) = DBLE(M) + GOTO 9998 + ELSE IF(LWORK.NE.0) THEN + IERROR = -8 + ENDIF ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 + IERROR = -1 ENDIF C C Error handling C IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Check for M, N, P C IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C C Switch on TRANS @@ -164,26 +166,26 @@ C C C Permuting with P C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE + DO 60 J = 1, N + DO 20 I = 1, M + WORK(I) = B(P(I),J) + 20 CONTINUE + DO 40 I = 1, M + B(I,J) = WORK(I) + 40 CONTINUE + 60 CONTINUE ELSE IF (istran) THEN C C Permuting with the transpose of P. C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE + DO 160 J = 1, N + DO 120 I = 1, M + WORK(P(I)) = B(I,J) + 120 CONTINUE + DO 140 I = 1, M + B(I,J) = WORK(I) + 140 CONTINUE + 160 CONTINUE END IF 9998 CONTINUE @@ -194,8 +196,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/f77/zlpupd.f b/base/serial/f77/zlpupd.f index e3b92eadc..80e682a02 100644 --- a/base/serial/f77/zlpupd.f +++ b/base/serial/f77/zlpupd.f @@ -97,20 +97,20 @@ C C C Performing left permutation and update C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE + DO 40 J = 1, N + DO 30 I = 1, M + C(I,J) = B(PERM(I),J) + BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE ELSE IF(BETA.EQ.(0.D0,0.d0)) THEN C C Performing right or left permutation C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE + DO 160 J = 1, N + DO 150 I = 1, M + C(I,J) = B(PERM(I),J) + 150 CONTINUE + 160 CONTINUE ENDIF RETURN END diff --git a/base/serial/f77/zswmm.f b/base/serial/f77/zswmm.f index b5b27296f..3f9ea0e27 100644 --- a/base/serial/f77/zswmm.f +++ b/base/serial/f77/zswmm.f @@ -145,7 +145,9 @@ C All checks on argument are performed in the calling routine. C C SUBROUTINE ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, - & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod + use psb_string_mod use psb_const_mod C .. Scalar Arguments .. INTEGER M,N,K,LDB,LDC,LWORK,IERROR @@ -170,7 +172,7 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (FIDA(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN C C A, IA1, IA2 ---> AR, JA, IA C VAL, INDX, PNTR @@ -180,13 +182,13 @@ C INFOA(*) not used C C JAD format not jet implemented C - ELSE IF (FIDA(1:3).EQ.'COO') THEN + ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN C C INFOA(*) not used C CALL ZCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, + IA2,INFOA,B,LDB,BETA,C,LDC,WORK) - ELSE IF ((FIDA(1:3).EQ.'JAD').AND.(.FALSE.)) THEN + ELSE IF ((psb_toupper(FIDA(1:3)).EQ.'JAD').AND.(.FALSE.)) THEN C C INFOA(*) not used C @@ -210,8 +212,8 @@ C CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF END diff --git a/base/serial/f77/zswsm.f b/base/serial/f77/zswsm.f index e982c4f06..59e389d74 100644 --- a/base/serial/f77/zswsm.f +++ b/base/serial/f77/zswsm.f @@ -155,6 +155,7 @@ C SUBROUTINE ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) use psb_const_mod + use psb_string_mod C .. Scalar Arguments .. INTEGER M, N, LDB, LDC, LWORK, IERROR CHARACTER UNITD, TRANS @@ -179,7 +180,8 @@ C .. Executable Statements .. C C Check for identity matrix C - IF(DESCRT(1:1).EQ.'D' .AND. DESCRT(3:3).EQ.'U') THEN + IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. + + psb_toupper(DESCRT(3:3)).EQ.'U') THEN CALL ZCOPY(M,B,ONE,C,ONE) GOTO 9999 ENDIF @@ -187,7 +189,7 @@ C C Switching on FIDT: proper sparse BLAS routine is selected C according to data structure C - IF (FIDT(1:3).EQ.'CSR') THEN + IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN C C T, IT1, IT2 ---> AR, JA, IA C VAL, INDX, PNTR @@ -195,7 +197,8 @@ C INFOT(*) not used C CALL ZCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, & IT2,B,LDB,BETA,C,LDC,WORK,LWORK) - ELSE IF ((FIDT(1:3).EQ.'JAD').AND.(.FALSE.)) THEN + ELSE IF ((psb_toupper(FIDT(1:3)).EQ.'JAD') + + .AND.(.FALSE.)) THEN C C .. JAD format not yet supported C diff --git a/base/serial/jad/Makefile b/base/serial/jad/Makefile index ec1c0fa3b..d4ad43964 100644 --- a/base/serial/jad/Makefile +++ b/base/serial/jad/Makefile @@ -4,7 +4,9 @@ include ../../../Make.inc # FOBJS = djadmm.o djadmv.o djadsm.o djadsv.o djdnrmi.o djadnr.o\ - djadmv2.o djadmv3.o djadmv4.o djadrws.o djdrws.o + djadmv2.o djadmv3.o djadmv4.o djadrws.o djdrws.o \ + sjadmm.o sjadmv.o sjadsm.o sjadsv.o sjdnrmi.o sjadnr.o\ + sjadmv2.o sjadmv3.o sjadmv4.o sjadrws.o sjdrws.o OBJS=$(FOBJS) diff --git a/base/serial/jad/sjadmm.f b/base/serial/jad/sjadmm.f new file mode 100644 index 000000000..9ec434823 --- /dev/null +++ b/base/serial/jad/sjadmm.f @@ -0,0 +1,144 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SJADMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, + * JA,IA,B,LDB,BETA,C,LDC,WORK,IERROR) + use psb_const_mod + IMPLICIT NONE +C +C +C .. Scalar Arguments .. + real(psb_spk_) ALPHA, BETA + INTEGER K, LDB, LDC, M, N,IERROR + CHARACTER TRANSA +C .. Array Arguments .. + real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) + INTEGER IA(*), JA(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + integer PIA, PJA, PNG + INTEGER I, J, KB,NB, ERR_ACT + CHARACTER DIAG, TRANS +c .. Local Arrays .. + CHARACTER*20 NAME + INTEGER INT_VAL(5) +C .. Executable Statements .. +C + + NAME = 'DJADMM\0' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + + TRANS = TRANSA + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' + IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' + IF (DESCRA(1:1).EQ.'D') THEN + IF (DESCRA(3:3).EQ.'U') THEN + DO 40 I = 1, K + DO 20 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) + 20 CONTINUE + 40 CONTINUE + ELSE + DO 80 I = 1, K + DO 60 J = 1, M + C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) + 60 CONTINUE + 80 CONTINUE + END IF + RETURN + END IF + IF (TRANS.EQ.'T'.or.TRANS.EQ.'C') THEN + IERROR = 3015 + RETURN + ENDIF +C + IF (DESCRA(3:3).EQ.'N') DIAG = 'N' + IF (DESCRA(3:3).EQ.'U') DIAG = 'U' + PNG = IA(1) + PIA = IA(2) + PJA = IA(3) +* write(6,*)'M N K',m,n,k + + NB = 4 + KB = MOD(K,NB) + + SELECT CASE(KB) + CASE (1) + IF (K==1) THEN + CALL SJADMV(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,1),BETA,C(1,1),IERROR) + ELSE + CALL SJADMV2(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) + CALL SJADMV3(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,3),LDB,BETA,C(1,3),LDC,IERROR) + KB = KB + 4 + ENDIF + CASE(2) + CALL SJADMV2(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) + CASE(3) + CALL SJADMV3(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) + + END SELECT + + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + DO I=KB+1,K,NB + CALL SJADMV4(DIAG,M,N,ALPHA,IA(PNG), + + AR,JA,IA(PJA),IA(PIA),B(1,I),LDB,BETA,C(1,I),LDC,IERROR) + END DO + + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/jad/sjadmv.f b/base/serial/jad/sjadmv.f new file mode 100644 index 000000000..345e4e5c4 --- /dev/null +++ b/base/serial/jad/sjadmv.f @@ -0,0 +1,351 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* PROCEDURAL LOGIC SECTION * +* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * +* DOUBLE PRECISION ZERO * +* PARAMETER (ZERO=0.0D0) * +* DOUBLE PRECISION ACC * +* INTEGER I, J, K, IPX, IPG * +* LOGICAL UNI * +*C .. Executable Statements .. * +*C * +*C * +* IF (DIAG.EQ.'U') THEN * +* DO 10 I = 1, M * +* Y(I) = BETA*Y(I) + ALPHA*X(I) * +* 10 CONTINUE * +* ELSE * +* DO 20 I = 1, M * +* Y(I) = BETA*Y(I) * +* 20 CONTINUE * +* END IF * +* * +* IF (ALPHA.EQ.ZERO) THEN * +* RETURN * +* END IF * +*C * +*C * +*C 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 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* IPX = IPX + 1 * +* 40 CONTINUE * +* 50 CONTINUE * +*C * +*C * +* IPX = IA(1,IPG) * +* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * +* DO 60 I = JA(K), JA(K+1) - 1 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* 60 CONTINUE * +* IPX = IPX + 1 * +* 70 CONTINUE * +* 200 CONTINUE * +*C * +* RETURN * +*C * +*C * +* END * +* * +* * +*********************************************************************** + SUBROUTINE SJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X, + + BETA,Y,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) A(*),X(*),Y(*),ALPHA,BETA + INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,IERROR + CHARACTER DIAG + INTEGER I, K, IPX, IPG, I0, IN + INTEGER NPG + real(psb_spk_) Y0, Y1, Y2, Y3, Y4, Y5, Y6, Y7, + + Y8, Y9, Y10, Y11, Y12, Y13, Y14, Y15 +c .. Executable Statements .. +c +c + IERROR=0 + IF (DIAG.EQ.'U') THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I) = ALPHA*X(I) + ENDDO + ELSE + DO 10 I = 1, NROW + Y(I) = BETA*Y(I) + ALPHA*X(I) + 10 CONTINUE + ENDIF + ELSE + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I) = 0.D0 + ENDDO + ELSE + DO 20 I = 1, NROW + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ENDIF + + IF (ALPHA.EQ.SZERO) THEN + RETURN + END IF +c +c + DO 200 IPG = 1, NG + K = IA(2,IPG) + NPG = JA(K+1)-JA(K) + + IF (NPG.EQ.4) THEN + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+3, 4 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + + ELSE IF (NPG.EQ.5) THEN + + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + Y4 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+4, 5 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + Y4 = Y4 + A(I+4)*X(KA(I+4)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 + + ELSE IF (NPG.EQ.6) THEN + + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + Y4 = SZERO + Y5 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+5, 6 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + Y4 = Y4 + A(I+4)*X(KA(I+4)) + Y5 = Y5 + A(I+5)*X(KA(I+5)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 + Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 + + ELSE IF (NPG.EQ.7) THEN + + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + Y4 = SZERO + Y5 = SZERO + Y6 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+6, 7 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + Y4 = Y4 + A(I+4)*X(KA(I+4)) + Y5 = Y5 + A(I+5)*X(KA(I+5)) + Y6 = Y6 + A(I+6)*X(KA(I+6)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 + Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 + Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 + + ELSE IF (NPG.EQ.8) THEN + + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + Y4 = SZERO + Y5 = SZERO + Y6 = SZERO + Y7 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+7, 8 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + Y4 = Y4 + A(I+4)*X(KA(I+4)) + Y5 = Y5 + A(I+5)*X(KA(I+5)) + Y6 = Y6 + A(I+6)*X(KA(I+6)) + Y7 = Y7 + A(I+7)*X(KA(I+7)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 + Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 + Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 + Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 + + ELSE IF (NPG.EQ.16) THEN + + IPX = IA(1,IPG) + Y0 = SZERO + Y1 = SZERO + Y2 = SZERO + Y3 = SZERO + Y4 = SZERO + Y5 = SZERO + Y6 = SZERO + Y7 = SZERO + Y8 = SZERO + Y9 = SZERO + Y10 = SZERO + Y11 = SZERO + Y12 = SZERO + Y13 = SZERO + Y14 = SZERO + Y15 = SZERO + K = IA(2,IPG) + I0 = JA(K) + K = IA(3,IPG)-1 + IN = JA(K) + DO I = I0, IN+15, 16 + Y0 = Y0 + A(I+0)*X(KA(I+0)) + Y1 = Y1 + A(I+1)*X(KA(I+1)) + Y2 = Y2 + A(I+2)*X(KA(I+2)) + Y3 = Y3 + A(I+3)*X(KA(I+3)) + Y4 = Y4 + A(I+4)*X(KA(I+4)) + Y5 = Y5 + A(I+5)*X(KA(I+5)) + Y6 = Y6 + A(I+6)*X(KA(I+6)) + Y7 = Y7 + A(I+7)*X(KA(I+7)) + Y8 = Y8 + A(I+8)*X(KA(I+8)) + Y9 = Y9 + A(I+9)*X(KA(I+9)) + Y10 = Y10 + A(I+10)*X(KA(I+10)) + Y11 = Y11 + A(I+11)*X(KA(I+11)) + Y12 = Y12 + A(I+12)*X(KA(I+12)) + Y13 = Y13 + A(I+13)*X(KA(I+13)) + Y14 = Y14 + A(I+14)*X(KA(I+14)) + Y15 = Y15 + A(I+15)*X(KA(I+15)) + ENDDO + Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 + Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 + Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 + Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 + Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 + Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 + Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 + Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 + Y(IPX+8) = Y(IPX+8) + ALPHA*Y8 + Y(IPX+9) = Y(IPX+9) + ALPHA*Y9 + Y(IPX+10) = Y(IPX+10) + ALPHA*Y10 + Y(IPX+11) = Y(IPX+11) + ALPHA*Y11 + Y(IPX+12) = Y(IPX+12) + ALPHA*Y12 + Y(IPX+13) = Y(IPX+13) + ALPHA*Y13 + Y(IPX+14) = Y(IPX+14) + ALPHA*Y14 + Y(IPX+15) = Y(IPX+15) + ALPHA*Y15 + + ELSE + + DO K = IA(2,IPG), IA(3,IPG)-1 + IPX = IA(1,IPG) + DO I = JA(K), JA(K+1) - 1 + Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) + IPX = IPX + 1 + ENDDO + ENDDO + END IF + +c CSR Product + + IPX = IA(1,IPG) + DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 + DO 60 I = JA(K), JA(K+1) - 1 + Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) + 60 CONTINUE + IPX = IPX + 1 + 70 CONTINUE + 200 CONTINUE +c + RETURN + END + diff --git a/base/serial/jad/sjadmv2.f b/base/serial/jad/sjadmv2.f new file mode 100644 index 000000000..0d0efea4d --- /dev/null +++ b/base/serial/jad/sjadmv2.f @@ -0,0 +1,358 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* PROCEDURAL LOGIC SECTION * +* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * +* DOUBLE PRECISION ZERO * +* PARAMETER (ZERO=0.0D0) * +* DOUBLE PRECISION ACC * +* INTEGER I, J, K, IPX, IPG * +* LOGICAL UNI * +*C .. Executable Statements .. * +*C * +*C * +* IF (DIAG.EQ.'U') THEN * +* DO 10 I = 1, M * +* Y(I) = BETA*Y(I) + ALPHA*X(I) * +* 10 CONTINUE * +* ELSE * +* DO 20 I = 1, M * +* Y(I) = BETA*Y(I) * +* 20 CONTINUE * +* END IF * +* * +* IF (ALPHA.EQ.ZERO) THEN * +* RETURN * +* END IF * +*C * +*C * +*C 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 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* IPX = IPX + 1 * +* 40 CONTINUE * +* 50 CONTINUE * +*C * +*C * +* IPX = IA(1,IPG) * +* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * +* DO 60 I = JA(K), JA(K+1) - 1 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* 60 CONTINUE * +* IPX = IPX + 1 * +* 70 CONTINUE * +* 200 CONTINUE * +*C * +* RETURN * +*C * +*C * +* END * +* * +* * +*********************************************************************** + SUBROUTINE SJADMV2(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, + + X,LDX,BETA,Y,LDY, IERROR) + use psb_const_mod + IMPLICIT NONE + INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR + real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA + CHARACTER DIAG + INTEGER I, J, K, IPX, IPG, I0, IN + INTEGER NPG + integer nb + parameter (nb=2) + real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), + + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), + + Y12(NB), Y13(NB), Y14(NB), Y15(NB) +c .. Executable Statements .. +c +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb + IERROR=0 + IF (DIAG.EQ.'U') THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = ALPHA*X(I,1:NB) + ENDDO + ELSE + DO 10 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) + 10 CONTINUE + ENDIF + ELSE + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = 0.D0 + ENDDO + ELSE + DO 20 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + 20 CONTINUE + END IF + ENDIF + + IF (ALPHA.EQ.SZERO) THEN + RETURN + END IF +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta + + do 200 ipg = 1, ng + k = ia(2,ipg) + npg = ja(k+1)-ja(k) + +c$$$ write(0,*) 'djadmv2:',npg + + if (npg.eq.4) then + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+3, 4 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + + else if (npg.eq.5) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+4, 5 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + + else if (npg.eq.6) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+5, 6 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + + else if (npg.eq.7) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+6, 7 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + + else if (npg.eq.8) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+7, 8 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + + else if (npg.eq.16) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + y8(1:nb) = szero + y9(1:nb) = szero + y10(1:nb) = szero + y11(1:nb) = szero + y12(1:nb) = szero + y13(1:nb) = szero + y14(1:nb) = szero + y15(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+15, 16 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) + y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) + y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) + y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) + y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) + y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) + y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) + y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) + y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) + y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) + y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) + y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) + y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) + y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) + y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) + + else + + do k = ia(2,ipg), ia(3,ipg)-1 + ipx = ia(1,ipg) + do i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + ipx = ipx + 1 + enddo + enddo + end if + +c csr product + + ipx = ia(1,ipg) + do 70 k = ia(3,ipg), ia(2,ipg+1)-1 + do 60 i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + 60 continue + ipx = ipx + 1 + 70 continue + 200 continue +c + return + end + diff --git a/base/serial/jad/sjadmv3.f b/base/serial/jad/sjadmv3.f new file mode 100644 index 000000000..111fe7b48 --- /dev/null +++ b/base/serial/jad/sjadmv3.f @@ -0,0 +1,358 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* PROCEDURAL LOGIC SECTION * +* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * +* DOUBLE PRECISION ZERO * +* PARAMETER (ZERO=0.0D0) * +* DOUBLE PRECISION ACC * +* INTEGER I, J, K, IPX, IPG * +* LOGICAL UNI * +*C .. Executable Statements .. * +*C * +*C * +* IF (DIAG.EQ.'U') THEN * +* DO 10 I = 1, M * +* Y(I) = BETA*Y(I) + ALPHA*X(I) * +* 10 CONTINUE * +* ELSE * +* DO 20 I = 1, M * +* Y(I) = BETA*Y(I) * +* 20 CONTINUE * +* END IF * +* * +* IF (ALPHA.EQ.ZERO) THEN * +* RETURN * +* END IF * +*C * +*C * +*C 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 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* IPX = IPX + 1 * +* 40 CONTINUE * +* 50 CONTINUE * +*C * +*C * +* IPX = IA(1,IPG) * +* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * +* DO 60 I = JA(K), JA(K+1) - 1 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* 60 CONTINUE * +* IPX = IPX + 1 * +* 70 CONTINUE * +* 200 CONTINUE * +*C * +* RETURN * +*C * +*C * +* END * +* * +* * +*********************************************************************** + SUBROUTINE SJADMV3(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, + + X,LDX,BETA,Y,LDY, IERROR) + use psb_const_mod + IMPLICIT NONE + INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR + real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA + CHARACTER DIAG + INTEGER I, J, K, IPX, IPG, I0, IN + INTEGER NPG + integer nb + parameter (nb=3) + real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), + + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), + + Y12(NB), Y13(NB), Y14(NB), Y15(NB) +c .. Executable Statements .. +c +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb + IERROR=0 + IF (DIAG.EQ.'U') THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = ALPHA*X(I,1:NB) + ENDDO + ELSE + DO 10 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) + 10 CONTINUE + ENDIF + ELSE + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = 0.D0 + ENDDO + ELSE + DO 20 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + 20 CONTINUE + END IF + ENDIF + + IF (ALPHA.EQ.SZERO) THEN + RETURN + END IF +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta + + do 200 ipg = 1, ng + k = ia(2,ipg) + npg = ja(k+1)-ja(k) + +c$$$ write(0,*) 'djadmv2:',npg + + if (npg.eq.4) then + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+3, 4 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + + else if (npg.eq.5) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+4, 5 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + + else if (npg.eq.6) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+5, 6 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + + else if (npg.eq.7) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+6, 7 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + + else if (npg.eq.8) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+7, 8 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + + else if (npg.eq.16) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + y8(1:nb) = szero + y9(1:nb) = szero + y10(1:nb) = szero + y11(1:nb) = szero + y12(1:nb) = szero + y13(1:nb) = szero + y14(1:nb) = szero + y15(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+15, 16 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) + y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) + y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) + y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) + y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) + y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) + y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) + y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) + y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) + y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) + y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) + y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) + y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) + y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) + y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) + + else + + do k = ia(2,ipg), ia(3,ipg)-1 + ipx = ia(1,ipg) + do i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + ipx = ipx + 1 + enddo + enddo + end if + +c csr product + + ipx = ia(1,ipg) + do 70 k = ia(3,ipg), ia(2,ipg+1)-1 + do 60 i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + 60 continue + ipx = ipx + 1 + 70 continue + 200 continue +c + return + end + diff --git a/base/serial/jad/sjadmv4.f b/base/serial/jad/sjadmv4.f new file mode 100644 index 000000000..19c17348d --- /dev/null +++ b/base/serial/jad/sjadmv4.f @@ -0,0 +1,358 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +*********************************************************************** +* PROCEDURAL LOGIC SECTION * +* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * +* DOUBLE PRECISION ZERO * +* PARAMETER (ZERO=0.0D0) * +* DOUBLE PRECISION ACC * +* INTEGER I, J, K, IPX, IPG * +* LOGICAL UNI * +*C .. Executable Statements .. * +*C * +*C * +* IF (DIAG.EQ.'U') THEN * +* DO 10 I = 1, M * +* Y(I) = BETA*Y(I) + ALPHA*X(I) * +* 10 CONTINUE * +* ELSE * +* DO 20 I = 1, M * +* Y(I) = BETA*Y(I) * +* 20 CONTINUE * +* END IF * +* * +* IF (ALPHA.EQ.ZERO) THEN * +* RETURN * +* END IF * +*C * +*C * +*C 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 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* IPX = IPX + 1 * +* 40 CONTINUE * +* 50 CONTINUE * +*C * +*C * +* IPX = IA(1,IPG) * +* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * +* DO 60 I = JA(K), JA(K+1) - 1 * +* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * +* 60 CONTINUE * +* IPX = IPX + 1 * +* 70 CONTINUE * +* 200 CONTINUE * +*C * +* RETURN * +*C * +*C * +* END * +* * +* * +*********************************************************************** + SUBROUTINE SJADMV4(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, + + X,LDX,BETA,Y,LDY, IERROR) + use psb_const_mod + IMPLICIT NONE + INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR + real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA + CHARACTER DIAG + INTEGER I, J, K, IPX, IPG, I0, IN + INTEGER NPG + integer nb + parameter (nb=4) + real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), + + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), + + Y12(NB), Y13(NB), Y14(NB), Y15(NB) +c .. Executable Statements .. +c +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb + IERROR=0 + IF (DIAG.EQ.'U') THEN + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = ALPHA*X(I,1:NB) + ENDDO + ELSE + DO 10 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) + 10 CONTINUE + ENDIF + ELSE + IF (BETA.EQ.SZERO) THEN + DO I = 1, NROW + Y(I,1:NB) = 0.D0 + ENDDO + ELSE + DO 20 I = 1, NROW + Y(I,1:NB) = BETA*Y(I,1:NB) + 20 CONTINUE + END IF + ENDIF + + IF (ALPHA.EQ.SZERO) THEN + RETURN + END IF +c +c$$$ write(0,*) 'djadmv2:',diag,alpha,beta + + do 200 ipg = 1, ng + k = ia(2,ipg) + npg = ja(k+1)-ja(k) + +c$$$ write(0,*) 'djadmv2:',npg + + if (npg.eq.4) then + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+3, 4 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + + else if (npg.eq.5) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+4, 5 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + + else if (npg.eq.6) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+5, 6 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + + else if (npg.eq.7) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+6, 7 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + + else if (npg.eq.8) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+7, 8 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + + else if (npg.eq.16) then + + ipx = ia(1,ipg) + y0(1:nb) = szero + y1(1:nb) = szero + y2(1:nb) = szero + y3(1:nb) = szero + y4(1:nb) = szero + y5(1:nb) = szero + y6(1:nb) = szero + y7(1:nb) = szero + y8(1:nb) = szero + y9(1:nb) = szero + y10(1:nb) = szero + y11(1:nb) = szero + y12(1:nb) = szero + y13(1:nb) = szero + y14(1:nb) = szero + y15(1:nb) = szero + k = ia(2,ipg) + i0 = ja(k) + k = ia(3,ipg)-1 + in = ja(k) + do i = i0, in+15, 16 + y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) + y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) + y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) + y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) + y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) + y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) + y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) + y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) + y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) + y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) + y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) + y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) + y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) + y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) + y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) + y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) + enddo + y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) + y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) + y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) + y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) + y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) + y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) + y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) + y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) + y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) + y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) + y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) + y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) + y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) + y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) + y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) + y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) + + else + + do k = ia(2,ipg), ia(3,ipg)-1 + ipx = ia(1,ipg) + do i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + ipx = ipx + 1 + enddo + enddo + end if + +c csr product + + ipx = ia(1,ipg) + do 70 k = ia(3,ipg), ia(2,ipg+1)-1 + do 60 i = ja(k), ja(k+1) - 1 + y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) + 60 continue + ipx = ipx + 1 + 70 continue + 200 continue +c + return + end + diff --git a/base/serial/jad/sjadnr.f b/base/serial/jad/sjadnr.f new file mode 100644 index 000000000..6225172e5 --- /dev/null +++ b/base/serial/jad/sjadnr.f @@ -0,0 +1,90 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute infinity norma for sparse matrix in CSR Format ... + FUNCTION SJADNR(TRANS,M,N,NG,A,KA,JA,IA, + + INFOA,IERROR) + use psb_const_mod + use psb_spmat_type + IMPLICIT NONE + real(psb_spk_) sjadnr +C .. Scalar Arguments .. + INTEGER M,N, IERROR, NG + CHARACTER TRANS +C .. Array Arguments .. + INTEGER KA(*),JA(*),IA(3,*),INFOA(*) + real(psb_spk_) A(*) +C ... Local Array .. + real(psb_spk_) NRMI_BLOCK(PSB_MAXJDROWS_) +C ... Local Scalars .. + real(psb_spk_) NRMI + INTEGER I, K, IPG, NPG, IPX + + IERROR=0 + NRMI = 0.0 + + DO IPG = 1, NG + K = IA(2,IPG) + NPG = JA(K+1)- JA(K) + +C ... Initialize NRMI_BLOCK ... + DO I = 1, NPG + NRMI_BLOCK(I) = 0.0 + ENDDO + + DO K = IA(2,IPG), IA(3,IPG)-1 + IPX = 1 + DO I = JA(K), JA(K+1) - 1 + NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) + IPX = IPX + 1 + ENDDO + ENDDO + +C ... CSR Representation ... + + IPX = 1 + DO K = IA(3,IPG), IA(2,IPG+1)-1 + DO I = JA(K), JA(K+1) - 1 + NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) + ENDDO + IPX = IPX + 1 + ENDDO + +C ... Compute Max in Block ... + DO I = 1, NPG + IF (NRMI_BLOCK(I).GT.NRMI) THEN + NRMI = NRMI_BLOCK(I) + ENDIF + ENDDO + ENDDO + + SJADNR = NRMI + END diff --git a/base/serial/jad/sjadrws.f b/base/serial/jad/sjadrws.f new file mode 100644 index 000000000..ea2763867 --- /dev/null +++ b/base/serial/jad/sjadrws.f @@ -0,0 +1,79 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute infinity norma for sparse matrix in CSR Format ... + SUBROUTINE SJADRWS(TRANS,M,N,NG,A,KA,JA,IA, + + INFOA,ROWSUM,IERROR) + use psb_const_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR, NG + CHARACTER TRANS +C .. Array Arguments .. + INTEGER KA(*),JA(*),IA(3,*),INFOA(*) + real(psb_spk_) A(*), rowsum(*) +C ... Local Scalars .. + real(psb_spk_) NRMI + INTEGER I, IR, K, IPG, NPG, IPX + + NRMI = 0.0 + IR = 0 + DO IPG = 1, NG + K = IA(2,IPG) + NPG = JA(K+1)- JA(K) + +C ... ... + DO I = 1, NPG + ROWSUM(IR+I) = 0.0 + ENDDO + + DO K = IA(2,IPG), IA(3,IPG)-1 + IPX = 1 + DO I = JA(K), JA(K+1) - 1 + ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) + IPX = IPX + 1 + ENDDO + ENDDO + +C ... CSR Representation ... + + IPX = 1 + DO K = IA(3,IPG), IA(2,IPG+1)-1 + DO I = JA(K), JA(K+1) - 1 + ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) + ENDDO + IPX = IPX + 1 + ENDDO + + IR = IR + NPG + ENDDO + + END diff --git a/base/serial/jad/sjadsm.f b/base/serial/jad/sjadsm.f new file mode 100644 index 000000000..77f5ee0c9 --- /dev/null +++ b/base/serial/jad/sjadsm.f @@ -0,0 +1,139 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +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 SJADSM(TRANST,M,N,VDIAG,TDIAG,PERMQ,ALPHA,DESCRA, + + AR,JA,IA,PERMP,B,LDB,BETA,C,LDC,WORK) + use psb_const_mod + use psb_error_mod + use psb_string_mod + implicit none +C +C +C .. Scalar Arguments .. + INTEGER LDB, LDC, M, N + CHARACTER TDIAG, TRANST + real(psb_spk_) ALPHA, BETA +C .. Array Arguments .. + real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), VDIAG(*), WORK(*) + INTEGER IA(*), JA(*), PERMP(*), PERMQ(*) + CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER PIA, PJA, PNG + INTEGER I, K, ERR_ACT + CHARACTER UPLO,UNITD + integer :: debug_level, debug_unit + CHARACTER*20 NAME + INTEGER INT_VAL(5),ierror +C .. Executable Statements .. +C + NAME = 'DJADSM' + IERROR = 0 + CALL FCPSB_ERRACTIONSAVE(ERR_ACT) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + IF((ALPHA.NE.sone) .OR. (BETA.NE.szero))then + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + UPLO = '?' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' + IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. + + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' +C + IF (UPLO.EQ.'?') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + + IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN + IERROR=5 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF + UNITD=DESCRA(3:3) +C +C B = INV(A)*B OR B=INV(A')*B +C + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': entry',m,n + + IF (psb_toupper(TDIAG).EQ.'R') THEN + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': Right Scale' + DO I = 1, N + DO K = 1, M + B(K,I) = B(K,I)*VDIAG(K) + ENDDO + ENDDO + END IF + + PNG = IA(1) + PIA = IA(2) + PJA = IA(3) + + DO I = 1, N + CALL SJADSV(UNITD,M,IA(PNG), + + AR,JA,IA(PIA),IA(PJA),B(1,I),C(1,I),IERROR) + ENDDO + IF(IERROR.NE.0) THEN + INT_VAL(1)=IERROR + CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) + GOTO 9999 + END IF + + + IF (psb_toupper(TDIAG).EQ.'L') THEN + if (debug_level >= psb_debug_serial_comp_) + + write(debug_unit,*) trim(name),': Left Scale' + DO I = 1, N + DO K = 1, M + C(K,I) = C(K,I)*VDIAG(K) + ENDDO + ENDDO + END IF + + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + RETURN + + 9999 CONTINUE + CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + + IF ( ERR_ACT .NE. 0 ) THEN + CALL FCPSB_SERROR() + RETURN + ENDIF + + RETURN + END diff --git a/base/serial/jad/sjadsv.f b/base/serial/jad/sjadsv.f new file mode 100644 index 000000000..b3ff3a057 --- /dev/null +++ b/base/serial/jad/sjadsv.f @@ -0,0 +1,88 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C This routine compute only the casew with Unit diagonal ... + SUBROUTINE SJADSV(UNITD,NROW,NG,A,KA,IA,JA,X,Y,IERROR) + use psb_const_mod + implicit none + real(psb_spk_) A(*),X(*),Y(*) + integer IA(3,*),JA(*),KA(*),nrow,ng,i,j,k,ipg,ip2,ipx + CHARACTER UNITD + INTEGER IERROR + + IERROR=0 + + IF (UNITD.EQ.'U') THEN + + IF (NG.EQ.0) THEN + DO I = 1, NROW + Y(I) = X(I) + ENDDO + ENDIF + + DO IPG=1,NG + DO I = IA(1,IPG),IA(1,IPG+1)-1 + Y(I) = X(I) + END DO +* +* LOOP ON COLUMNS +* --------------- +* + IP2 = IA(2,IPG) + DO K = IP2, IA(3,IPG)-1 + IPX = IA(1,IPG) + DO I = JA(K), JA(K+1)-1 + Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) + IPX = IPX+1 + ENDDO + ENDDO +* +* +* LOOP ON ROWS +* --------------- +* + IPX = IA(1,IPG) + DO K = IA(3,IPG), IA(2,IPG+1)-1 + DO I = JA(K), JA(K+1)-1 + Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) + ENDDO + IPX = IPX + 1 + ENDDO + +**************************************** + END DO !END LOOP ON IPG=1,NG +**************************************** + ELSE + WRITE(0,*) 'ERROR in DJADSV' + ENDIF + RETURN + END + diff --git a/base/serial/jad/sjdnrmi.f b/base/serial/jad/sjdnrmi.f new file mode 100644 index 000000000..8d1dceb18 --- /dev/null +++ b/base/serial/jad/sjdnrmi.f @@ -0,0 +1,61 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute infinity norm for sparse matrix in CSR Format ... + FUNCTION SJDNRMI(TRANS,M,N,DESCRA,A,JA,IA, + + INFOA,IERROR) + use psb_const_mod + IMPLICIT NONE + real(psb_spk_) sjdnrmi +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER JA(*),IA(*),INFOA(*) + CHARACTER DESCRA*11 + real(psb_spk_) A(*) +C .. Local scalars .. + INTEGER PNG, PIA, PJA +C .. External routines .. + real(psb_spk_) SJADNR + EXTERNAL SJADNR + + IERROR=0 + PNG = IA(1) + PIA = IA(2) + PJA = IA(3) + sjdnrmi = 0.0 + IF (DESCRA(1:1).EQ.'G') THEN + SJDNRMI = SJADNR(TRANS,M,N,IA(PNG), + + A,JA,IA(PJA),IA(PIA), + + INFOA,IERROR) + ENDIF + END diff --git a/base/serial/jad/sjdrws.f b/base/serial/jad/sjdrws.f new file mode 100644 index 000000000..1d5ad16a8 --- /dev/null +++ b/base/serial/jad/sjdrws.f @@ -0,0 +1,60 @@ +C +C Parallel Sparse BLAS version 2.2 +C (C) Copyright 2006/2007/2008 +C Salvatore Filippone University of Rome Tor Vergata +C Alfredo Buttari University of Rome Tor Vergata +C +C Redistribution and use in source and binary forms, with or without +C modification, are permitted provided that the following conditions +C are met: +C 1. Redistributions of source code must retain the above copyright +C notice, this list of conditions and the following disclaimer. +C 2. Redistributions in binary form must reproduce the above copyright +C notice, this list of conditions, and the following disclaimer in the +C documentation and/or other materials provided with the distribution. +C 3. The name of the PSBLAS group or the names of its contributors may +C not be used to endorse or promote products derived from this +C software without specific written permission. +C +C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +C POSSIBILITY OF SUCH DAMAGE. +C +C +C ... Compute infinity norm for sparse matrix in CSR Format ... + SUBROUTINE SJDRWS(TRANS,M,N,DESCRA,A,JA,IA, + + INFOA,ROWSUM,IERROR) + use psb_const_mod + IMPLICIT NONE +C .. Scalar Arguments .. + INTEGER M,N, IERROR + CHARACTER TRANS +C .. Array Arguments .. + INTEGER JA(*),IA(*),INFOA(*) + CHARACTER DESCRA*11 + real(psb_spk_) A(*), ROWSUM(*) +C .. Local scalars .. + INTEGER PNG, PIA, PJA +C .. External routines .. + + IERROR = 0 + PNG = IA(1) + PIA = IA(2) + PJA = IA(3) + + IF (DESCRA(1:1).EQ.'G') THEN + CALL SJADRWS(TRANS,M,N,IA(PNG), + + A,JA,IA(PJA),IA(PIA), + + INFOA,ROWSUM,IERROR) + ELSE + IERROR = 3011 + ENDIF + END diff --git a/base/serial/psb_ccoins.f90 b/base/serial/psb_ccoins.f90 new file mode 100644 index 000000000..c892f15d8 --- /dev/null +++ b/base/serial/psb_ccoins.f90 @@ -0,0 +1,620 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccoins.f90 +! Subroutine: psb_ccoins +! Takes a cloud of coefficients and inserts them into a sparse matrix. +! This subroutine is the serial, inner counterpart to the outer, user-level +! psb_spins. +! +! Arguments: +! +! nz - integer, input The number of points to insert. +! ia(:) - integer, input The row indices of the coefficients. +! ja(:) - integer, input The column indices of the coefficients. +! val(:) - complex, input The values of the coefficients to be inserted. +! a - type(psb_cspmat_type), inout The sparse destination matrix. +! imin - integer, input The minimum valid row index +! imax - integer, input The maximum valid row index +! jmin - integer, input The minimum valid col index +! jmax - integer, input The maximum valid col index +! info - integer, output Return code. +! gtl(:) - integer, input,optional An index mapping to be applied +! default: identity +! rebuild - logical, input, optional Rebuild in case of update +! finding a new index. Default: false. +! Not fully tested. +! +subroutine psb_ccoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_error_mod + use psb_serial_mod, psb_protect_name => psb_ccoins + use psb_update_mod + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, intent(in), optional :: rebuild + + character(len=5) :: ufida + integer :: ng, nza, isza,spstate, & + & ip1, nzl, err_act, int_err(5), iupd, irst + integer :: debug_level, debug_unit + logical :: rebuild_ + character(len=20) :: name, ch_err + type(psb_cspmat_type) :: tmp + + name='psb_ccoins' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + info = 0 + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (present(rebuild)) then + rebuild_ = rebuild + else + rebuild_ = .false. + end if + + ufida = psb_toupper(a%fida) + spstate = psb_sp_getifld(psb_state_,a,info) + + + if (present(gtl)) then + + ng = size(gtl) + select case(spstate) + case(psb_spmat_bld_) + if ((ufida /= 'COO').and.(ufida/='COI')) then + info = 134 + ch_err(1:3)=ufida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info,gtl,ng) + + if(info /= izero) then + + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%infoa(psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': insert discarded items ' + end if + end if + if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + endif + call psb_sp_setifld(nza,psb_nnz_,a,info) + + case(psb_spmat_upd_) + + iupd = psb_sp_getifld(psb_upd_,a,info) + select case (iupd) + case (psb_upd_perm_) + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + nzl = psb_sp_getifld(psb_del_bnd_,a,info) + 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) + + if (info /= izero) then + ch_err='psb_inner_upd' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': update discarded items ' + end if + end if + + select case(ufida) + case ('JAD') + a%ia1(ip1+psb_nnz_) = nza + case default + a%ia2(ip1+psb_nnz_) = nza + end select + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza + + case (psb_upd_srch_) + + call psb_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + if (info > 0) then + if (rebuild_) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*)& + & trim(name),& + & ': Going through rebuild_ fingers crossed!' + irst = info + call psb_nullify_sp(tmp) + call psb_spcnv(a,tmp,info,afmt='coo') + if(info /= izero) then + info=4010 + ch_err='psb_csdp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst + call psb_sp_transfer(tmp,a,info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_transfer' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) write(debug_unit,*)& + & trim(name),': Reinserting',a%fida,nza,isza,irst,nz + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + if (irst <= nz) then + call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& + & nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + &imin,imax,jmin,jmax,info,gtl,ng) + if (info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + endif + + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + call psb_sp_setifld(nza,psb_nnz_,a,info) + end if + + else + info = 2231 + call psb_errpush(info,name) + goto 9999 + end if + else if (info < 0) then + info = 2230 + call psb_errpush(info,name) + goto 9999 + + end if + + case default + + info = 2231 + call psb_errpush(info,name) + goto 9999 + end select + + + case default + info = 2232 + call psb_errpush(info,name) + goto 9999 + end select + + + + + + else + + ng = -1 + + select case(spstate) + case(psb_spmat_bld_) + if ((ufida /= 'COO').and.(ufida/='COI')) then + info = 134 + ch_err(1:3)=ufida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info) + + if(info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%infoa(psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': insert discarded items ' + end if + end if + if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + endif + call psb_sp_setifld(nza,psb_nnz_,a,info) + + case(psb_spmat_upd_) + + iupd = psb_sp_getifld(psb_upd_,a,info) + select case (iupd) + 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_) + + + call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& + & imin,imax,jmin,jmax,nzl,info) + if (info /= izero) then + ch_err='psb_inner_upd' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) then + if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': update discarded items ' + end if + end if + a%ia2(ip1+psb_nnz_) = nza + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza + + case (psb_upd_srch_) + + call psb_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info) + + if (info > 0) then + if (rebuild_) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*)& + & trim(name),& + & ': Going through rebuild_ fingers crossed!' + irst = info + call psb_nullify_sp(tmp) + call psb_spcnv(a,tmp,info,afmt='coo') + call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst + call psb_sp_transfer(tmp,a,info) + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) write(debug_unit,*)& + & trim(name),': Reinserting',a%fida,nza,isza + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + if (irst <= nz) then + call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& + & nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info) + if (info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + endif + + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + call psb_sp_setifld(nza,psb_nnz_,a,info) + end if + + else + info = 2231 + call psb_errpush(info,name) + goto 9999 + end if + else if (info < 0) then + info = 2230 + call psb_errpush(info,name) + goto 9999 + + end if + + case default + + info = 2233 + call psb_errpush(info,name) + goto 9999 + end select + + + case default + info = 2232 + call psb_errpush(info,name) + goto 9999 + end select + endif + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic + character(len=20) :: name, ch_err + + + name='psb_inner_upd' + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + if ((nza > nzl)) then + do i=1, nz + nza = nza + 1 + if (nza>maxsz) then + call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) + info = -71 + return + endif + aspk(nza) = val(i) + end do + else + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza>maxsz) then + info = -72 + return + endif + aspk(nza) = val(i) + end if + end if + end do + end if + else + if ((nza >= nzl)) then + do i=1, nz + nza = nza + 1 + if (nza>maxsz) then + info = -73 + return + endif + aspk(nza) = val(i) + end do + else + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza>maxsz) then + info = -74 + return + endif + aspk(nza) = val(i) + end if + end do + end if + end if + end subroutine psb_inner_upd + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl,ng) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic + + info = 0 + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + +end subroutine psb_ccoins + diff --git a/base/serial/psb_ccsmm.f90 b/base/serial/psb_ccsmm.f90 new file mode 100644 index 000000000..62b5ce22c --- /dev/null +++ b/base/serial/psb_ccsmm.f90 @@ -0,0 +1,89 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccsmm.f90 +! Subroutine: +! Arguments: +subroutine psb_ccsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_cspmat_type) :: a + complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + + complex(psb_spk_), allocatable :: work(:) + character :: trans_ + integer :: iwsz,m,n,k,lb,lc,err_act + character(len=20) :: name + + name='psb_ccsmm' + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + endif + + if ((trans_=='N').or.(trans_=='n')) then + m = a%m + k = a%k + else + k = a%m + m = a%k + end if + n = min(size(b,2),size(c,2)) + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call ccsmm(trans_,m,n,k,alpha,& + & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_ccsmm diff --git a/base/serial/psb_ccsmv.f90 b/base/serial/psb_ccsmv.f90 new file mode 100644 index 000000000..ed69af4fe --- /dev/null +++ b/base/serial/psb_ccsmv.f90 @@ -0,0 +1,89 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccsmv.f90 +! Subroutine: +! Arguments: + +subroutine psb_ccsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + implicit none + + type(psb_cspmat_type) :: a + complex(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + + complex(psb_spk_), allocatable :: work(:) + character :: trans_ + integer :: iwsz,m,n,k,lb,lc, err_act + character(len=20) :: name + + name='psb_ccsmv' + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + endif + + if ((trans_=='N').or.(trans_=='n')) then + m = a%m + k = a%k + else + k = a%m + m = a%k + end if + n = 1 + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call ccsmm(trans_,m,n,k,alpha,& + & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_ccsmv diff --git a/base/serial/psb_ccsnmi.f90 b/base/serial/psb_ccsnmi.f90 new file mode 100644 index 000000000..f803e0f60 --- /dev/null +++ b/base/serial/psb_ccsnmi.f90 @@ -0,0 +1,93 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccsnmi.f90 +! Subroutine: +! Arguments: + +function psb_ccsnmi(a,info,trans) + + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + real(psb_spk_) :: psb_ccsnmi + interface + function ccsnmi(trans,m,n,fida,descra,a,ia1,ia2,& + & infoa,ierror) + use psb_const_mod + real(psb_spk_) :: ccsnmi + integer :: m,n, ierror + character :: trans + integer :: ia1(*),ia2(*),infoa(*) + character :: descra*11, fida*5 + complex(psb_spk_) :: a(*) + end function ccsnmi + end interface + + integer :: err_act + character :: itrans + character(len=20) :: name, ch_err + + name='psb_ccsnmi' + call psb_erractionsave(err_act) + + if(present(trans)) then + itrans=trans + else + itrans='N' + end if + + psb_ccsnmi = ccsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) + if(info/=0) then + psb_ccsnmi = -1 + info=4010 + ch_err='psb_ccsnmi' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_ccsnmi diff --git a/base/serial/psb_ccsprt.f90 b/base/serial/psb_ccsprt.f90 new file mode 100644 index 000000000..0797ee1d1 --- /dev/null +++ b/base/serial/psb_ccsprt.f90 @@ -0,0 +1,193 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccsprt.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* Print out a matrix. * +!* Should really align with the F77 version under the SERIAL dir, which * +!* does a nice printout in MatrixMarket format; this would be a quick job. * +!* * +!* Handles both a shift in the row/col indices and a fuctional transform * +!* on the indices. * +!* * +!* * +!* * +!* * +!***************************************************************************** +subroutine psb_ccsprt(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_spmat_type + use psb_string_mod + implicit none + + integer, intent(in) :: iout + type(psb_cspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + character(len=*), parameter :: frmtr='(2(i6,1x),2(es16.8,1x),2(i6,1x))' + integer :: irs,ics,i,j + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% ',psb_toupper(a%fida) + endif + + select case(psb_toupper(a%fida)) + + case ('CSR') + + write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 + + if (present(iv)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+i),(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + endif + endif + + case ('CSC') + + write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 + + if (present(iv)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) + enddo + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) + enddo + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+a%ia1(j)),(ics+i),a%aspk(j) + enddo + enddo + endif + endif + + case ('COO') + if(present(iv)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) + enddo + else if (present(ivr).and.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) a%ia1(j),a%ia2(j),a%aspk(j) + enddo + endif + endif + case default + write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' + end select + +end subroutine psb_ccsprt diff --git a/base/serial/psb_ccssm.f90 b/base/serial/psb_ccssm.f90 new file mode 100644 index 000000000..85c57b693 --- /dev/null +++ b/base/serial/psb_ccssm.f90 @@ -0,0 +1,100 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_zcssm.f90 +! Subroutine: +! Arguments: + +subroutine psb_ccssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_zspmat_type) :: t + complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + complex(psb_spk_), optional, target :: d(:) + + complex(psb_spk_), allocatable :: work(:) + complex(psb_spk_), pointer :: ddl(:) + character :: lt, lu + integer :: iwsz,m,n,lb,lc,err_act + character(len=20) :: name + + name='psb_ccssm' + info = 0 + call psb_erractionsave(err_act) + + + if (present(trans)) then + lt = trans + else + lt = 'N' + endif + if (present(unitd)) then + lu = unitd + else + lu = 'U' + endif + if (present(d)) then + ddl => d + else + allocate(ddl(1)) + endif + + m = t%m + n = min(size(b,2),size(c,2)) + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call ccssm(lt,m,n,alpha,lu,ddl,& + & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + if (.not.present(d)) then + deallocate(ddl) + endif + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_ccssm diff --git a/base/serial/psb_ccssv.f90 b/base/serial/psb_ccssv.f90 new file mode 100644 index 000000000..e458a9c92 --- /dev/null +++ b/base/serial/psb_ccssv.f90 @@ -0,0 +1,100 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccssv.f90 +! Subroutine: +! Arguments: + +subroutine psb_ccssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_cspmat_type) :: t + complex(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + complex(psb_spk_), optional, target :: d(:) + + complex(psb_spk_), allocatable :: work(:) + complex(psb_spk_), pointer :: ddl(:) + character :: lt, lu + integer :: iwsz,m,n,lb,lc,err_act + character(len=20) :: name + + name='psb_ccssv' + info = 0 + call psb_erractionsave(err_act) + + + if (present(trans)) then + lt = trans + else + lt = 'N' + endif + if (present(unitd)) then + lu = unitd + else + lu = 'U' + endif + if (present(d)) then + ddl => d + else + allocate(ddl(1)) + endif + + m = t%m + n = 1 + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call ccssm(lt,m,n,alpha,lu,ddl,& + & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + if (.not.present(d)) then + deallocate(ddl) + endif + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_ccssv diff --git a/base/serial/psb_cfixcoo.f90 b/base/serial/psb_cfixcoo.f90 new file mode 100644 index 000000000..399c200ae --- /dev/null +++ b/base/serial/psb_cfixcoo.f90 @@ -0,0 +1,264 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cfixcoo.f90 +! Subroutine: +! Arguments: + +Subroutine psb_cfixcoo(a,info,idir) + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_cfixcoo + use psb_error_mod + implicit none + + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + integer, intent(in), optional :: idir + + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia1),size(a%ia2) + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) 'Fixcoo Invalid input ',a%fida + info = -1 + return + end if + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + 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 + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nza,a%ia1(1),iaux(1),iret) + if (iret == 0) call creordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + i = 1 + j = i + do while (i <= nza) + do while ((a%ia1(j) == a%ia1(i))) + j = j+1 + if (j > nza) exit + enddo + nzl = j - i + call msort_up(nzl,a%ia2(i),iaux(1),iret) + if (iret == 0) & + & call creordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) + i = j + enddo + + i = 1 + irw = a%ia1(i) + icl = a%ia2(i) + j = 1 + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nza,a%ia2(1),iaux(1),iret) + if (iret == 0) call creordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + i = 1 + j = i + do while (i <= nza) + do while ((a%ia2(j) == a%ia2(i))) + j = j+1 + if (j > nza) exit + enddo + nzl = j - i + call msort_up(nzl,a%ia1(i),iaux(1),iret) + if (iret == 0) & + & call creordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) + i = j + enddo + + i = 1 + irw = a%ia1(i) + icl = a%ia2(i) + j = 1 + + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_cfixcoo diff --git a/base/serial/psb_cgelp.f90 b/base/serial/psb_cgelp.f90 new file mode 100644 index 000000000..2892783e3 --- /dev/null +++ b/base/serial/psb_cgelp.f90 @@ -0,0 +1,266 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cgelp.f90 +! +! +! Subroutine: psb_cgelp +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:,:). +! info - integer. Return code. +subroutine psb_cgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_cgelp + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer :: ictxt + complex(psb_spk_),allocatable :: dtemp(:) + integer, allocatable :: itemp(:) + integer :: int_err(5), i1sz, i2sz, err_act + real(psb_spk_),parameter :: one=1 + logical, parameter :: debug=.false. + + interface + subroutine cgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + use psb_const_mod + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(psb_spk_), intent(inout) :: b(ldb,*), work(*) + integer, intent(in) :: p(*) + end subroutine cgelp + end interface + + interface isaperm + + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm + end interface + + character(len=20) :: name, ch_err + name = 'psb_cgelp' + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug) write(*,*) 'gelp: ',i1sz,i2sz + allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.isaperm(i1sz,itemp)) then + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + + call cgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) + if(info /= 0) then + info=4010 + ch_err='zgelp' + call psb_errpush(info,name,a_err=ch_err) + end if + + deallocate(dtemp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! WARNING: This routine should be changed and moved to the serial part +! i.e. taking out the descriptor. +! +! +! Subroutine: psb_cgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_cgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_cgelpv + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer :: ictxt + integer :: int_err(5), i1sz, err_act + complex(psb_spk_),allocatable :: dtemp(:) + integer, allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + logical, parameter :: debug=.false. + + interface cgelp + subroutine cgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + use psb_const_mod + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + complex(psb_spk_), intent(inout) :: b(*), work(*) + integer, intent(in) :: p(*) + end subroutine cgelp + end interface + + interface isaperm + + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm + end interface + + character(len=20) :: name, ch_err + name = 'psb_cgelpv' + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + + i1sz = size(x) + + + if (debug) write(*,*) 'gelp: ',i1sz + allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.isaperm(i1sz,itemp)) then + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + + call cgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) + if(info /= 0) then + info=4010 + ch_err='zgelp' + call psb_errpush(info,name,a_err=ch_err) + end if + + deallocate(dtemp) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cgelpv + diff --git a/base/serial/psb_cipcoo2csc.f90 b/base/serial/psb_cipcoo2csc.f90 new file mode 100644 index 000000000..d25600ab1 --- /dev/null +++ b/base/serial/psb_cipcoo2csc.f90 @@ -0,0 +1,214 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cipcoo2csc.f90 +! Subroutine: +! Arguments: + +subroutine psb_cipcoo2csc(a,info,clshr) + use psb_spmat_type + use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_cipcoo2csc + use psb_error_mod + use psb_string_mod + use psb_realloc_mod + implicit none + + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + logical, optional :: clshr + + integer, allocatable :: iaux(:), itemp(:) + !locals + logical :: clshr_ + Integer :: nza, i,j, idl,err_act,nc,icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + name='psb_ipcoo2csc' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) write(debug_unit,*) & + & trim(name),': start',a%fida,a%m + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) trim(name),' Invalid input ',a%fida + info = -1 + call psb_errpush(info,name) + goto 9999 + end if + if (present(clshr)) then + clshr_ = clshr + else + clshr_ = .false. + end if + + call psb_fixcoo(a,info,idir=1) + nc = a%k + nza = a%infoa(psb_nnz_) + allocate(iaux(max(nc+1,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) + goto 9999 + end if + if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& + & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) + + call psb_transfer(a%ia2,itemp,info) + call psb_transfer(iaux,a%ia2,info) + + ! + ! This routine can be used in two modes: + ! 1. Normal: just look at the col indices and trust them. This + ! implies putting in empty cols where needed. In this case you + ! can get in trouble if A%M < A%IA1(NZA) + ! 2. Shrink mode: disregard the actual value of the col indices, + ! just treat them as ident markers. In this case you can get in + ! trouble when the number of distinct col indices is greater + ! than A%M + ! + ! + + a%ia2(1) = 1 + + if (nza <= 0) then + do i=1,nc + a%ia2(i+1) = a%ia2(i) + end do + else + + if (clshr_) then + + j = 1 + i = 1 + icl = itemp(j) + + do j=1, nza + if (itemp(j) /= icl) then + a%ia2(i+1) = j + icl = itemp(j) + i = i + 1 + if (i>nc) then + write(debug_unit,*) trim(name),': CLSHR=.true. : ',& + & i, nc,' Expect trouble!' + exit + end if + endif + enddo +! write(debug_unit,*) 'Exit from loop',j,nza,i + do + if (i>=nc+1) exit + a%ia2(i+1) = j + i = i + 1 + end do + + else + + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + end if + + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i>nc) then + write(debug_unit,*) trim(name),& + & 'strange situation: i>nc ',i,nc,j,nza,icl,idl + exit outer + end if + a%ia2(i+1) = a%ia2(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + if (i>nc) then + write(debug_unit,*) trim(name), & + &'Strange situation: ',i,nc,size(a%ia2),& + & nza,j,itemp(j) + end if + a%ia2(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i>nc) exit + enddo outer + ! + ! Cleanup empty cols at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) + endif + do + if (i>nc) exit + a%ia2(i+1) = j + i = i + 1 + end do + + endif + + end if + +!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza + a%fida='CSC' + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='deallocate') + goto 9999 + end if + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_cipcoo2csc diff --git a/base/serial/psb_cipcoo2csr.f90 b/base/serial/psb_cipcoo2csr.f90 new file mode 100644 index 000000000..83d163f9f --- /dev/null +++ b/base/serial/psb_cipcoo2csr.f90 @@ -0,0 +1,213 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cipcoo2csr.f90 +! Subroutine: +! Arguments: + +subroutine psb_cipcoo2csr(a,info,rwshr) + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_serial_mod, only : psb_fixcoo + use psb_error_mod + use psb_string_mod + implicit none + + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + logical, optional :: rwshr + + integer, allocatable :: iaux(:), itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + name='psb_ipcoo2csr' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': start',a%fida,a%m + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) trim(name),': Invalid input ',a%fida + info = -1 + call psb_errpush(info,name) + goto 9999 + end if + if (present(rwshr)) then + rwshr_ = rwshr + else + rwshr_ = .false. + end if + + call psb_fixcoo(a,info) + nr = a%m + nza = a%infoa(psb_nnz_) + allocate(iaux(max(nr+1,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) + goto 9999 + end if + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) + + call psb_transfer(a%ia1,itemp,info) + call psb_transfer(a%ia2,a%ia1,info) + call psb_transfer(iaux,a%ia2,info) + + ! + ! This routine can be used in two modes: + ! 1. Normal: just look at the row indices and trust them. This + ! implies putting in empty rows where needed. In this case you + ! can get in trouble if A%M < A%IA1(NZA) + ! 2. Shrink mode: disregard the actual value of the row indices, + ! just treat them as ident markers. In this case you can get in + ! trouble when the number of distinct row indices is greater + ! than A%M + ! + ! + + a%ia2(1) = 1 + + if (nza <= 0) then + do i=1,nr + a%ia2(i+1) = a%ia2(i) + end do + else + + if (rwshr_) then + + + j = 1 + i = 1 + irw = itemp(j) + + do j=1, nza + if (itemp(j) /= irw) then + a%ia2(i+1) = j + irw = itemp(j) + i = i + 1 + if (i>nr) then + write(debug_unit,*) trim(name),': RWSHR=.true. : ',& + & i, nr,' Expect trouble!' + exit + end if + endif + enddo + do + if (i>=nr+1) exit + a%ia2(i+1) = j + i = i + 1 + end do + + else + + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%ia2(i+1) = a%ia2(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%ia2(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%ia2(i+1) = j + i = i + 1 + end do + + endif + + end if + + a%fida='CSR' + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='deallocate') + goto 9999 + end if + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_cipcoo2csr diff --git a/base/serial/psb_cipcsr2coo.f90 b/base/serial/psb_cipcsr2coo.f90 new file mode 100644 index 000000000..0c3f3758d --- /dev/null +++ b/base/serial/psb_cipcsr2coo.f90 @@ -0,0 +1,102 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cipcsr2coo.f90 +! Subroutine: +! Arguments: + +Subroutine psb_cipcsr2coo(a,info) + use psb_spmat_type + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_realloc_mod + use psb_serial_mod, psb_protect_name => psb_cipcsr2coo + implicit none + + !....Parameters... + Type(psb_cspmat_type), intent(inout) :: A + Integer, intent(out) :: info + + !locals + Integer :: nza, nr + integer :: i,j,err_act + integer, allocatable :: iaux(:), itemp(:) + character(len=20) :: name='psb_cipcsr2coo' + + info = 0 + call psb_erractionsave(err_act) + + if (psb_toupper(a%fida) /= 'CSR') then + info = 5 + call psb_errpush(info,name) + goto 9999 + end if + + nr = a%m + nza = a%ia2(nr+1) - 1 + allocate(iaux(max(nza,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) + goto 9999 + end if +!!$ write(0,*) 'ipcsr2coo ',a%m + call psb_transfer(a%ia2,itemp,info) + call psb_transfer(a%ia1,a%ia2,info) + call psb_transfer(iaux,a%ia1,info) + + do i=1, nr + do j=itemp(i),itemp(i+1)-1 + a%ia1(j) = i + end do + end do + + a%fida='COO' + a%infoa(psb_nnz_) = nza + a%infoa(psb_srtd_) = psb_isrtdcoo_ + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp) + call psb_fixcoo(a,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_cipcsr2coo diff --git a/base/serial/psb_cneigh.f90 b/base/serial/psb_cneigh.f90 new file mode 100644 index 000000000..e09644d13 --- /dev/null +++ b/base/serial/psb_cneigh.f90 @@ -0,0 +1,121 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cneigh.f90 +! Subroutine: +! Arguments: + +subroutine psb_cneigh(a,idx,neigh,n,info,lev) + + use psb_realloc_mod + use psb_const_mod + use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_cneigh + implicit none + + + type(psb_cspmat_type), intent(in) :: a ! the sparse matrix + integer, intent(in) :: idx ! the index whose neighbours we want to find + integer, intent(out) :: n, info ! the number of neighbours and the info + integer, allocatable :: neigh(:) ! the neighbours + integer, optional :: lev ! level of neighbours to find + + integer :: lev_, i, nl, ifl,ill,& + & n1, err_act, nn, nidx,ntl + character(len=20) :: name + integer, allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + + name='psb_cneigh' + info = 0 + call psb_erractionsave(err_act) + + n = 0 + info = 0 + if(present(lev)) then + lev_ = lev + else + lev_=1 + end if + + call psb_sp_getrow(idx,a,n,ia,ja,val,info) + if (info == 0) call psb_realloc(n,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + + + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then + call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) + if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn) + ifl = ill + 1 + ill = ill + nn + end do + call imsru(ill,neigh,psb_sort_up_,nn) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_cneigh + diff --git a/base/serial/psb_cnumbmm.f90 b/base/serial/psb_cnumbmm.f90 new file mode 100644 index 000000000..891059847 --- /dev/null +++ b/base/serial/psb_cnumbmm.f90 @@ -0,0 +1,138 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_snumbmm.f90 +! Subroutine: +! Arguments: +! +! +! Note: This subroutine performs the numerical product of two sparse matrices. +! It is modeled after the SMMP package by R. Bank and C. Douglas, but is +! rewritten in Fortran 95 making use of our sparse matrix facilities. +! +! + +subroutine psb_cnumbmm(a,b,c) + use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_cnumbmm + implicit none + + type(psb_cspmat_type) :: a,b,c + complex(psb_spk_), allocatable :: temp(:) + integer :: info + logical :: csra, csrb + + allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) + if (info /= 0) then + return + endif + call psb_realloc(size(c%ia1),c%aspk,info) + ! + ! Note: we still have to test about possible performance hits. + ! + ! + csra = (psb_toupper(a%fida(1:3))=='CSR') + csrb = (psb_toupper(b%fida(1:3))=='CSR') + + if (csra.and.csrb) then + call cnumbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,a%aspk,& + & b%ia2,b%ia1,0,b%aspk,& + & c%ia2,c%ia1,0,c%aspk,temp) + else + call inner_numbmm(a,b,c,temp,info) + end if + deallocate(temp) + return + +contains + + subroutine inner_numbmm(a,b,c,temp,info) + type(psb_cspmat_type) :: a,b,c + integer :: info + complex(psb_spk_) :: temp(:) + integer, allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + complex(psb_spk_), allocatable :: aval(:),bval(:) + integer :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + complex(psb_spk_) :: ajj + + + n = a%m + m = a%k + l = b%k + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= 0) then + return + endif + + do i = 1,maxlmn + temp(i) = czero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(0,*) ' NUMBMM: Problem with A ',i,jj,j,m + endif + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%ia2(i),c%ia2(i+1)-1 + if((c%ia1(j)<1).or. (c%ia1(j) > maxlmn)) then + write(0,*) ' NUMBMM: output problem',i,j,c%ia1(j),maxlmn + else + c%aspk(j) = temp(c%ia1(j)) + temp(c%ia1(j)) = czero + endif + end do + end do + + + + + end subroutine inner_numbmm + + +end subroutine psb_cnumbmm diff --git a/base/serial/psb_crwextd.f90 b/base/serial/psb_crwextd.f90 new file mode 100644 index 000000000..2ee918bed --- /dev/null +++ b/base/serial/psb_crwextd.f90 @@ -0,0 +1,174 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_crwextd.f90 +! Subroutine: +! Arguments: +! +! We have a problem here: 1. How to handle well all the formats? +! 2. What should we do with rowscale? Does it only +! apply when a%fida='COO' ?????? +! +! +subroutine psb_crwextd(nr,a,info,b,rowscale) + use psb_spmat_type + use psb_error_mod + use psb_string_mod + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer, intent(in) :: nr + type(psb_cspmat_type), intent(inout) :: a + integer,intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer :: i,j,ja,jb,err_act,nza,nzb + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_crwextd' + info = 0 + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + if (nr > a%m) then + if (psb_toupper(a%fida) == 'CSR') then + call psb_realloc(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) + if (psb_toupper(b%fida)=='CSR') then + + do i=1, min(nr-a%m,b%m) + a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i) + ja = a%ia2(a%m+i) + jb = b%ia2(i) + do + if (jb >= b%ia2(i+1)) exit + a%aspk(ja) = b%aspk(jb) + a%ia1(ja) = b%ia1(jb) + ja = ja + 1 + jb = jb + 1 + end do + end do + do j=i,nr-a%m + a%ia2(a%m+i+1) = a%ia2(a%m+i) + end do + else + write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + endif + else + do i=a%m+2,nr+1 + a%ia2(i) = a%ia2(i-1) + end do + end if + a%m = nr + a%k = max(a%k,b%k) + + else if (psb_toupper(a%fida) == 'COO') then + + if (present(b)) then + nza = psb_sp_get_nnzeros(a) + nzb = psb_sp_get_nnzeros(b) + call psb_sp_reall(a,nza+nzb,info) + if (psb_toupper(b%fida)=='COO') then + if (rowscale_) then + do j=1,nzb + if ((a%m + b%ia1(j)) <= nr) then + nza = nza + 1 + a%ia1(nza) = a%m + b%ia1(j) + a%ia2(nza) = b%ia2(j) + a%aspk(nza) = b%aspk(j) + end if + enddo + else + do j=1,nzb + if ((b%ia1(j)) <= nr) then + nza = nza + 1 + a%ia1(nza) = b%ia1(j) + a%ia2(nza) = b%ia2(j) + a%aspk(nza) = b%aspk(j) + endif + enddo + endif + a%infoa(psb_nnz_) = nza + else if(psb_toupper(b%fida)=='CSR') then + do i=1, min(nr-a%m,b%m) + do + jb = b%ia2(i) + if (jb >= b%ia2(i+1)) exit + nza = nza + 1 + a%aspk(nza) = b%aspk(jb) + a%ia1(nza) = a%m + i + a%ia2(nza) = b%ia1(jb) + jb = jb + 1 + end do + end do + a%infoa(psb_nnz_) = nza + else + write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + endif + endif + a%m = nr + a%k = max(a%k,b%k) + else if (a%fida == 'JAD') then + info=135 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_crwextd diff --git a/base/serial/psb_cspclip.f90 b/base/serial/psb_cspclip.f90 new file mode 100644 index 000000000..9f56fd206 --- /dev/null +++ b/base/serial/psb_cspclip.f90 @@ -0,0 +1,157 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspclip.f90 +! Subroutine: psb_cspclip +! Creates a "clipped" copy of input matrix A. Output is always in COO. +! Arguments: + +!***************************************************************************** +!* * +!***************************************************************************** +subroutine psb_cspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_cspclip + implicit none + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(out) :: b + integer, intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer :: err_act + character(len=20) :: name + integer :: imin_,imax_,jmin_,jmax_ + logical :: rscale_,cscale_ + integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j + integer, parameter :: irbk=40 + + name='psb_csp_clip' + info = 0 + call psb_erractionsave(err_act) + call psb_set_erraction(0) + + call psb_nullify_sp(b) + + + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + endif + if (present(imax)) then + imax_ = imax + else + imax_ = a%m + endif + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%k + endif + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + endif + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + endif + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%m ! Should this be imax_ ?? + endif + if (cscale_) then + kb = jmax_ - jmin_ +1 + else + kb = a%k ! Should this be jmax_ ?? + endif + + + sizeb = psb_sp_get_nnzeros(a) + call psb_sp_all(mb,kb,b,sizeb,info) + b%fida = 'COO' + b%descra = a%descra + nzb = 0 + do i=imin_, imax_, irbk + nrt = min(irbk,imax_-i+1) + ifst = i + ilst = ifst + nrt - 1 + call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& + & lrw=ilst, append=.true.,nzin=nzb) + do j=nzb+1,nzb+nzt + if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then + nzb = nzb + 1 + b%aspk(nzb) = b%aspk(j) + b%ia1(nzb) = b%ia1(j) + b%ia2(nzb) = b%ia2(j) + end if + end do + + end do + b%infoa(psb_nnz_) = nzb + + if (rscale_) then + do i=1, nzb + b%ia1(i) = b%ia1(i) - imin_ + 1 + end do + end if + if (cscale_) then + do i=1, nzb + b%ia2(i) = b%ia2(i) - jmin_ + 1 + end do + end if + call psb_fixcoo(b,info) + call psb_sp_trim(b,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cspclip + diff --git a/base/serial/psb_cspcnv.f90 b/base/serial/psb_cspcnv.f90 new file mode 100644 index 000000000..7ff240f92 --- /dev/null +++ b/base/serial/psb_cspcnv.f90 @@ -0,0 +1,573 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspcnv.f90 +! +! Subroutine: psb_cspcnv2 +! This subroutine converts the storage format of a matrix. +! +! Arguments: +! +! a - type(psb_spmat_type), input The input matrix to be converted. +! b - type(psb_spmat_type), output The assembled output matrix. +! info - integer. Return code +! afmt - character, optional The desired storage format +! +subroutine psb_cspcnv2(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_cspcnv2 + implicit none + !....Parameters... + Type(psb_cspmat_type), intent(in) :: A + Type(psb_cspmat_type), intent(out) :: B + Integer, intent(out) :: info + Integer, intent(in), optional :: upd,dupl + character(len=*), optional, intent(in) :: afmt + + !...Locals... + complex(psb_dpk_) :: d(1) + complex(psb_dpk_), allocatable :: work(:) + type(psb_cspmat_type) :: temp_a + Integer :: nzr, ntry, ifc_, ia1_size,& + & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ + integer :: err_act + character :: check_,trans_,unitd_ + character(len=5) :: afmt_ + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_spcnv2' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ntry=0 + + ifc_ = 2 + + + check_ = 'N' + trans_ = 'N' + unitd_ = 'U' + allocate(work(max(size(a%ia1),size(a%ia2))+a%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_ = psb_toupper(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=psb_toupper(afmt_) + size_req = psb_sp_get_nnzeros(a) + ! + 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 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': size_req 1:',& + & size_req, trans_,upd_,dupl_,b%fida,b%descra + + select case (psb_toupper(a%fida)) + + case ('CSR') + + select case (psb_toupper(b%fida)) + + case ('CSR') + + call ccrcr(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 ccrjd(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_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(debug_unit,*) trim(name),& + & ' 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra + call ccrco(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 (psb_toupper(b%fida)) + + case ('CSR') + + call ccocr(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 ccocr(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 ccrjd(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_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(debug_unit,*) trim(name),' 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 ccoco(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_) then + call psb_sp_trim(b,info) + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cspcnv2 + + +! +! Subroutine: psb_cspcnv1 +! This subroutine converts in place the storage format of a matrix. +! +! Arguments: +! +! a - type(psb_spmat_type), inout The input matrix to be converted. +! info - integer. Return code +! afmt - character, optional The desired storage format +! +subroutine psb_cspcnv1(a, info, afmt, upd, dupl) + + use psb_spmat_type + use psb_regen_mod + use psb_serial_mod, psb_protect_name => psb_cspcnv1 + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + !use psb_penv_mod + + implicit none + + + !...Parameters.... + type(psb_cspmat_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_cspmat_type) :: atemp + integer :: err_act + integer :: spstate + integer :: upd_, dupl_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + logical :: inplace + + info = 0 + int_err(1)=0 + name = 'psb_spcnv' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ + inplace = .false. + if (upd_ == psb_upd_srch_) then + if (present(afmt)) then + select case (psb_toupper(a%fida)) + case('COO') + select case(psb_toupper(afmt)) + case('COO') + call psb_fixcoo(a,info) + inplace = .true. + case('CSR') + call psb_ipcoo2csr(a,info) + inplace = .true. + case('CSC') + call psb_ipcoo2csc(a,info) + inplace = .true. + end select + case('CSR') + select case(psb_toupper(afmt)) + case('COO') + call psb_ipcsr2coo(a,info) + inplace = .true. + end select + end select + end if + if (inplace) then + if (info == 0) call psb_sp_trim(a,info) + if (info /= 0) then + info=4010 + ch_err='inplace cnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + call psb_erractionrestore(err_act) + return + 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 + + ! 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_level >= psb_debug_serial_)& + & write(debug_unit, *) trim(name),& + & ': 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 + + call psb_sp_free(atemp,info) + + else if (spstate == psb_spmat_upd_) then + ! + ! Second case: we come from an update loop. + ! + select case(psb_toupper(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 + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + + endif + + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cspcnv1 diff --git a/base/serial/psb_cspgetrow.f90 b/base/serial/psb_cspgetrow.f90 new file mode 100644 index 000000000..bc291712d --- /dev/null +++ b/base/serial/psb_cspgetrow.f90 @@ -0,0 +1,130 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspgetrow.f90 +! Subroutine: psb_cspgetrow +! Gets one or more rows from a sparse matrix. +! Arguments: +! irw - integer, input The row to be extracted +! a - type(psb_cspmat_type),input The sparse matrix +! nz - integer, output The number of entries +! ia(:) - integer, allocatable, inout The output row indices +! ja(:) - integer, allocatable, inout The output col indices +! val(:) - complex, allocatable,inout The coefficients +! info - integer, output Error code +! iren(:) - integer, input,optional Renumbering of indices +! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw +! append - logical, input,optional Should we append to already existing +! partial output? +! nzin - integer, input, optional If appending, how many entries were already +! occupied. +! +subroutine psb_cspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) + ! Output is always in COO format + use psb_spmat_type + use psb_const_mod + use psb_getrow_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_cspgetrow + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: lrw, nzin + + logical :: append_ + integer :: nzin_, lrw_, irw_, err_act + character(len=20) :: name, ch_err + + name='psb_spgetrow' + info = 0 + + call psb_erractionsave(err_act) + + irw_ = irw + if (present(lrw)) then + lrw_ = lrw + else + lrw_ = irw + endif + if (lrw_ < irw) then + write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ + lrw_ = irw + end if + if (present(append)) then + append_=append + else + append_=.false. + endif + + + if ((append_).and.(present(nzin))) then + nzin_ = nzin + else + nzin_ = 0 + endif + + select case (psb_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) + return + +9999 continue +!!$ call psb_erractionrestore(err_act) + call psb_erractionsave(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_cspgetrow + diff --git a/base/serial/psb_cspgtblk.f90 b/base/serial/psb_cspgtblk.f90 new file mode 100644 index 000000000..57232c029 --- /dev/null +++ b/base/serial/psb_cspgtblk.f90 @@ -0,0 +1,114 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspgtblk.f90 +! Subroutine: psb_cspgtblk +! Gets one or more rows from a sparse matrix. +! Arguments: +!***************************************************************************** +!* * +!* Takes a specified row from matrix A and copies into matrix B (possibly * +!* appending to B). Output is always COO. Input might be anything, * +!* * +!***************************************************************************** +subroutine psb_cspgtblk(irw,a,b,info,append,iren,lrw,srt) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_cspgtblk + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_cspmat_type), intent(inout) :: b + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + logical, intent(in), optional :: srt + + logical :: append_,srt_ + integer :: nz,nzb, lrw_, irw_ + character(len=20) :: name + + name='psb_spgtblk' + info = 0 + + irw_ = irw + if (present(lrw)) then + lrw_ = lrw + else + lrw_ = irw + endif + if (lrw_ < irw) then + write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ + lrw_ = irw + end if + if (present(append)) then + append_ = append + else + append_ = .false. + endif + + if (present(srt)) then + srt_ = srt + else + srt_ = .true. + endif + + + if (append_) then + nzb = b%infoa(psb_nnz_) + else + nzb = 0 + b%m = 0 + b%k = 0 + b%descra = a%descra + endif + b%fida = 'COO' + + call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& + & lrw=lrw_,append=append_,nzin=nzb) + if (info == 0) call psb_ensure_size(1,b%pl,info) + if (info == 0) call psb_ensure_size(1,b%pr,info) + if (info /= 0) return + b%pl = 0 + b%pr = 0 + b%infoa(psb_nnz_) = nzb+nz + b%m = b%m+lrw_-irw+1 + b%k = max(b%k,a%k) + if (srt_) call psb_fixcoo(b,info) + return + +end subroutine psb_cspgtblk + diff --git a/base/serial/psb_cspgtdiag.f90 b/base/serial/psb_cspgtdiag.f90 new file mode 100644 index 000000000..a26cdda16 --- /dev/null +++ b/base/serial/psb_cspgtdiag.f90 @@ -0,0 +1,123 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspgtdiag.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* * +!***************************************************************************** +subroutine psb_cspgtdiag(a,d,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_error_mod + use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_cspgtdiag + implicit none + + type(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + + type(psb_cspmat_type) :: tmpa + integer :: i,j, err_act, ii, rng, irb, nrb + character(len=20) :: name, ch_err + + name='psb_cspgtdiag' + info = 0 + call psb_erractionsave(err_act) + + if (size(d) < min(a%k,a%m)) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = 0.d0 + if (a%fida == 'CSR') then + + do i=1, min(a%m,a%k) + do j=a%ia2(i),a%ia2(i+1)-1 + if (a%ia1(j) == i) then + d(i) = a%aspk(j) + end if + end do + end do + + else if (a%fida == 'COO') then + + do i=1,a%infoa(psb_nnz_) + j=a%ia1(i) + if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then + d(j) = a%aspk(i) + endif + enddo + + else if (a%fida == 'JAD') then + + rng=min(a%m,a%k) + nrb=16 + do i=1, rng, nrb + irb=min(i+nrb-1,rng) + call psb_sp_getblk(i,a,tmpa,info,lrw=irb) + if(info /= 0) then + info=4010 + ch_err='psb_spgtblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do ii=1,tmpa%infoa(psb_nnz_) + j=tmpa%ia1(ii) + if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then + d(j) = tmpa%aspk(ii) + endif + enddo + + end do + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cspgtdiag + diff --git a/base/serial/psb_cspscal.f90 b/base/serial/psb_cspscal.f90 new file mode 100644 index 000000000..4a0eb7d06 --- /dev/null +++ b/base/serial/psb_cspscal.f90 @@ -0,0 +1,99 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspscal.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* * +!***************************************************************************** +subroutine psb_cspscal(a,d,info) + ! the input format + use psb_spmat_type + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + complex(psb_spk_), intent(in) :: d(:) + + integer :: i,j, err_act + character(len=20) :: name, ch_err + + name='psb_cspscal' + info = 0 + call psb_erractionsave(err_act) + + select case(psb_toupper(a%fida(1:3))) + case ('CSR') + + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + a%aspk(j) = a%aspk(j) * d(i) + end do + end do + + case ('COO') + + do i=1,a%infoa(psb_nnz_) + j=a%ia1(i) + a%aspk(i) = a%aspk(i) * d(j) + enddo + + case ('JAD') + info=135 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + case default + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cspscal + diff --git a/base/serial/psb_csymbmm.f90 b/base/serial/psb_csymbmm.f90 new file mode 100644 index 000000000..8716103c0 --- /dev/null +++ b/base/serial/psb_csymbmm.f90 @@ -0,0 +1,189 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_csymbmm.f90 +! Subroutine: +! Arguments: +! +! +! Note: This subroutine performs the symbolic product of two sparse matrices. +! It is modeled after the SMMP package by R. Bank and C. Douglas, but is +! rewritten in Fortran 95 making use of our sparse matrix facilities. +! + +subroutine psb_csymbmm(a,b,c,info) + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_csymbmm + implicit none + + type(psb_cspmat_type) :: a,b,c + integer, allocatable :: itemp(:) + integer :: nze,info + + interface + subroutine symbmm (n, m, l, ia, ja, diaga, & + & ib, jb, diagb, ic, jc, diagc, index) + integer n,m,l, ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & diagc, index(*) + integer, allocatable :: ic(:),jc(:) + end subroutine symbmm + end interface + + character(len=20) :: name + integer :: err_act + logical :: csra, csrb + name='psb_symbmm' + call psb_erractionsave(err_act) + + csra = (psb_toupper(a%fida(1:3))=='CSR') + csrb = (psb_toupper(b%fida(1:3))=='CSR') + + if (b%m /= a%k) then + write(0,*) 'Mismatch in SYMBMM: ',a%m,a%k,b%m,b%k + endif + allocate(itemp(max(a%m,a%k,b%m,b%k)),stat=info) + if (info /= 0) then + return + endif + nze = max(a%m+1,2*a%m) + call psb_sp_reall(c,nze,info) + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + if (csra.and.csrb) then + call symbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,& + & b%ia2,b%ia1,0,& + & c%ia2,c%ia1,0,itemp) + else + call inner_symbmm(a,b,c,itemp,info) + endif + call psb_realloc(size(c%ia1),c%aspk,info) + + c%pl(1) = 0 + c%pr(1) = 0 + c%m=a%m + c%k=b%k + c%fida='CSR' + c%descra='GUN' + deallocate(itemp) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + subroutine inner_symbmm(a,b,c,index,info) + type(psb_cspmat_type) :: a,b,c + integer :: index(:),info + integer, allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + complex(psb_spk_), allocatable :: aval(:),bval(:) + integer :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + + + n = a%m + m = a%k + l = b%k + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= 0) then + return + endif + + + if (size(c%ia2) < n+1) then + + call psb_realloc(n+1,c%ia2,info) + endif + do i=1,maxlmn + index(i)=0 + end do + + c%ia2(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(0,*) ' SymbMM: Problem with A ',i,jj,j,m + endif + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%ia2(i+1)=c%ia2(i)+length + + if (c%ia2(i+1) > size(c%ia1)) then + if (n > (2*i)) then + nze = max(c%ia2(i+1), c%ia2(i)*((n+i-1)/i)) + else + nze = max(c%ia2(i+1), nint((dble(c%ia2(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ia1,info) + end if + do j= c%ia2(i),c%ia2(i+1)-1 + c%ia1(j)=istart + istart=index(istart) + index(c%ia1(j))=0 + end do + call psb_msort(c%ia1(c%ia2(i):c%ia2(i)+length-1)) + index(i) = 0 + end do main + + end subroutine inner_symbmm + +end subroutine psb_csymbmm diff --git a/base/serial/psb_ctransc.f90 b/base/serial/psb_ctransc.f90 new file mode 100644 index 000000000..52640f85b --- /dev/null +++ b/base/serial/psb_ctransc.f90 @@ -0,0 +1,84 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ctransc.f90 +! Subroutine: +! Arguments: + +subroutine psb_ctransc(a,b,c,fmt) + use psb_spmat_type + use psb_tools_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_ctransc + implicit none + + type(psb_cspmat_type), intent(inout) :: a + type(psb_cspmat_type), intent(out) :: b + integer, optional :: c + character(len=*), optional :: fmt + + character(len=5) :: fmt_ + integer :: c_, info, i + integer, allocatable :: itmp(:) + + if (present(c)) then + c_=c + else + c_=1 + endif + if (present(fmt)) then + fmt_ = psb_toupper(fmt) + else + fmt_='CSR' + 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) + + do i=1, b%infoa(psb_nnz_) + b%aspk(i) = conjg(b%aspk(i)) + end do + + b%m = a%k + b%k = a%m + call psb_spcnv(b,info,afmt=fmt_) + + return +end subroutine psb_ctransc diff --git a/base/serial/psb_ctransp.f90 b/base/serial/psb_ctransp.f90 new file mode 100644 index 000000000..91f1d869e --- /dev/null +++ b/base/serial/psb_ctransp.f90 @@ -0,0 +1,80 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ctransp.f90 +! Subroutine: +! Arguments: + +subroutine psb_ctransp(a,b,c,fmt) + use psb_spmat_type + use psb_tools_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_ctransp + implicit none + + type(psb_cspmat_type), intent(inout) :: a + type(psb_cspmat_type), intent(out) :: b + integer, optional :: c + character(len=*), optional :: fmt + + character(len=5) :: fmt_ + integer :: c_, info + integer, allocatable :: itmp(:) + + if (present(c)) then + c_=c + else + c_=1 + endif + if (present(fmt)) then + fmt_ = psb_toupper(fmt) + else + fmt_='CSR' + 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 + call psb_spcnv(b,info,afmt=fmt_) + + return +end subroutine psb_ctransp diff --git a/base/serial/psb_dcoins.f90 b/base/serial/psb_dcoins.f90 index 66853d538..e84394f8d 100644 --- a/base/serial/psb_dcoins.f90 +++ b/base/serial/psb_dcoins.f90 @@ -119,7 +119,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) rebuild_ = .false. end if - call psb_touppers(a%fida,ufida) + ufida = psb_toupper(a%fida) spstate = psb_sp_getifld(psb_state_,a,info) diff --git a/base/serial/psb_dspcnv.f90 b/base/serial/psb_dspcnv.f90 index 8332e12c3..0753d2023 100644 --- a/base/serial/psb_dspcnv.f90 +++ b/base/serial/psb_dspcnv.f90 @@ -78,7 +78,6 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) ifc_ = 2 - check_ = 'N' trans_ = 'N' unitd_ = 'U' @@ -98,7 +97,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) call psb_sp_setifld(dupl,psb_dupl_,b,info) end if if (present(afmt)) then - afmt_ = psb_tolower(afmt) + afmt_ = psb_toupper(afmt) else afmt_ = psb_fidef_ end if @@ -126,7 +125,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) ! ...matrix conversion... b%m=a%m b%k=a%k - b%fida=psb_tolower(afmt_) + b%fida=psb_toupper(afmt_) size_req = psb_sp_get_nnzeros(a) ! n_row=b%m @@ -170,13 +169,13 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) & write(debug_unit,*) trim(name),': size_req 1:',& & size_req, trans_,upd_,dupl_,b%fida,b%descra - select case (psb_tolower(a%fida)) + select case (psb_toupper(a%fida)) - case ('csr') + case ('CSR') - select case (psb_tolower(b%fida)) + select case (psb_toupper(b%fida)) - case ('csr') + 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,& @@ -191,7 +190,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('jad') + case ('JAD') !...converting to JAD !...output matrix may not be big enough @@ -234,7 +233,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('coo') + case ('COO') if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& @@ -253,11 +252,11 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) end select - case ('coo','coi') + case ('COO','COI') - select case (psb_tolower(b%fida)) + select case (psb_toupper(b%fida)) - case ('csr') + 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,& @@ -269,7 +268,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('jad') + case ('JAD') call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) if (info /= 0) then @@ -326,7 +325,7 @@ subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) end do - case ('coo') + 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,& @@ -460,22 +459,22 @@ subroutine psb_dspcnv1(a, info, afmt, upd, dupl) inplace = .false. if (upd_ == psb_upd_srch_) then if (present(afmt)) then - select case (psb_tolower(a%fida)) - case('coo') - select case(psb_tolower(afmt)) - case('coo') + select case (psb_toupper(a%fida)) + case('COO') + select case(psb_toupper(afmt)) + case('COO') call psb_fixcoo(a,info) inplace = .true. - case('csr') + case('CSR') call psb_ipcoo2csr(a,info) inplace = .true. - case('csc') + case('CSC') call psb_ipcoo2csc(a,info) inplace = .true. end select - case('csr') - select case(psb_tolower(afmt)) - case('coo') + case('CSR') + select case(psb_toupper(afmt)) + case('COO') call psb_ipcsr2coo(a,info) inplace = .true. end select @@ -525,12 +524,12 @@ subroutine psb_dspcnv1(a, info, afmt, upd, dupl) ! ! Second case: we come from an update loop. ! - select case(psb_tolower(a%fida)) - case('csr') + select case(psb_toupper(a%fida)) + case('CSR') call csr_regen(a,info) - case ('coo','coi') + case ('COO','COI') call coo_regen(a,info) - case('jad') + case('JAD') call jad_regen(a,info) case default info=136 diff --git a/base/serial/psb_getrow_mod.f90 b/base/serial/psb_getrow_mod.f90 index 17daee2ce..518e56870 100644 --- a/base/serial/psb_getrow_mod.f90 +++ b/base/serial/psb_getrow_mod.f90 @@ -32,17 +32,439 @@ module psb_getrow_mod interface csr_getrow - module procedure csr_dspgtrow, csr_zspgtrow + module procedure csr_sspgtrow, csr_dspgtrow, csr_cspgtrow, csr_zspgtrow end interface interface coo_getrow - module procedure coo_dspgtrow, coo_zspgtrow + module procedure coo_sspgtrow, coo_dspgtrow, coo_cspgtrow, coo_zspgtrow end interface interface jad_getrow - module procedure jad_dspgtrow, jad_zspgtrow + module procedure jad_sspgtrow, jad_dspgtrow, jad_cspgtrow, jad_zspgtrow end interface contains + subroutine csr_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer :: lrw,info + integer, optional :: iren(:) + + integer :: idx,i,j, k, nr, row_idx, nzin_ + integer, allocatable :: indices(:) + + if (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%pl(1) /= 0) then + + nr = lrw - irw + 1 + allocate(indices(nr)) + nz = 0 + do i=1,nr + indices(i)=a%pl(irw+i-1) + nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) + end do + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + k=0 + if(present(iren)) then + do i=1,nr + row_idx=indices(i) + do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(row_idx) + ja(nzin_+k) = iren(a%ia1(j)) + end do + end do + else + do i=1,nr + row_idx=indices(i) + do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = row_idx + ja(nzin_+k) = a%ia1(j) + end do + end do + end if + + else + + idx = irw + + if (idx<0) then + write(0,*) ' spgtrow Error : idx no good ',idx + info = 2 + return + end if + nr = lrw - irw + 1 + nz = a%ia2(idx+nr) - a%ia2(idx) + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + + if (present(iren)) then + k=0 + do i=irw,lrw + do j=a%ia2(i),a%ia2(i+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(i) + ja(nzin_+k) = iren(a%ia1(j)) + end do + enddo + else + k=0 + + do i=irw,lrw + do j=a%ia2(i),a%ia2(i+1)-1 + k = k + 1 + ia(nzin_+k) = i + ja(nzin_+k) = a%ia1(j) + val(nzin_+k) = a%aspk(j) + end do + enddo + end if +!!$ if (nz /= k) then +!!$ write(0,*) 'csr getrow Size mismatch ',nz,k +!!$ endif + if (a%pr(1) /= 0) then + write(0,*) 'Feeling lazy today, Right Permutation will have to wait' + endif + + endif + + end subroutine csr_sspgtrow + + subroutine coo_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer :: lrw,info + integer, optional :: iren(:) + integer :: nzin_, nza, idx,ip,jp,i,k, nzt + integer :: debug_level, debug_unit + character(len=20) :: name='coo_sspgtrow' + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + nza = a%infoa(psb_nnz_) + if (a%pl(1) /= 0) then + write(debug_unit,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' + idx = -1 + else + idx = irw + endif + if (idx<0) then + write(debug_unit,*) ' spgtrow Error : idx no good ',idx + info = 2 + return + end if + + if (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then + ! In this case we can do a binary search. + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + call ibsrch(ip,irw,nza,a%ia1) + if (ip /= -1) exit + irw = irw + 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,idx + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia1(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + call ibsrch(jp,lrw,nza,a%ia1) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia1(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nz = jp - ip +1 + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + if (present(iren)) then + do i=ip,jp + nzin_ = nzin_ + 1 + val(nzin_) = a%aspk(i) + ia(nzin_) = iren(a%ia1(i)) + ja(nzin_) = iren(a%ia2(i)) + enddo + else + do i=ip,jp + nzin_ = nzin_ + 1 + val(nzin_) = a%aspk(i) + ia(nzin_) = a%ia1(i) + ja(nzin_) = a%ia2(i) + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%m,1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + + if (present(iren)) then + k = 0 + do i=1, a%infoa(psb_nnz_) + if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + end if + val(nzin_+k) = a%aspk(i) + ia(nzin_+k) = iren(a%ia1(i)) + ja(nzin_+k) = iren(a%ia2(i)) + endif + enddo + else + k = 0 + do i=1,a%infoa(psb_nnz_) + if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + + end if + val(nzin_+k) = a%aspk(i) + ia(nzin_+k) = (a%ia1(i)) + ja(nzin_+k) = (a%ia2(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_sspgtrow + + + subroutine jad_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + + implicit none + + type(psb_sspmat_type), intent(in), target :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer, optional :: iren(:) + integer :: lrw,info + + integer, pointer :: ia1(:), ia2(:), ia3(:),& + & ja_(:), ka_(:), indices(:), blks(:) + integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& + & i,j,k,nr + + + 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(:) + + ng = 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 (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%pl(1) /= 0) then + + nr = lrw - irw + 1 + allocate(indices(nr),blks(nr)) + nz = 0 + + do i=1,nr + indices(i)=a%pl(irw+i-1) + j=0 + blkfnd: do + j=j+1 + if(ia1(j) == indices(i)) then + blks(i)=j + nz=nz+ia3(j)-ia2(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 + nz = nz+ja_(row+1)-ja_(row) + exit blkfnd + else if(ia1(j) > indices(i)) then + blks(i)=j-1 + nz=nz+ia3(j-1)-ia2(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 + nz = nz+ja_(row+1)-ja_(row) + exit blkfnd + end if + end do blkfnd + end do + + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + k=0 + ! cycle over rows + do i=1,nr + + ! 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 + + if(present(iren))then + do col = ia2(blk), ia3(blk)-1 + k=k+1 + val(nzin_+k) = a%aspk(ja_(col)+rb) + ia(nzin_+k) = iren(irw+i-1) + ja(nzin_+k) = iren(ka_(ja_(col)+rb)) + end do + else + do col = ia2(blk), ia3(blk)-1 + k=k+1 + val(nzin_+k) = a%aspk(ja_(col)+rb) + ia(nzin_+k) = irw+i-1 + ja(nzin_+k) = ka_(ja_(col)+rb) + end do + end if + ! extract second part of the row from the csr tail + row=ia3(blk)+rb + if(present(iren))then + do j=ja_(row), ja_(row+1)-1 + k=k+1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(irw+i-1) + ja(nzin_+k) = iren(ka_(j)) + end do + else + do j=ja_(row), ja_(row+1)-1 + k=k+1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = irw+i-1 + ja(nzin_+k) = ka_(j) + end do + end if + end do + + else + ! There might be some problems + info=134 + end if + + end subroutine jad_sspgtrow + + subroutine csr_dspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) use psb_spmat_type @@ -465,6 +887,431 @@ contains end subroutine jad_dspgtrow + subroutine csr_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer :: lrw,info + integer, optional :: iren(:) + + integer :: idx,i,j, k, nr, row_idx, nzin_ + integer, allocatable :: indices(:) + integer :: debug_level, debug_unit + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%pl(1) /= 0) then + + nr = lrw - irw + 1 + allocate(indices(nr)) + nz = 0 + do i=1,nr + indices(i)=a%pl(irw+i-1) + nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) + end do + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + k=0 + if(present(iren)) then + do i=1,nr + row_idx=indices(i) + do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(row_idx) + ja(nzin_+k) = iren(a%ia1(j)) + end do + end do + else + do i=1,nr + row_idx=indices(i) + do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = row_idx + ja(nzin_+k) = a%ia1(j) + end do + end do + end if + + else + idx = irw + + if (idx<0) then + write(0,*) ' spgtrow Error : idx no good ',idx + return + end if + nr = lrw - irw + 1 + nz = a%ia2(idx+nr) - a%ia2(idx) + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + + if (present(iren)) then + k=0 + do i=irw,lrw + do j=a%ia2(i),a%ia2(i+1)-1 + k = k + 1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(i) + ja(nzin_+k) = iren(a%ia1(j)) + end do + enddo + else + k=0 + + do i=irw,lrw + do j=a%ia2(i),a%ia2(i+1)-1 + k = k + 1 + ia(nzin_+k) = i + ja(nzin_+k) = a%ia1(j) + val(nzin_+k) = a%aspk(j) + end do + enddo + end if + if (a%pr(1) /= 0) then + write(debug_unit,*)& + & 'Feeling lazy today, Right Permutation will have to wait' + endif + + endif + + end subroutine csr_cspgtrow + + + subroutine coo_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(in) :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer :: lrw,info + integer, optional :: iren(:) + integer :: nzin_, nza, idx,ip,jp,i,k, nzt + integer :: debug_level, debug_unit + character(len=20) :: name='coo_zspgtrow' + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + nza = a%infoa(psb_nnz_) + if (a%pl(1) /= 0) then + write(debug_unit,*) trim(name),& + & 'Fatal error: do not feed a permuted mat so far!' + idx = -1 + else + idx = irw + endif + if (idx<0) then + write(debug_unit,*) trim(name),& + &' Error : idx no good ',idx + info = 2 + return + end if + + if (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then + ! In this case we can do a binary search. + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': srtdcoo ' + do + call ibsrch(ip,irw,nza,a%ia1) + if (ip /= -1) exit + irw = irw + 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,idx + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia1(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + call ibsrch(jp,lrw,nza,a%ia1) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia1(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nz = jp - ip +1 + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + if (present(iren)) then + do i=ip,jp + nzin_ = nzin_ + 1 + val(nzin_) = a%aspk(i) + ia(nzin_) = iren(a%ia1(i)) + ja(nzin_) = iren(a%ia2(i)) + enddo + else + do i=ip,jp + nzin_ = nzin_ + 1 + val(nzin_) = a%aspk(i) + ia(nzin_) = a%ia1(i) + ja(nzin_) = a%ia2(i) + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + nzt = (nza*(lrw-irw+1))/max(a%m,1) + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + + if (present(iren)) then + k = 0 + do i=1, a%infoa(psb_nnz_) + if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + end if + val(nzin_+k) = a%aspk(i) + ia(nzin_+k) = iren(a%ia1(i)) + ja(nzin_+k) = iren(a%ia2(i)) + endif + enddo + else + k = 0 + do i=1,a%infoa(psb_nnz_) + if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) return + + end if + val(nzin_+k) = a%aspk(i) + ia(nzin_+k) = (a%ia1(i)) + ja(nzin_+k) = (a%ia2(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_cspgtrow + + + subroutine jad_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) + + use psb_spmat_type + use psb_const_mod + implicit none + + type(psb_cspmat_type), intent(in), target :: a + integer :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer :: nzin + logical, intent(in) :: append + integer, optional :: iren(:) + integer :: lrw,info + + integer, pointer :: ia1(:), ia2(:), ia3(:),& + & ja_(:), ka_(:), indices(:), blks(:) + integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& + & i,j,k,nr + + + 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(:) + + ng = 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 (append) then + nzin_ = nzin + else + nzin_ = 0 + endif + + if (a%pl(1) /= 0) then + + nr = lrw - irw + 1 + allocate(indices(nr),blks(nr)) + nz = 0 + + do i=1,nr + indices(i)=a%pl(irw+i-1) + j=0 + blkfnd: do + j=j+1 + if(ia1(j) == indices(i)) then + blks(i)=j + nz=nz+ia3(j)-ia2(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 + nz = nz+ja_(row+1)-ja_(row) + exit blkfnd + else if(ia1(j) > indices(i)) then + blks(i)=j-1 + nz=nz+ia3(j-1)-ia2(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 + nz = nz+ja_(row+1)-ja_(row) + exit blkfnd + end if + end do blkfnd + end do + + + call psb_ensure_size(nzin_+nz,ia,info) + if (info==0) call psb_ensure_size(nzin_+nz,ja,info) + if (info==0) call psb_ensure_size(nzin_+nz,val,info) + if (info /= 0) return + + k=0 + ! cycle over rows + do i=1,nr + + ! 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 + + if(present(iren))then + do col = ia2(blk), ia3(blk)-1 + k=k+1 + val(nzin_+k) = a%aspk(ja_(col)+rb) + ia(nzin_+k) = iren(irw+i-1) + ja(nzin_+k) = iren(ka_(ja_(col)+rb)) + end do + else + do col = ia2(blk), ia3(blk)-1 + k=k+1 + val(nzin_+k) = a%aspk(ja_(col)+rb) + ia(nzin_+k) = irw+i-1 + ja(nzin_+k) = ka_(ja_(col)+rb) + end do + end if + ! extract second part of the row from the csr tail + row=ia3(blk)+rb + if(present(iren))then + do j=ja_(row), ja_(row+1)-1 + k=k+1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = iren(irw+i-1) + ja(nzin_+k) = iren(ka_(j)) + end do + else + do j=ja_(row), ja_(row+1)-1 + k=k+1 + val(nzin_+k) = a%aspk(j) + ia(nzin_+k) = irw+i-1 + ja(nzin_+k) = ka_(j) + end do + end if + end do + + else + ! There might be some problems + info=134 + end if + + end subroutine jad_cspgtrow + + subroutine csr_zspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) use psb_spmat_type diff --git a/base/serial/psb_regen_mod.f90 b/base/serial/psb_regen_mod.f90 index bf5891835..76f0a06a1 100644 --- a/base/serial/psb_regen_mod.f90 +++ b/base/serial/psb_regen_mod.f90 @@ -32,17 +32,334 @@ module psb_regen_mod interface csr_regen - module procedure csr_dsp_regen, csr_zsp_regen + module procedure csr_ssp_regen, csr_dsp_regen, csr_csp_regen, csr_zsp_regen end interface interface coo_regen - module procedure coo_dsp_regen, coo_zsp_regen + module procedure coo_ssp_regen, coo_dsp_regen, coo_csp_regen, coo_zsp_regen end interface interface jad_regen - module procedure jad_dsp_regen, jad_zsp_regen + module procedure jad_ssp_regen, jad_dsp_regen, jad_csp_regen, jad_zsp_regen end interface contains + subroutine csr_ssp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + real(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! + ! 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csr_ssp_regen + + subroutine coo_ssp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + real(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! + ! 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine coo_ssp_regen + + subroutine jad_ssp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + real(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! + ! 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine jad_ssp_regen + subroutine csr_dsp_regen(a,info) use psb_spmat_type @@ -360,6 +677,320 @@ contains end subroutine jad_dsp_regen + + subroutine csr_csp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + complex(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! + ! 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csr_csp_regen + + subroutine coo_csp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + complex(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ! + ! 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine coo_csp_regen + + subroutine jad_csp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + integer :: info + + integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt + complex(psb_spk_), allocatable :: work(:) + integer :: err_act + character(len=20) :: name + integer :: debug_level, debug_unit + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! + ! 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(debug_unit,*) trim(name),'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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & '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 == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine jad_csp_regen subroutine csr_zsp_regen(a,info) diff --git a/base/serial/psb_scoins.f90 b/base/serial/psb_scoins.f90 new file mode 100644 index 000000000..b25c34a81 --- /dev/null +++ b/base/serial/psb_scoins.f90 @@ -0,0 +1,622 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scoins.f90 +! Subroutine: psb_scoins +! Takes a cloud of coefficients and inserts them into a sparse matrix. +! This subroutine is the serial, inner counterpart to the outer, user-level +! psb_spins. +! +! Arguments: +! +! nz - integer, input The number of points to insert. +! ia(:) - integer, input The row indices of the coefficients. +! ja(:) - integer, input The column indices of the coefficients. +! val(:) - real, input The values of the coefficients to be inserted. +! a - type(psb_sspmat_type), inout The sparse destination matrix. +! imin - integer, input The minimum valid row index +! imax - integer, input The maximum valid row index +! jmin - integer, input The minimum valid col index +! jmax - integer, input The maximum valid col index +! info - integer, output Return code. +! gtl(:) - integer, input,optional An index mapping to be applied +! default: identity +! rebuild - logical, input, optional Rebuild in case of update +! finding a new index. Default: false. +! Not fully tested. +! +subroutine psb_scoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_error_mod + use psb_serial_mod, psb_protect_name => psb_scoins + use psb_update_mod + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + logical, intent(in), optional :: rebuild + + character(len=5) :: ufida + integer :: ng, nza, isza,spstate, & + & ip1, nzl, err_act, int_err(5), iupd, irst + integer :: debug_level, debug_unit + logical :: rebuild_ + character(len=20) :: name, ch_err + type(psb_sspmat_type) :: tmp + + name='psb_scoins' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + info = 0 + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (present(rebuild)) then + rebuild_ = rebuild + else + rebuild_ = .false. + end if + + ufida = psb_toupper(a%fida) + spstate = psb_sp_getifld(psb_state_,a,info) + + + if (present(gtl)) then + + ng = size(gtl) + select case(spstate) + case(psb_spmat_bld_) + if ((ufida /= 'COO').and.(ufida/='COI')) then + info = 134 + ch_err(1:3)=ufida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info,gtl,ng) + + if(info /= izero) then + + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%infoa(psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': insert discarded items ' + end if + end if + if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + endif + call psb_sp_setifld(nza,psb_nnz_,a,info) + + case(psb_spmat_upd_) + + iupd = psb_sp_getifld(psb_upd_,a,info) + select case (iupd) + case (psb_upd_perm_) + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + nzl = psb_sp_getifld(psb_del_bnd_,a,info) + 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) + + if (info /= izero) then + ch_err='psb_inner_upd' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': update discarded items ' + end if + end if + + select case(ufida) + case ('JAD') + a%ia1(ip1+psb_nnz_) = nza + case default + a%ia2(ip1+psb_nnz_) = nza + end select + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza + + case (psb_upd_srch_) + + call psb_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + if (info > 0) then + if (rebuild_) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*)& + & trim(name),& + & ': Going through rebuild_ fingers crossed!' + irst = info + call psb_nullify_sp(tmp) + call psb_spcnv(a,tmp,info,afmt='coo') + if(info /= izero) then + info=4010 + ch_err='psb_csdp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst + call psb_sp_transfer(tmp,a,info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_transfer' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) write(debug_unit,*)& + & trim(name),': Reinserting',a%fida,nza,isza,irst,nz + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + if (irst <= nz) then + call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& + & nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + &imin,imax,jmin,jmax,info,gtl,ng) + if (info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + endif + + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + call psb_sp_setifld(nza,psb_nnz_,a,info) + end if + + else + info = 2231 + call psb_errpush(info,name) + goto 9999 + end if + else if (info < 0) then + info = 2230 + call psb_errpush(info,name) + goto 9999 + + end if + + case default + + info = 2231 + call psb_errpush(info,name) + goto 9999 + end select + + + case default + info = 2232 + call psb_errpush(info,name) + goto 9999 + end select + + + + + + else + + ng = -1 + + select case(spstate) + case(psb_spmat_bld_) + if ((ufida /= 'COO').and.(ufida/='COI')) then + info = 134 + ch_err(1:3)=ufida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info) + + if(info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + + goto 9999 + endif + if (debug_level >= psb_debug_serial_) then + if ((nza - a%infoa(psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': insert discarded items ' + end if + end if + if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + endif + call psb_sp_setifld(nza,psb_nnz_,a,info) + + case(psb_spmat_upd_) + + iupd = psb_sp_getifld(psb_upd_,a,info) + select case (iupd) + 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_) + + + call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& + & imin,imax,jmin,jmax,nzl,info) + if (info /= izero) then + ch_err='psb_inner_upd' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) then + if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then + write(debug_unit,*) trim(name),': update discarded items ' + end if + end if + a%ia2(ip1+psb_nnz_) = nza + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza + + case (psb_upd_srch_) + + call psb_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info) + + if (info > 0) then + if (rebuild_) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*)& + & trim(name),& + & ': Going through rebuild_ fingers crossed!' + irst = info + call psb_nullify_sp(tmp) + call psb_spcnv(a,tmp,info,afmt='coo') + call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst + call psb_sp_transfer(tmp,a,info) + call psb_sp_info(psb_nztotreq_,a,nza,info) + call psb_sp_info(psb_nzsizereq_,a,isza,info) + if(info /= izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debug_level >= psb_debug_serial_) write(debug_unit,*)& + & trim(name),': Reinserting',a%fida,nza,isza + + if ((nza+nz)>isza) then + call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) + if(info /= izero) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + if (irst <= nz) then + call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& + & nza,a%ia1,a%ia2,a%aspk,& + & min(size(a%ia1),size(a%ia2),size(a%aspk)),& + & imin,imax,jmin,jmax,info) + if (info /= izero) then + ch_err='psb_inner_ins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + endif + + call psb_sp_setifld(nza,psb_del_bnd_,a,info) + call psb_sp_setifld(nza,psb_nnz_,a,info) + end if + + else + info = 2231 + call psb_errpush(info,name) + goto 9999 + end if + else if (info < 0) then + info = 2230 + call psb_errpush(info,name) + goto 9999 + + end if + + case default + + info = 2233 + call psb_errpush(info,name) + goto 9999 + end select + + + case default + info = 2232 + call psb_errpush(info,name) + goto 9999 + end select + endif + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic + character(len=20) :: name, ch_err + + + name='psb_inner_upd' + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + if ((nza > nzl)) then + do i=1, nz + nza = nza + 1 + if (nza>maxsz) then + call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) + info = -71 + return + endif + aspk(nza) = val(i) + end do + else + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza>maxsz) then + info = -72 + return + endif + aspk(nza) = val(i) + end if + end if + end do + end if + else + if ((nza >= nzl)) then + do i=1, nz + nza = nza + 1 + if (nza>maxsz) then + info = -73 + return + endif + aspk(nza) = val(i) + end do + else + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza>maxsz) then + info = -74 + return + endif + aspk(nza) = val(i) + end if + end do + end if + end if + end subroutine psb_inner_upd + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl,ng) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic + + info = 0 + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + +end subroutine psb_scoins + diff --git a/base/serial/psb_scsmm.f90 b/base/serial/psb_scsmm.f90 new file mode 100644 index 000000000..bb6bf8f5b --- /dev/null +++ b/base/serial/psb_scsmm.f90 @@ -0,0 +1,113 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scsmm.f90 +! Subroutine: +! Arguments: +subroutine psb_scsmm(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_sspmat_type) :: a + real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans + + real(psb_spk_), allocatable :: work(:) + character :: trans_ + integer :: iwsz,m,n,k,lb,lc,err_act + character(len=20) :: name, ch_err + + name='psb_scsmm' + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + endif + + if (trans_=='N') then + m = a%m + k = a%k + else + k = a%m + m = a%k + end if + n = min(size(b,2),size(c,2)) + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz),stat=info) + if (info /= 0) then + info = 4010 + ch_err='allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call scsmm(trans_,m,n,k,alpha,& + & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + + if (info /= 0) then + info = 4010 + ch_err='Serial csmm' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + goto 9999 + end if + deallocate(work,stat=info) + + if (info /= 0) then + info = 4010 + ch_err='Deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_scsmm diff --git a/base/serial/psb_scsmv.f90 b/base/serial/psb_scsmv.f90 new file mode 100644 index 000000000..875d7a792 --- /dev/null +++ b/base/serial/psb_scsmv.f90 @@ -0,0 +1,89 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scsmv.f90 +! Subroutine: +! Arguments: + +subroutine psb_scsmv(alpha,a,b,beta,c,info,trans) + use psb_spmat_type + implicit none + + type(psb_sspmat_type) :: a + real(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans + + real(psb_spk_), allocatable :: work(:) + character :: trans_ + integer :: iwsz,m,n,k,lb,lc, err_act + character(len=20) :: name + + name='psb_scsmv' + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + endif + + if (trans_=='N') then + m = a%m + k = a%k + else + k = a%m + m = a%k + end if + n = 1 + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call scsmm(trans_,m,n,k,alpha,& + & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_scsmv diff --git a/base/serial/psb_scsnmi.f90 b/base/serial/psb_scsnmi.f90 new file mode 100644 index 000000000..c0ed97650 --- /dev/null +++ b/base/serial/psb_scsnmi.f90 @@ -0,0 +1,93 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scsnmi.f90 +! Subroutine: +! Arguments: + +function psb_scsnmi(a,info,trans) + + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer, intent(out) :: info + character, optional :: trans + real(psb_spk_) :: psb_scsnmi + interface + function scsnmi(trans,m,n,fida,descra,a,ia1,ia2,& + & infoa,ierror) + use psb_const_mod + real(psb_spk_) :: dcsnmi + integer :: m,n, ierror + character :: trans + integer :: ia1(*),ia2(*),infoa(*) + character :: descra*11, fida*5 + real(psb_spk_) :: a(*) + end function scsnmi + end interface + + integer :: err_act + character :: itrans + character(len=20) :: name, ch_err + + name='psb_scsnmi' + call psb_erractionsave(err_act) + + if(present(trans)) then + itrans=trans + else + itrans='N' + end if + + psb_scsnmi = scsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) + if(info/=0) then + psb_scsnmi = -1 + info=4010 + ch_err='psb_scsnmi' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_scsnmi diff --git a/base/serial/psb_scsprt.f90 b/base/serial/psb_scsprt.f90 new file mode 100644 index 000000000..ce1abd98c --- /dev/null +++ b/base/serial/psb_scsprt.f90 @@ -0,0 +1,193 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scsprt.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* Print out a matrix. * +!* Should really align with the F77 version under the SERIAL dir, which * +!* does a nice printout in MatrixMarket format; this would be a quick job. * +!* * +!* Handles both a shift in the row/col indices and a fuctional transform * +!* on the indices. * +!* * +!* * +!* * +!* * +!***************************************************************************** +subroutine psb_scsprt(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_spmat_type + use psb_string_mod + implicit none + + integer, intent(in) :: iout + type(psb_sspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + character(len=*), parameter :: frmtr='(2(i6,1x),es16.8,2(i6,1x))' + integer :: irs,ics,i,j + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% ',psb_toupper(a%fida) + endif + + select case(psb_toupper(a%fida)) + + case ('CSR') + + write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 + + if (present(iv)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+i),(ics+a%ia1(j)),a%aspk(j) + enddo + enddo + endif + endif + + case ('CSC') + + write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 + + if (present(iv)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) + enddo + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) + enddo + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) + enddo + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, a%k + do j=a%ia2(i),a%ia2(i+1)-1 + write(iout,frmtr) (irs+a%ia1(j)),(ics+i),a%aspk(j) + enddo + enddo + endif + endif + + case ('COO') + if(present(iv)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) + enddo + else if (present(ivr).and.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) + write(iout,frmtr) a%ia1(j),a%ia2(j),a%aspk(j) + enddo + endif + endif + case default + write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' + end select + +end subroutine psb_scsprt diff --git a/base/serial/psb_scssm.f90 b/base/serial/psb_scssm.f90 new file mode 100644 index 000000000..d0355a45f --- /dev/null +++ b/base/serial/psb_scssm.f90 @@ -0,0 +1,100 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scssm.f90 +! Subroutine: +! Arguments: + +subroutine psb_scssm(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_sspmat_type) :: t + real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) + integer :: info + character, optional :: trans, unitd + real(psb_spk_), optional, target :: d(:) + + real(psb_spk_), allocatable :: work(:) + real(psb_spk_), pointer :: ddl(:) + character :: lt, lu + integer :: iwsz,m,n,lb,lc,err_act + character(len=20) :: name + + name='psb_scssm' + info = 0 + call psb_erractionsave(err_act) + + + if (present(trans)) then + lt = trans + else + lt = 'N' + endif + if (present(unitd)) then + lu = unitd + else + lu = 'U' + endif + if (present(d)) then + ddl => d + else + allocate(ddl(1)) + endif + + m = t%m + n = min(size(b,2),size(c,2)) + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call scssm(lt,m,n,alpha,lu,ddl,& + & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + if (.not.present(d)) then + deallocate(ddl) + endif + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_scssm diff --git a/base/serial/psb_scssv.f90 b/base/serial/psb_scssv.f90 new file mode 100644 index 000000000..d8b367197 --- /dev/null +++ b/base/serial/psb_scssv.f90 @@ -0,0 +1,100 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scssv.f90 +! Subroutine: +! Arguments: + +subroutine psb_scssv(alpha,t,b,beta,c,info,trans,unitd,d) + use psb_spmat_type + use psb_error_mod + implicit none + + type(psb_sspmat_type) :: t + real(psb_spk_) :: alpha, beta, b(:), c(:) + integer :: info + character, optional :: trans, unitd + real(psb_spk_), optional, target :: d(:) + + real(psb_spk_), allocatable :: work(:) + real(psb_spk_), pointer :: ddl(:) + character :: lt, lu + integer :: iwsz,m,n,lb,lc,err_act + character(len=20) :: name + + name='psb_scssv' + info = 0 + call psb_erractionsave(err_act) + + + if (present(trans)) then + lt = trans + else + lt = 'N' + endif + if (present(unitd)) then + lu = unitd + else + lu = 'U' + endif + if (present(d)) then + ddl => d + else + allocate(ddl(1)) + endif + + m = t%m + n = 1 + lb = size(b,1) + lc = size(c,1) + iwsz = 2*m*n + allocate(work(iwsz)) + + call scssm(lt,m,n,alpha,lu,ddl,& + & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& + & b,lb,beta,c,lc,work,iwsz,info) + + if (.not.present(d)) then + deallocate(ddl) + endif + deallocate(work) + call psb_erractionrestore(err_act) + + if(info /= 0) then + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end if + + return + +end subroutine psb_scssv diff --git a/base/serial/psb_sfixcoo.f90 b/base/serial/psb_sfixcoo.f90 new file mode 100644 index 000000000..682ab9828 --- /dev/null +++ b/base/serial/psb_sfixcoo.f90 @@ -0,0 +1,264 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sfixcoo.f90 +! Subroutine: +! Arguments: + +subroutine psb_sfixcoo(a,info,idir) + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_sfixcoo + use psb_error_mod + implicit none + + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + integer, intent(in), optional :: idir + + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia1),size(a%ia2) + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) 'Fixcoo Invalid input ',a%fida + info = -1 + return + end if + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + 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 + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nza,a%ia1(1),iaux(1),iret) + if (iret == 0) call sreordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + i = 1 + j = i + do while (i <= nza) + do while ((a%ia1(j) == a%ia1(i))) + j = j+1 + if (j > nza) exit + enddo + nzl = j - i + call msort_up(nzl,a%ia2(i),iaux(1),iret) + if (iret == 0) & + & call sreordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) + i = j + enddo + + i = 1 + irw = a%ia1(i) + icl = a%ia2(i) + j = 1 + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nza,a%ia2(1),iaux(1),iret) + if (iret == 0) call reordvn(nza,a%aspk(1),a%ia1(1),a%ia2(1),iaux(1)) + i = 1 + j = i + do while (i <= nza) + do while ((a%ia2(j) == a%ia2(i))) + j = j+1 + if (j > nza) exit + enddo + nzl = j - i + call msort_up(nzl,a%ia1(i),iaux(1),iret) + if (iret == 0) & + & call reordvn(nzl,a%aspk(i),a%ia1(i),a%ia2(i),iaux(1)) + i = j + enddo + + i = 1 + irw = a%ia1(i) + icl = a%ia2(i) + j = 1 + + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_sfixcoo diff --git a/base/serial/psb_sgelp.f90 b/base/serial/psb_sgelp.f90 new file mode 100644 index 000000000..9bbe87cb1 --- /dev/null +++ b/base/serial/psb_sgelp.f90 @@ -0,0 +1,268 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sgelp.f90 +! +! +! Subroutine: psb_sgelp +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:,:). +! info - integer. Return code. +subroutine psb_sgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_sgelp + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer :: ictxt + real(psb_spk_),allocatable :: dtemp(:) + integer :: int_err(5), i1sz, i2sz, err_act + integer, allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + integer :: debug_level, debug_unit + + interface sgelp + subroutine sgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + use psb_const_mod + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + real(psb_spk_), intent(inout) :: b(ldb,*), work(*) + integer, intent(in) :: p(*) + end subroutine sgelp + end interface + + interface isaperm + + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm + end interface + + character(len=20) :: name, ch_err + name = 'psb_sgelp' + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.isaperm(i1sz,itemp)) then + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + + call sgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) + if(info /= 0) then + info=4010 + ch_err='sgelp' + call psb_errpush(info,name,a_err=ch_err) + end if + + deallocate(dtemp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_sgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! Subroutine: psb_sgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_sgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_sgelpv + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer, intent(in) :: iperm(:) + integer, intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer :: ictxt + integer :: int_err(5), i1sz, err_act + real(psb_spk_),allocatable :: dtemp(:) + integer, allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + integer :: debug_level, debug_unit + + interface sgelp + subroutine sgelp(trans,m,n,p,b,ldb,work,lwork,ierror) + use psb_const_mod + integer, intent(in) :: ldb, m, n, lwork + integer, intent(out) :: ierror + character, intent(in) :: trans + real(psb_spk_), intent(inout) :: b(*), work(*) + integer, intent(in) :: p(*) + end subroutine sgelp + end interface + + interface isaperm + + logical function isaperm(n,ip) + integer, intent(in) :: n + integer, intent(inout) :: ip(*) + end function isaperm + end interface + + character(len=20) :: name, ch_err + name = 'psb_sgelpv' + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.isaperm(i1sz,itemp)) then + info = 70 + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call sgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) + if(info /= 0) then + info=4010 + ch_err='sgelp' + call psb_errpush(info,name,a_err=ch_err) + end if + + deallocate(dtemp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_sgelpv + diff --git a/base/serial/psb_sipcoo2csc.f90 b/base/serial/psb_sipcoo2csc.f90 new file mode 100644 index 000000000..d84a0ff9f --- /dev/null +++ b/base/serial/psb_sipcoo2csc.f90 @@ -0,0 +1,214 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sipcoo2csc.f90 +! Subroutine: +! Arguments: + +subroutine psb_sipcoo2csc(a,info,clshr) + use psb_spmat_type + use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_sipcoo2csc + use psb_error_mod + use psb_string_mod + use psb_realloc_mod + implicit none + + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + logical, optional :: clshr + + integer, allocatable :: iaux(:), itemp(:) + !locals + logical :: clshr_ + Integer :: nza, i,j, idl,err_act,nc,icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + name='psb_ipcoo2csc' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) write(debug_unit,*) & + & trim(name),': start',a%fida,a%m + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) trim(name),' Invalid input ',a%fida + info = -1 + call psb_errpush(info,name) + goto 9999 + end if + if (present(clshr)) then + clshr_ = clshr + else + clshr_ = .false. + end if + + call psb_fixcoo(a,info,idir=1) + nc = a%k + nza = a%infoa(psb_nnz_) + allocate(iaux(max(nc+1,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) + goto 9999 + end if + if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& + & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) + + call psb_transfer(a%ia2,itemp,info) + call psb_transfer(iaux,a%ia2,info) + + ! + ! This routine can be used in two modes: + ! 1. Normal: just look at the col indices and trust them. This + ! implies putting in empty cols where needed. In this case you + ! can get in trouble if A%M < A%IA1(NZA) + ! 2. Shrink mode: disregard the actual value of the col indices, + ! just treat them as ident markers. In this case you can get in + ! trouble when the number of distinct col indices is greater + ! than A%M + ! + ! + + a%ia2(1) = 1 + + if (nza <= 0) then + do i=1,nc + a%ia2(i+1) = a%ia2(i) + end do + else + + if (clshr_) then + + j = 1 + i = 1 + icl = itemp(j) + + do j=1, nza + if (itemp(j) /= icl) then + a%ia2(i+1) = j + icl = itemp(j) + i = i + 1 + if (i>nc) then + write(debug_unit,*) trim(name),': CLSHR=.true. : ',& + & i, nc,' Expect trouble!' + exit + end if + endif + enddo +! write(debug_unit,*) 'Exit from loop',j,nza,i + do + if (i>=nc+1) exit + a%ia2(i+1) = j + i = i + 1 + end do + + else + + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + end if + + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i>nc) then + write(debug_unit,*) trim(name),& + & 'strange situation: i>nc ',i,nc,j,nza,icl,idl + exit outer + end if + a%ia2(i+1) = a%ia2(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + if (i>nc) then + write(debug_unit,*) trim(name), & + &'Strange situation: ',i,nc,size(a%ia2),& + & nza,j,itemp(j) + end if + a%ia2(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i>nc) exit + enddo outer + ! + ! Cleanup empty cols at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) + endif + do + if (i>nc) exit + a%ia2(i+1) = j + i = i + 1 + end do + + endif + + end if + +!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza + a%fida='CSC' + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='deallocate') + goto 9999 + end if + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_sipcoo2csc diff --git a/base/serial/psb_sipcoo2csr.f90 b/base/serial/psb_sipcoo2csr.f90 new file mode 100644 index 000000000..3c1df84fb --- /dev/null +++ b/base/serial/psb_sipcoo2csr.f90 @@ -0,0 +1,213 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sipcoo2csr.f90 +! Subroutine: +! Arguments: + +subroutine psb_sipcoo2csr(a,info,rwshr) + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_serial_mod, psb_protect_name => psb_sipcoo2csr + use psb_error_mod + use psb_string_mod + implicit none + + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + logical, optional :: rwshr + + integer, allocatable :: iaux(:), itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + name='psb_ipcoo2csr' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': start',a%fida,a%m + if (psb_toupper(a%fida) /= 'COO') then + write(debug_unit,*) trim(name),': Invalid input ',a%fida + info = -1 + call psb_errpush(info,name) + goto 9999 + end if + if (present(rwshr)) then + rwshr_ = rwshr + else + rwshr_ = .false. + end if + + call psb_fixcoo(a,info) + nr = a%m + nza = a%infoa(psb_nnz_) + allocate(iaux(max(nr+1,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) + goto 9999 + end if + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) + + call psb_transfer(a%ia1,itemp,info) + call psb_transfer(a%ia2,a%ia1,info) + call psb_transfer(iaux,a%ia2,info) + + ! + ! This routine can be used in two modes: + ! 1. Normal: just look at the row indices and trust them. This + ! implies putting in empty rows where needed. In this case you + ! can get in trouble if A%M < A%IA1(NZA) + ! 2. Shrink mode: disregard the actual value of the row indices, + ! just treat them as ident markers. In this case you can get in + ! trouble when the number of distinct row indices is greater + ! than A%M + ! + ! + + a%ia2(1) = 1 + + if (nza <= 0) then + do i=1,nr + a%ia2(i+1) = a%ia2(i) + end do + else + + if (rwshr_) then + + + j = 1 + i = 1 + irw = itemp(j) + + do j=1, nza + if (itemp(j) /= irw) then + a%ia2(i+1) = j + irw = itemp(j) + i = i + 1 + if (i>nr) then + write(debug_unit,*) trim(name),': RWSHR=.true. : ',& + & i, nr,' Expect trouble!' + exit + end if + endif + enddo + do + if (i>=nr+1) exit + a%ia2(i+1) = j + i = i + 1 + end do + + else + + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%ia2(i+1) = a%ia2(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%ia2(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%ia2(i+1) = j + i = i + 1 + end do + + endif + + end if + + a%fida='CSR' + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp,stat=info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='deallocate') + goto 9999 + end if + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_sipcoo2csr diff --git a/base/serial/psb_sipcsr2coo.f90 b/base/serial/psb_sipcsr2coo.f90 new file mode 100644 index 000000000..3d4b040f6 --- /dev/null +++ b/base/serial/psb_sipcsr2coo.f90 @@ -0,0 +1,102 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sipcsr2coo.f90 +! Subroutine: +! Arguments: + +Subroutine psb_sipcsr2coo(a,info) + use psb_spmat_type + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_realloc_mod + use psb_serial_mod, psb_protect_name => psb_sipcsr2coo + implicit none + + !....Parameters... + Type(psb_sspmat_type), intent(inout) :: A + Integer, intent(out) :: info + + !locals + Integer :: nza, nr + integer :: i,j,err_act + integer, allocatable :: iaux(:), itemp(:) + character(len=20) :: name='psb_sipcsr2coo' + + info = 0 + call psb_erractionsave(err_act) + + if (psb_toupper(a%fida) /= 'CSR') then + info = 5 + call psb_errpush(info,name) + goto 9999 + end if + + nr = a%m + nza = a%ia2(nr+1) - 1 + allocate(iaux(max(nza,1)),stat=info) + if (info /= 0) then + info=4025 + call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) + goto 9999 + end if +!!$ write(0,*) 'ipcsr2coo ',a%m + call psb_transfer(a%ia2,itemp,info) + call psb_transfer(a%ia1,a%ia2,info) + call psb_transfer(iaux,a%ia1,info) + + do i=1, nr + do j=itemp(i),itemp(i+1)-1 + a%ia1(j) = i + end do + end do + + a%fida='COO' + a%infoa(psb_nnz_) = nza + a%infoa(psb_srtd_) = psb_isrtdcoo_ + a%infoa(psb_upd_) = psb_upd_srch_ + + deallocate(itemp) + call psb_fixcoo(a,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end Subroutine psb_sipcsr2coo diff --git a/base/serial/psb_sneigh.f90 b/base/serial/psb_sneigh.f90 new file mode 100644 index 000000000..1dec1f7a6 --- /dev/null +++ b/base/serial/psb_sneigh.f90 @@ -0,0 +1,121 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sneigh.f90 +! Subroutine: +! Arguments: + +subroutine psb_sneigh(a,idx,neigh,n,info,lev) + + use psb_realloc_mod + use psb_const_mod + use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_sneigh + implicit none + + + type(psb_sspmat_type), intent(in) :: a ! the sparse matrix + integer, intent(in) :: idx ! the index whose neighbours we want to find + integer, intent(out) :: n, info ! the number of neighbours and the info + integer, allocatable :: neigh(:) ! the neighbours + integer, optional :: lev ! level of neighbours to find + + integer :: lev_, i, nl, ifl,ill,& + & n1, err_act, nn, nidx,ntl + character(len=20) :: name + integer, allocatable :: ia(:), ja(:) + real(psb_spk_), allocatable :: val(:) + + name='psb_sneigh' + info = 0 + call psb_erractionsave(err_act) + + n = 0 + info = 0 + if(present(lev)) then + lev_=lev + else + lev_=1 + end if + + call psb_sp_getrow(idx,a,n,ia,ja,val,info) + if (info == 0) call psb_realloc(n,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + + + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then + call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) + if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn) + ifl = ill + 1 + ill = ill + nn + end do + call imsru(ill,neigh,psb_sort_up_,nn) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_sneigh + diff --git a/base/serial/psb_snumbmm.f90 b/base/serial/psb_snumbmm.f90 new file mode 100644 index 000000000..e240e5bc6 --- /dev/null +++ b/base/serial/psb_snumbmm.f90 @@ -0,0 +1,145 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_snumbmm.f90 +! Subroutine: +! Arguments: +! +! +! Note: This subroutine performs the numerical product of two sparse matrices. +! It is modeled after the SMMP package by R. Bank and C. Douglas, but is +! rewritten in Fortran 95 making use of our sparse matrix facilities. +! +! + +subroutine psb_snumbmm(a,b,c) + use psb_spmat_type + use psb_serial_mod, psb_protect_name => psb_snumbmm + implicit none + + type(psb_sspmat_type) :: a,b,c + real(psb_spk_), allocatable :: temp(:) + integer :: info + logical :: csra, csrb + + allocate(temp(max(a%m,a%k,b%m,b%k)),stat=info) + if (info /= 0) then + return + endif + call psb_realloc(size(c%ia1),c%aspk,info) + ! + ! Note: we still have to test about possible performance hits. + ! + ! + csra = (psb_toupper(a%fida(1:3))=='CSR') + csrb = (psb_toupper(b%fida(1:3))=='CSR') + + if (csra.and.csrb) then + call snumbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,a%aspk,& + & b%ia2,b%ia1,0,b%aspk,& + & c%ia2,c%ia1,0,c%aspk,temp) + else + call inner_numbmm(a,b,c,temp,info) + if (info /= 0) then + 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 + +contains + + subroutine inner_numbmm(a,b,c,temp,info) + type(psb_sspmat_type) :: a,b,c + integer :: info + real(psb_spk_) :: temp(:) + integer, allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + real(psb_spk_), allocatable :: aval(:),bval(:) + integer :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + real(psb_spk_) :: ajj + + n = a%m + m = a%k + l = b%k + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= 0) then + return + endif + + do i = 1,maxlmn + temp(i) = szero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(0,*) ' NUMBMM: Problem with A ',i,jj,j,m + info = 1 + return + + endif + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + info = 2 + return + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%ia2(i),c%ia2(i+1)-1 + if((c%ia1(j)<1).or. (c%ia1(j) > maxlmn)) then + write(0,*) ' NUMBMM: output problem',i,j,c%ia1(j),maxlmn + info = 3 + return + else + c%aspk(j) = temp(c%ia1(j)) + temp(c%ia1(j)) = szero + endif + end do + end do + + + end subroutine inner_numbmm + +end subroutine psb_snumbmm diff --git a/base/serial/psb_srwextd.f90 b/base/serial/psb_srwextd.f90 new file mode 100644 index 000000000..89a6d81e8 --- /dev/null +++ b/base/serial/psb_srwextd.f90 @@ -0,0 +1,175 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_srwextd.f90 +! Subroutine: +! Arguments: +! +! We have a problem here: 1. How to handle well all the formats? +! 2. What should we do with rowscale? Does it only +! apply when a%fida='COO' ?????? +! +! +subroutine psb_srwextd(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_srwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer, intent(in) :: nr + type(psb_sspmat_type), intent(inout) :: a + integer,intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer :: i,j,ja,jb,err_act,nza,nzb + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_srwextd' + info = 0 + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + if (nr > a%m) then + if (psb_toupper(a%fida) == 'CSR') then + call psb_ensure_size(nr+1,a%ia2,info) + if (present(b)) then + nzb = psb_sp_get_nnzeros(b) + call psb_ensure_size(size(a%ia1)+nzb,a%ia1,info) + call psb_ensure_size(size(a%aspk)+nzb,a%aspk,info) + if (psb_toupper(b%fida)=='CSR') then + + do i=1, min(nr-a%m,b%m) + a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i) + ja = a%ia2(a%m+i) + jb = b%ia2(i) + do + if (jb >= b%ia2(i+1)) exit + a%aspk(ja) = b%aspk(jb) + a%ia1(ja) = b%ia1(jb) + ja = ja + 1 + jb = jb + 1 + end do + end do + do j=i,nr-a%m + a%ia2(a%m+i+1) = a%ia2(a%m+i) + end do + else + write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + endif + else + do i=a%m+2,nr+1 + a%ia2(i) = a%ia2(i-1) + end do + end if + a%m = nr + a%k = max(a%k,b%k) + + else if (psb_toupper(a%fida) == 'COO') then + + if (present(b)) then + nza = psb_sp_get_nnzeros(a) + nzb = psb_sp_get_nnzeros(b) + call psb_sp_reall(a,nza+nzb,info) + if (psb_toupper(b%fida)=='COO') then + if (rowscale_) then + do j=1,nzb + if ((a%m + b%ia1(j)) <= nr) then + nza = nza + 1 + a%ia1(nza) = a%m + b%ia1(j) + a%ia2(nza) = b%ia2(j) + a%aspk(nza) = b%aspk(j) + end if + enddo + else + do j=1,nzb + if ((b%ia1(j)) <= nr) then + nza = nza + 1 + a%ia1(nza) = b%ia1(j) + a%ia2(nza) = b%ia2(j) + a%aspk(nza) = b%aspk(j) + endif + enddo + endif + a%infoa(psb_nnz_) = nza + else if(psb_toupper(b%fida)=='CSR') then + do i=1, min(nr-a%m,b%m) + do + jb = b%ia2(i) + if (jb >= b%ia2(i+1)) exit + nza = nza + 1 + a%aspk(nza) = b%aspk(jb) + a%ia1(nza) = a%m + i + a%ia2(nza) = b%ia1(jb) + jb = jb + 1 + end do + end do + a%infoa(psb_nnz_) = nza + else + write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + endif + endif + a%m = nr + a%k = max(a%k,b%k) + else if (a%fida == 'JAD') then + info=135 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_srwextd diff --git a/base/serial/psb_sspclip.f90 b/base/serial/psb_sspclip.f90 new file mode 100644 index 000000000..d749da381 --- /dev/null +++ b/base/serial/psb_sspclip.f90 @@ -0,0 +1,157 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspclip.f90 +! Subroutine: psb_sspclip +! Creates a "clipped" copy of input matrix A. Output is always in COO. +! Arguments: + +!***************************************************************************** +!* * +!***************************************************************************** +subroutine psb_sspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_sspclip + implicit none + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(out) :: b + integer, intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer :: err_act + character(len=20) :: name + integer :: imin_,imax_,jmin_,jmax_ + logical :: rscale_,cscale_ + integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j + integer, parameter :: irbk=40 + + name='psb_ssp_clip' + info = 0 + call psb_erractionsave(err_act) + call psb_set_erraction(0) + + call psb_nullify_sp(b) + + + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + endif + if (present(imax)) then + imax_ = imax + else + imax_ = a%m + endif + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%k + endif + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + endif + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + endif + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%m ! Should this be imax_ ?? + endif + if (cscale_) then + kb = jmax_ - jmin_ +1 + else + kb = a%k ! Should this be jmax_ ?? + endif + + + sizeb = psb_sp_get_nnzeros(a) + call psb_sp_all(mb,kb,b,sizeb,info) + b%fida = 'COO' + b%descra = a%descra + nzb = 0 + do i=imin_, imax_, irbk + nrt = min(irbk,imax_-i+1) + ifst = i + ilst = ifst + nrt - 1 + call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& + & lrw=ilst, append=.true.,nzin=nzb) + do j=nzb+1,nzb+nzt + if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then + nzb = nzb + 1 + b%aspk(nzb) = b%aspk(j) + b%ia1(nzb) = b%ia1(j) + b%ia2(nzb) = b%ia2(j) + end if + end do + + end do + b%infoa(psb_nnz_) = nzb + + if (rscale_) then + do i=1, nzb + b%ia1(i) = b%ia1(i) - imin_ + 1 + end do + end if + if (cscale_) then + do i=1, nzb + b%ia2(i) = b%ia2(i) - jmin_ + 1 + end do + end if + call psb_fixcoo(b,info) + call psb_sp_trim(b,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sspclip + diff --git a/base/serial/psb_sspcnv.f90 b/base/serial/psb_sspcnv.f90 new file mode 100644 index 000000000..5291d9816 --- /dev/null +++ b/base/serial/psb_sspcnv.f90 @@ -0,0 +1,572 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspcnv.f90 +! +! Subroutine: psb_sspcnv2 +! This subroutine converts the storage format of a matrix. +! +! Arguments: +! +! a - type(psb_spmat_type), input The input matrix to be converted. +! b - type(psb_spmat_type), output The assembled output matrix. +! info - integer. Return code +! afmt - character, optional The desired storage format +! +subroutine psb_sspcnv2(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_sspcnv2 + implicit none + !....Parameters... + Type(psb_sspmat_type), intent(in) :: A + Type(psb_sspmat_type), intent(out) :: B + Integer, intent(out) :: info + Integer, intent(in), optional :: upd,dupl + character(len=*), optional, intent(in) :: afmt + + !...Locals... + real(psb_spk_) :: d(1) + real(psb_spk_), allocatable :: work(:) + type(psb_sspmat_type) :: temp_a + Integer :: nzr, ntry, ifc_, ia1_size,& + & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ + integer :: err_act + character :: check_,trans_,unitd_ + character(len=5) :: afmt_ + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_spcnv2' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ntry=0 + + ifc_ = 2 + + check_ = 'N' + trans_ = 'N' + unitd_ = 'U' + allocate(work(max(size(a%ia1),size(a%ia2))+a%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_ = psb_toupper(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=psb_toupper(afmt_) + size_req = psb_sp_get_nnzeros(a) + ! + 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 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': size_req 1:',& + & size_req, trans_,upd_,dupl_,b%fida,b%descra + + select case (psb_toupper(a%fida)) + + case ('CSR') + + select case (psb_toupper(b%fida)) + + case ('CSR') + + call scrcr(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='scrcr' + 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 scrjd(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='scrjd') + goto 9999 + endif + + ntry = ntry + 1 + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),' On out from scrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(debug_unit,*) trim(name),& + & ' Tried reallocating for SCRJAD 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra + call scrco(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 (psb_toupper(b%fida)) + + case ('CSR') + + call scocr(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='scocr') + 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 scocr(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='scocr') + goto 9999 + end if + + do + call scrjd(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='scrjd') + goto 9999 + end if + + ntry = ntry + 1 + if (debug_level >= psb_debug_serial_) then + write(debug_unit,*) trim(name),' On out from scrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(debug_unit,*) trim(name),' Tried reallocating for sCRJAD 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 scoco(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='scoco') + 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_) then + call psb_sp_trim(b,info) + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sspcnv2 + + +! +! Subroutine: psb_sspcnv1 +! This subroutine converts in place the storage format of a matrix. +! +! Arguments: +! +! a - type(psb_spmat_type), inout The input matrix to be converted. +! info - integer. Return code +! afmt - character, optional The desired storage format +! +subroutine psb_sspcnv1(a, info, afmt, upd, dupl) + + use psb_spmat_type + use psb_regen_mod + use psb_serial_mod, psb_protect_name => psb_sspcnv1 + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + !use psb_penv_mod + + implicit none + + + !...Parameters.... + type(psb_sspmat_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_sspmat_type) :: atemp + integer :: err_act + integer :: spstate + integer :: upd_, dupl_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + logical :: inplace + + info = 0 + int_err(1)=0 + name = 'psb_spcnv1' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': 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_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ + inplace = .false. + if (upd_ == psb_upd_srch_) then + if (present(afmt)) then + select case (psb_toupper(a%fida)) + case('COO') + select case(psb_toupper(afmt)) + case('COO') + call psb_fixcoo(a,info) + inplace = .true. + case('CSR') + call psb_ipcoo2csr(a,info) + inplace = .true. + case('CSC') + call psb_ipcoo2csc(a,info) + inplace = .true. + end select + case('CSR') + select case(psb_toupper(afmt)) + case('COO') + call psb_ipcsr2coo(a,info) + inplace = .true. + end select + end select + end if + if (inplace) then + if (info == 0) call psb_sp_trim(a,info) + if (info /= 0) then + info=4010 + ch_err='inplace cnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + call psb_erractionrestore(err_act) + return + 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 + + ! 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_level >= psb_debug_serial_)& + & write(debug_unit, *) trim(name),& + & ': 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 + + call psb_sp_free(atemp,info) + + else if (spstate == psb_spmat_upd_) then + ! + ! Second case: we come from an update loop. + ! + select case(psb_toupper(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 + + 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_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),& + & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + + endif + + 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 == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sspcnv1 diff --git a/base/serial/psb_sspgetrow.f90 b/base/serial/psb_sspgetrow.f90 new file mode 100644 index 000000000..e63c8f9be --- /dev/null +++ b/base/serial/psb_sspgetrow.f90 @@ -0,0 +1,130 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspgetrow.f90 +! Subroutine: psb_sspgetrow +! Gets one or more rows from a sparse matrix. +! Arguments: +! irw - integer, input The row to be extracted +! a - type(psb_sspmat_type),input The sparse matrix +! nz - integer, output The number of entries +! ia(:) - integer, allocatable, inout The output row indices +! ja(:) - integer, allocatable, inout The output col indices +! val(:) - real, allocatable,inout The coefficients +! info - integer, output Error code +! iren(:) - integer, input,optional Renumbering of indices +! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw +! append - logical, input,optional Should we append to already existing +! partial output? +! nzin - integer, input, optional If appending, how many entries were already +! occupied. +! +subroutine psb_sspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) + ! Output is always in COO format + use psb_spmat_type + use psb_const_mod + use psb_getrow_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_sspgetrow + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: irw + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: lrw, nzin + + logical :: append_ + integer :: nzin_, lrw_, irw_, err_act + character(len=20) :: name, ch_err + + name='psb_spgetrow' + info = 0 + + call psb_erractionsave(err_act) + + irw_ = irw + if (present(lrw)) then + lrw_ = lrw + else + lrw_ = irw + endif + if (lrw_ < irw) then + write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ + lrw_ = irw + end if + if (present(append)) then + append_=append + else + append_=.false. + endif + + + if ((append_).and.(present(nzin))) then + nzin_ = nzin + else + nzin_ = 0 + endif + + select case (psb_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) + return + +9999 continue +!!$ call psb_erractionrestore(err_act) + call psb_erractionsave(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_sspgetrow + diff --git a/base/serial/psb_sspgtblk.f90 b/base/serial/psb_sspgtblk.f90 new file mode 100644 index 000000000..aed1617ce --- /dev/null +++ b/base/serial/psb_sspgtblk.f90 @@ -0,0 +1,114 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspgtblk.f90 +! Subroutine: psb_sspgtblk +! Gets one or more rows from a sparse matrix. +! Arguments: +!***************************************************************************** +!* * +!* Takes a specified row from matrix A and copies into matrix B (possibly * +!* appending to B). Output is always COO. Input might be anything, * +!* * +!***************************************************************************** +subroutine psb_sspgtblk(irw,a,b,info,append,iren,lrw,srt) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_sspgtblk + implicit none + + type(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: irw + type(psb_sspmat_type), intent(inout) :: b + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), target, optional :: iren(:) + integer, intent(in), optional :: lrw + logical, intent(in), optional :: srt + + logical :: append_,srt_ + integer :: nz,nzb, lrw_, irw_ + character(len=20) :: name + + name='psb_spgtblk' + info = 0 + + irw_ = irw + if (present(lrw)) then + lrw_ = lrw + else + lrw_ = irw + endif + if (lrw_ < irw) then + write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ + lrw_ = irw + end if + if (present(append)) then + append_ = append + else + append_ = .false. + endif + + if (present(srt)) then + srt_ = srt + else + srt_ = .true. + endif + + + if (append_) then + nzb = b%infoa(psb_nnz_) + else + nzb = 0 + b%m = 0 + b%k = 0 + b%descra = a%descra + endif + b%fida = 'COO' + + call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& + & lrw=lrw_,append=append_,nzin=nzb) + if (info == 0) call psb_ensure_size(1,b%pl,info) + if (info == 0) call psb_ensure_size(1,b%pr,info) + if (info /= 0) return + b%pl = 0 + b%pr = 0 + b%infoa(psb_nnz_) = nzb+nz + b%m = b%m+lrw_-irw+1 + b%k = max(b%k,a%k) + if (srt_) call psb_fixcoo(b,info) + return + +end subroutine psb_sspgtblk + diff --git a/base/serial/psb_sspgtdiag.f90 b/base/serial/psb_sspgtdiag.f90 new file mode 100644 index 000000000..bc31d9ce8 --- /dev/null +++ b/base/serial/psb_sspgtdiag.f90 @@ -0,0 +1,123 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspgtdiag.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* * +!***************************************************************************** +subroutine psb_sspgtdiag(a,d,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_error_mod + use psb_const_mod + use psb_serial_mod, psb_protect_name => psb_sspgtdiag + implicit none + + type(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(inout) :: d(:) + integer, intent(out) :: info + + type(psb_sspmat_type) :: tmpa + integer :: i,j, err_act, ii, rng, irb, nrb + character(len=20) :: name, ch_err + + name='psb_sspgtdiag' + info = 0 + call psb_erractionsave(err_act) + + if (size(d) < min(a%k,a%m)) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = 0.d0 + if (a%fida == 'CSR') then + + do i=1, min(a%m,a%k) + do j=a%ia2(i),a%ia2(i+1)-1 + if (a%ia1(j) == i) then + d(i) = a%aspk(j) + end if + end do + end do + + else if (a%fida == 'COO') then + + do i=1,a%infoa(psb_nnz_) + j=a%ia1(i) + if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then + d(j) = a%aspk(i) + endif + enddo + + else if (a%fida == 'JAD') then + + rng=min(a%m,a%k) + nrb=16 + do i=1, rng, nrb + irb=min(i+nrb-1,rng) + call psb_sp_getblk(i,a,tmpa,info,lrw=irb) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do ii=1,tmpa%infoa(psb_nnz_) + j=tmpa%ia1(ii) + if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then + d(j) = tmpa%aspk(ii) + endif + enddo + + end do + + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sspgtdiag + diff --git a/base/serial/psb_sspscal.f90 b/base/serial/psb_sspscal.f90 new file mode 100644 index 000000000..d32efd493 --- /dev/null +++ b/base/serial/psb_sspscal.f90 @@ -0,0 +1,99 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspscal.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* * +!***************************************************************************** +subroutine psb_sspscal(a,d,info) + ! the input format + use psb_spmat_type + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + real(psb_spk_), intent(in) :: d(:) + + integer :: i,j,err_act + character(len=20) :: name, ch_err + + name='psb_sspscal' + info = 0 + call psb_erractionsave(err_act) + + select case(psb_toupper(a%fida(1:3))) + case ('CSR') + + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + a%aspk(j) = a%aspk(j) * d(i) + end do + end do + + case ('COO') + + do i=1,a%infoa(psb_nnz_) + j=a%ia1(i) + a%aspk(i) = a%aspk(i) * d(j) + enddo + + case ('JAD') + info=135 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + case default + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sspscal + diff --git a/base/serial/psb_ssymbmm.f90 b/base/serial/psb_ssymbmm.f90 new file mode 100644 index 000000000..0404b69b4 --- /dev/null +++ b/base/serial/psb_ssymbmm.f90 @@ -0,0 +1,194 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ssymbmm.f90 +! Subroutine: +! Arguments: +! +! +! Note: This subroutine performs the symbolic product of two sparse matrices. +! It is modeled after the SMMP package by R. Bank and C. Douglas, but is +! rewritten in Fortran 95 making use of our sparse matrix facilities. +! + +subroutine psb_ssymbmm(a,b,c,info) + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_ssymbmm + implicit none + + type(psb_sspmat_type) :: a,b,c + integer, allocatable :: itemp(:) + integer :: nze,info + + interface + subroutine symbmm (n, m, l, ia, ja, diaga, & + & ib, jb, diagb, ic, jc, diagc, index) + integer n,m,l, ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & diagc, index(*) + integer, allocatable :: ic(:),jc(:) + end subroutine symbmm + end interface + character(len=20) :: name + integer :: err_act + logical :: csra, csrb + name='psb_symbmm' + call psb_erractionsave(err_act) + + csra = (psb_toupper(a%fida(1:3))=='CSR') + csrb = (psb_toupper(b%fida(1:3))=='CSR') + + if (b%m /= a%k) then + write(0,*) 'Mismatch in SYMBMM: ',a%m,a%k,b%m,b%k + endif + allocate(itemp(max(a%m,a%k,b%m,b%k)),stat=info) + if (info /= 0) then + return + endif + nze = max(a%m+1,2*a%m) + call psb_sp_reall(c,nze,info) + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + if (csra.and.csrb) then + call symbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,& + & b%ia2,b%ia1,0,& + & c%ia2,c%ia1,0,itemp) + else + call inner_symbmm(a,b,c,itemp,info) + endif + call psb_realloc(size(c%ia1),c%aspk,info) + + c%pl(1) = 0 + c%pr(1) = 0 + c%m=a%m + c%k=b%k + c%fida='CSR' + c%descra='GUN' + + deallocate(itemp) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine inner_symbmm(a,b,c,index,info) + type(psb_sspmat_type) :: a,b,c + integer :: index(:),info + integer, allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + real(psb_spk_), allocatable :: aval(:),bval(:) + integer :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + + + n = a%m + m = a%k + l = b%k + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= 0) then + return + endif + + + if (size(c%ia2) < n+1) then + + call psb_realloc(n+1,c%ia2,info) + endif + do i=1,maxlmn + index(i)=0 + end do + + c%ia2(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call psb_sp_getrow(i,a,nazr,iarw,iacl,aval,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(0,*) ' SymbMM: Problem with A ',i,jj,j,m + info = 1 + return + endif + call psb_sp_getrow(j,b,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + info=2 + return + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%ia2(i+1)=c%ia2(i)+length + + if (c%ia2(i+1) > size(c%ia1)) then + if (n > (2*i)) then + nze = max(c%ia2(i+1), c%ia2(i)*((n+i-1)/i)) + else + nze = max(c%ia2(i+1), nint((dble(c%ia2(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ia1,info) + end if + do j= c%ia2(i),c%ia2(i+1)-1 + c%ia1(j)=istart + istart=index(istart) + index(c%ia1(j))=0 + end do + call psb_msort(c%ia1(c%ia2(i):c%ia2(i)+length-1)) + index(i) = 0 + end do main + + end subroutine inner_symbmm + +end subroutine psb_ssymbmm diff --git a/base/serial/psb_stransp.f90 b/base/serial/psb_stransp.f90 new file mode 100644 index 000000000..213993a63 --- /dev/null +++ b/base/serial/psb_stransp.f90 @@ -0,0 +1,80 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_stransp.f90 +! Subroutine: +! Arguments: + +subroutine psb_stransp(a,b,c,fmt) + use psb_spmat_type + use psb_tools_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_stransp + implicit none + + type(psb_sspmat_type), intent(inout) :: a + type(psb_sspmat_type), intent(out) :: b + integer, optional :: c + character(len=*), optional :: fmt + + character(len=5) :: fmt_ + integer ::c_, info + integer, allocatable :: itmp(:) + + if (present(c)) then + c_=c + else + c_=1 + endif + if (present(fmt)) then + fmt_ = psb_toupper(fmt) + else + fmt_='CSR' + 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 + call psb_spcnv(b,info,afmt=fmt_) + + return +end subroutine psb_stransp diff --git a/base/serial/psb_update_mod.f90 b/base/serial/psb_update_mod.f90 index dc7e987c0..631185e05 100644 --- a/base/serial/psb_update_mod.f90 +++ b/base/serial/psb_update_mod.f90 @@ -32,24 +32,69 @@ module psb_update_mod interface psb_srch_upd - module procedure psb_d_srch_upd, psb_z_srch_upd + module procedure psb_s_srch_upd, psb_d_srch_upd, psb_c_srch_upd, psb_z_srch_upd end interface interface coo_srch_upd - module procedure d_coo_srch_upd, z_coo_srch_upd + module procedure s_coo_srch_upd, d_coo_srch_upd, c_coo_srch_upd, z_coo_srch_upd end interface interface csr_srch_upd - module procedure d_csr_srch_upd, z_csr_srch_upd + module procedure s_csr_srch_upd, d_csr_srch_upd, c_csr_srch_upd, z_csr_srch_upd end interface interface jad_srch_upd - module procedure d_jad_srch_upd, z_jad_srch_upd + module procedure s_jad_srch_upd, d_jad_srch_upd, c_jad_srch_upd, z_jad_srch_upd end interface contains + subroutine psb_s_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_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + + info = 0 + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + end if + select case(psb_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_s_srch_upd + subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -95,6 +140,68 @@ contains end subroutine psb_d_srch_upd + subroutine psb_c_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_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + + info = 0 + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + select case(psb_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(psb_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 + + end subroutine psb_c_srch_upd + + subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -157,6 +264,657 @@ contains end subroutine psb_z_srch_upd + subroutine s_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 + use psb_error_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + + integer :: debug_level, debug_unit + character(len=20) :: name='s_csr_srch_upd' + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,lb,ub,m,dupl + + info = 0 + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = psb_sp_getifld(psb_dupl_,a,info) + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc=i2-i1 + + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc = i2-i1 + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= a%m)) then + + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc=i2-i1 + + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc = i2-i1 + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + end if + + end subroutine s_csr_srch_upd + + subroutine s_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_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl + integer :: debug_level, debug_unit + character(len=20) :: name='s_coo_srch_upd' + + info = 0 + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + dupl = psb_sp_getifld(psb_dupl_,a,info) + + if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = psb_sp_getifld(psb_nnz_,a,info) + + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + 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) + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine s_coo_srch_upd + + subroutine s_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_sspmat_type), intent(inout), target :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + real(psb_spk_), 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,& + & i,j,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) == 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) > 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) == 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) > 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 s_jad_srch_upd + subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -262,6 +1020,7 @@ contains & write(debug_unit,*) trim(name),& & ': Discarding row that does not belong to us.' end if + end if end do @@ -809,6 +1568,659 @@ contains end subroutine d_jad_srch_upd + subroutine c_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_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,lb,ub,m,dupl + + integer :: debug_level, debug_unit + character(len=20) :: name='c_csr_srch_upd' + + info = 0 + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = psb_sp_getifld(psb_dupl_,a,info) + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc=i2-i1 + + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc = i2-i1 + call issrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= a%m)) then + + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc=i2-i1 + + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ia1(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + i1 = a%ia2(ir) + i2 = a%ia2(ir+1) + nc = i2-i1 + call ibsrch(ip,ic,nc,a%ia1(i1:i2-1)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + end if + + end subroutine c_csr_srch_upd + + subroutine c_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_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl + integer :: debug_level, debug_unit + character(len=20) :: name='c_coo_srch_upd' + + + info = 0 + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + dupl = psb_sp_getifld(psb_dupl_,a,info) + + if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = psb_sp_getifld(psb_nnz_,a,info) + + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + 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) + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= a%m)) then + + if (ir /= ilr) then + call ibsrch(i1,ir,nnz,a%ia1) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia1(i2+1) /= a%ia1(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia1(i1-1) /= a%ia1(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + call issrch(ip,ic,nc,a%ia2(i1:i2)) + if (ip>0) then + a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine c_coo_srch_upd + + + + subroutine c_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_cspmat_type), intent(inout), target :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza + complex(psb_spk_), 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,& + & i,j,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) == 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) > 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) == 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) > 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 c_jad_srch_upd + subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -913,6 +2325,7 @@ contains & write(debug_unit,*) trim(name),& & ': Discarding row that does not belong to us.' end if + end if end do diff --git a/base/serial/psb_zcoins.f90 b/base/serial/psb_zcoins.f90 index 5a2828c78..c55578fdf 100644 --- a/base/serial/psb_zcoins.f90 +++ b/base/serial/psb_zcoins.f90 @@ -119,7 +119,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) rebuild_ = .false. end if - call psb_touppers(a%fida,ufida) + ufida = psb_toupper(a%fida) spstate = psb_sp_getifld(psb_state_,a,info) diff --git a/base/serial/psb_zcsnmi.f90 b/base/serial/psb_zcsnmi.f90 index 81dcbfaf3..51ef37bbc 100644 --- a/base/serial/psb_zcsnmi.f90 +++ b/base/serial/psb_zcsnmi.f90 @@ -47,7 +47,7 @@ function psb_zcsnmi(a,info,trans) function zcsnmi(trans,m,n,fida,descra,a,ia1,ia2,& & infoa,ierror) use psb_const_mod - real(psb_dpk_) :: zcsnmi + real(psb_dpk_) :: zcsnmi integer :: m,n, ierror character :: trans integer :: ia1(*),ia2(*),infoa(*) diff --git a/base/serial/psb_zspcnv.f90 b/base/serial/psb_zspcnv.f90 index 8f666fbc2..fc5501017 100644 --- a/base/serial/psb_zspcnv.f90 +++ b/base/serial/psb_zspcnv.f90 @@ -98,7 +98,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) call psb_sp_setifld(dupl,psb_dupl_,b,info) end if if (present(afmt)) then - afmt_ = psb_tolower(afmt) + afmt_ = psb_toupper(afmt) else afmt_ = psb_fidef_ end if @@ -126,7 +126,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) ! ...matrix conversion... b%m=a%m b%k=a%k - b%fida=psb_tolower(afmt_) + b%fida=psb_toupper(afmt_) size_req = psb_sp_get_nnzeros(a) ! n_row=b%m @@ -170,13 +170,13 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) & write(debug_unit,*) trim(name),': size_req 1:',& & size_req, trans_,upd_,dupl_,b%fida,b%descra - select case (psb_tolower(a%fida)) + select case (psb_toupper(a%fida)) - case ('csr') + case ('CSR') - select case (psb_tolower(b%fida)) + select case (psb_toupper(b%fida)) - case ('csr') + 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,& @@ -191,7 +191,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('jad') + case ('JAD') !...converting to JAD !...output matrix may not be big enough @@ -234,7 +234,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('coo') + case ('COO') if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& @@ -253,11 +253,11 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) end select - case ('coo','coi') + case ('COO','COI') - select case (psb_tolower(b%fida)) + select case (psb_toupper(b%fida)) - case ('csr') + 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,& @@ -269,7 +269,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) goto 9999 end if - case ('jad') + case ('JAD') call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) if (info /= 0) then @@ -326,7 +326,7 @@ subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) end do - case ('coo') + 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,& @@ -460,22 +460,22 @@ subroutine psb_zspcnv1(a, info, afmt, upd, dupl) inplace = .false. if (upd_ == psb_upd_srch_) then if (present(afmt)) then - select case (psb_tolower(a%fida)) - case('coo') - select case(psb_tolower(afmt)) - case('coo') + select case (psb_toupper(a%fida)) + case('COO') + select case(psb_toupper(afmt)) + case('COO') call psb_fixcoo(a,info) inplace = .true. - case('csr') + case('CSR') call psb_ipcoo2csr(a,info) inplace = .true. - case('csc') + case('CSC') call psb_ipcoo2csc(a,info) inplace = .true. end select - case('csr') - select case(psb_tolower(afmt)) - case('coo') + case('CSR') + select case(psb_toupper(afmt)) + case('COO') call psb_ipcsr2coo(a,info) inplace = .true. end select @@ -525,12 +525,12 @@ subroutine psb_zspcnv1(a, info, afmt, upd, dupl) ! ! Second case: we come from an update loop. ! - select case(psb_tolower(a%fida)) - case('csr') + select case(psb_toupper(a%fida)) + case('CSR') call csr_regen(a,info) - case ('coo','coi') + case ('COO','COI') call coo_regen(a,info) - case('jad') + case('JAD') call jad_regen(a,info) case default info=136 diff --git a/base/tools/Makefile b/base/tools/Makefile index 4a0aa8226..6ee83b04d 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -1,18 +1,26 @@ include ../../Make.inc -FOBJS = psb_dallc.o psb_dasb.o psb_cdprt.o \ +FOBJS = psb_sallc.o psb_sasb.o \ + psb_sfree.o psb_sins.o \ + psb_dallc.o psb_dasb.o \ psb_dfree.o psb_dins.o \ - psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o \ + psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ + psb_sspalloc.o psb_sspasb.o \ + psb_sspfree.o psb_sspins.o psb_ssprn.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_zspfree.o\ - psb_zspins.o psb_zsprn.o + psb_zspins.o psb_zsprn.o \ + psb_cspalloc.o psb_cspasb.o psb_cspfree.o\ + psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \ + psb_cspins.o psb_csprn.o -MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_icdasb.o psb_dcdbldext.o psb_zcdbldext.o +MPFOBJS = psb_ssphalo.o psb_csphalo.o psb_dsphalo.o psb_zsphalo.o psb_icdasb.o \ + psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o LIBDIR=.. MODDIR=../modules diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 new file mode 100644 index 000000000..a50ecf3cb --- /dev/null +++ b/base/tools/psb_callc.f90 @@ -0,0 +1,264 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_callc.f90 +! +! Function: psb_calloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_calloc(x, desc_a, info, n, lb) + !....allocate dense matrix for psblas routines..... + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n, lb + + !locals + integer :: np,me,err,nr,i,j,err_act + integer :: ictxt,n_ + integer :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + int_err(1)=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=550 + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,psb_cd_get_local_cols(desc_a)) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,psb_cd_get_local_rows(desc_a)) + else + info = 4001 + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= 0) then + info=4025 + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:,:) = czero + + 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_calloc + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! Function: psb_callocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_callocv(x, desc_a,info,n) + !....allocate sparse matrix structure for psblas routines..... + use psb_descriptor_type + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_penv_mod + + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n + + !locals + integer :: np,me,nr,i,err_act + integer :: ictxt, int_err(5) + integer :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,psb_cd_get_local_cols(desc_a)) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,psb_cd_get_local_rows(desc_a)) + else + info = 4001 + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= 0) then + info=4025 + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:) = czero + + 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_callocv + diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 new file mode 100644 index 000000000..bf50a22c5 --- /dev/null +++ b/base/tools/psb_casb.f90 @@ -0,0 +1,264 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_casb.f90 +! +! Subroutine: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_casb(x, desc_a, info) + !....assembly dense matrix x ..... + use psb_descriptor_type + use psb_const_mod + use psb_comm_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer, intent(out) :: info + + ! local variables + integer :: ictxt,np,me,nrow,ncol, err_act + integer :: i1sz, i2sz + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_cgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if ((.not.allocated(desc_a%matrix_data))) then + info=3110 + call psb_errpush(info,name) + goto 9999 + endif + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & psb_cd_get_dectype(desc_a) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ',& + & psb_cd_get_dectype(desc_a) + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = psb_cd_get_context(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= 0) then + info=4010 + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_casb + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_casbv(x, desc_a, info) + !....assembly dense matrix x ..... + use psb_descriptor_type + use psb_const_mod + use psb_comm_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer, intent(out) :: info + + ! local variables + integer :: ictxt,np,me + integer :: int_err(5), i1sz,nrow,ncol, err_act + integer :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = 0 + int_err(1) = 0 + name = 'psb_cgeasb_v' + + ictxt = psb_cd_get_context(desc_a) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= 0) then + info=4010 + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_casbv + diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 new file mode 100644 index 000000000..aab2c449d --- /dev/null +++ b/base/tools/psb_ccdbldext.F90 @@ -0,0 +1,767 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccdbldext.f90 +! +! Subroutine: psb_ccdbldext +! This routine takes a matrix A with its descriptor, and builds the +! auxiliary descriptor corresponding to the number of overlap levels +! specified on input. +! +! Arguments: +! a - type(psb_cspmat_type). The input sparse matrix. +! desc_a - type(psb_desc_type). The input communication descriptor. +! novr - integer. The number of overlap levels. +! desc_ov - type(psb_desc_type). The auxiliary output communication +! descriptor. +! info - integer. Return code. +! extype - integer. Choice of type of overlap: +! psb_ovt_xhal_: build a descriptor with an extended +! stencil, i.e. enlarge the existing +! halo by novr additional layers. +! psb_ovt_asov_: build a descriptor suitable +! for Additive Schwarz preconditioner. +! This last choice implies that: +! a. The novr halo layers are added to +! the overlap; +! b. The novr layers are also copied to +! the ext_ structure to provide +! the mapping between the base +! descriptor and the overlapped one. +! c. The (novr+1)-th layer becomes the +! new halo. +! +Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) + + use psb_tools_mod, psb_protect_name => psb_ccdbldext + use psb_serial_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psi_mod +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + ! .. Array Arguments .. + integer, intent(in) :: novr + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in), target :: desc_a + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + + interface + subroutine psb_icdasb(desc_a,info,ext_hv) + use psb_descriptor_type + Type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + logical, intent(in),optional :: ext_hv + end subroutine psb_icdasb + end interface + integer icomm, err_act + + ! .. Local Scalars .. + Integer :: i, j, np, me,m,nnzero,& + & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo + Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& + & n_elem_send,tot_recv,tot_elem,cntov_o,& + & counter_t,n_elem,i_ovr,jj,proc_id,isz, & + & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ + + type(psb_cspmat_type) :: blk + Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) + Integer,allocatable :: halo(:),works(:),workr(:),t_halo_in(:),& + & t_halo_out(:),temp(:),maskr(:) + Integer,allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_ccdbldext' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + Call psb_info(ictxt, me, np) + + If (debug_level >= psb_debug_outer_) & + & Write(debug_unit,*) me,' ',trim(name),': start',novr + + if (present(extype)) then + extype_ = extype + else + extype_ = psb_ovt_xhal_ + endif + m = psb_cd_get_local_rows(desc_a) + nnzero = Size(a%aspk) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-m + + if (novr<0) then + info=10 + int_err(1)=1 + int_err(2)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) + if (info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':From desccpy' + if (novr==0) then + ! + ! Just copy the input. + ! + return + endif + + + + If (debug_level >= psb_debug_outer_)then + Write(debug_unit,*) me,' ',trim(name),':BEGIN ',nhalo + call psb_barrier(ictxt) + endif + + ! + ! Ok, since we are only estimating, do it as follows: + ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average + ! nonzeros per row is the same as the global. + ! + nztot = psb_sp_get_nnzeros(a) + if (nztot>0) then + lovr = ((nztot+m-1)/m)*nhalo*novr + lworks = ((nztot+m-1)/m)*nhalo + lworkr = ((nztot+m-1)/m)*nhalo + else + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + If (debug_level >= psb_debug_outer_)& + & Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr + + index_dim = size(desc_a%halo_index) + elem_dim = size(desc_a%halo_index) + + l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) + l_tmp_halo = novr*(3*Size(desc_a%halo_index)) + + call psb_cd_set_ovl_bld(desc_ov,info) + desc_ov%base_desc => desc_a + + If (debug_level >= psb_debug_outer_) then + Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + call psb_barrier(ictxt) + endif + + + Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& + & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(blk,max(lworks,lworkr),info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blk%fida='COO' + + Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& + & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + halo(:) = desc_a%halo_index(:) + tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_t = 1 + counter_h = 1 + counter_o = 1 + cntov_o = 1 + ! Init overlap with desc_a%ovrlap (if any) + counter = 1 + Do While (desc_a%ovrlap_index(counter) /= -1) + proc = desc_a%ovrlap_index(counter+psb_proc_id_) + n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) + n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) + + Do j=0,n_elem_recv-1 + + idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + orig_ovr(cntov_o)=proc + orig_ovr(cntov_o+1)=1 + orig_ovr(cntov_o+2)=gidx + orig_ovr(cntov_o+3)=-1 + cntov_o=cntov_o+3 + end Do + counter=counter+n_elem_recv+n_elem_send+3 + end Do + + + + + ! + ! A picture is in order to understand what goes on here. + ! I is the internal part; H is halo, R row, C column. The final + ! matrix with N levels of overlap looks like this + ! + ! I | Hc1 | 0 | 0 | + ! -------|-----|-----|-----| + ! Hr1 | Hd1 | Hc2 | 0 | + ! -------|-----|-----|-----| + ! 0 | Hr2 | Hd2 | Hc2 | + ! -------|-----|-----|-----| + ! 0 | 0 | Hr3 | Hd3 | Hc3 + ! + ! At the start we already have I and Hc1, so we know the row + ! indices that will make up Hr1, and also who owns them. As we + ! actually get those rows, we receive the column indices in Hc2; + ! these define the row indices for Hr2, and so on. When we have + ! reached the desired level HrN. + ! + ! + Do i_ovr = 1, novr + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Running on overlap level ',i_ovr,' of ',novr + + ! + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. + ! + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 + + desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + + Do While (halo(counter) /= -1) + tot_elem=0 + proc=halo(counter+psb_proc_id_) + n_elem_recv=halo(counter+psb_n_elem_recv_) + n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then + info = -1 + call psb_errpush(info,name) + goto 9999 + end If + tot_recv=tot_recv+n_elem_recv + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': tot_recv:',proc,n_elem_recv,tot_recv + ! + ! + ! The format of the halo vector exists in two forms: 1. Temporary + ! 2. Assembled. In this loop we are using the (assembled) halo_in and + ! copying it into (temporary) halo_out; this is because tmp_halo will + ! be enlarged with the new column indices received, and will reassemble + ! everything for the next iteration. + ! + ! + ! add recv elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If + + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 + + counter_h=counter_h+3 + + Enddo + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv + + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 + + idx = halo(counter+psb_elem_send_+j) + gidx = desc_ov%loc_to_glob(idx) + if (idx > psb_cd_get_local_rows(Desc_a)) & + & write(debug_unit,*) me,' ',trim(name),':Out of local rows ',i_ovr,& + & idx,psb_cd_get_local_rows(Desc_a) + + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr <= (novr)) Then + n_elem = psb_sp_get_nnz_row(idx,a) + call psb_ensure_size((idxs+tot_elem+n_elem),works,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + + call psb_sp_getblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + + if (i_ovr <= novr) then + if (tot_elem > 1) then + call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) + tot_elem=i + endif + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if + counter = counter+n_elem_send+3 + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop End',tmp_ovr_idx(1:10) + Enddo + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':End phase 1', m, n_col, tot_recv + + if (i_ovr <= novr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if + + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr + + if (psb_is_large_desc(desc_ov)) then + call psb_ensure_size(iszr,maskr,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) + end if + end do + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col=psb_cd_get_local_cols(desc_ov) + + do i=1,iszs + idx = works(i) + n_col = psb_cd_get_local_cols(desc_ov) + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Added into t_halo_in from recv',& + &proc_id,n_col,idx + else if (desc_ov%glob_to_loc(idx) < 0) Then + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Wrong input to cdbldextbld?',& + &idx,desc_ov%glob_to_loc(idx) + End If + End Do + desc_ov%matrix_data(psb_n_col_)=n_col + + end if + + end if + ! + ! Ok, now we have a temporary halo with all the info for the + ! next round. If we need to keep going, convert the halo format + ! from temporary to final, so that we can work out the next iteration. + ! This uses one of the convert_comm internals, i.e. we are doing + ! the equivalent of a partial call to convert_comm + ! + t_halo_in(counter_t)=-1 + + If (i_ovr < (novr)) Then + + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) + write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' + end if + + call psi_crea_index(desc_ov,t_halo_in,t_halo_out,.false.,& + & nxch,nsnd,nrcv,info) + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' + call psb_barrier(ictxt) + end if + call psb_transfer(t_halo_out,halo,info) + ! + ! At this point we have built the halo necessary for I_OVR+1. + ! + End If + End Do + + + select case(extype_) + case(psb_ovt_xhal_) + ! + ! Build an extended-stencil halo, but no overlap enlargement. + ! Here we need: 1. orig_ovr -> ovrlap + ! 2. (tmp_halo + t_halo_in) -> halo + ! 3. (t_ovr_idx) -> /dev/null + ! 4. n_row(ov) = n_row(a) + ! 5. n_col(ov) current. + ! + desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) + call psb_transfer(orig_ovr,desc_ov%ovrlap_index,info) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_ensure_size') + goto 9999 + end if + tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) + counter_h = counter_h+counter_t-1 + tmp_halo(counter_h:) = -1 + call psb_transfer(tmp_halo,desc_ov%halo_index,info) + deallocate(tmp_ovr_idx,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='deallocate') + goto 9999 + end if + + case(psb_ovt_asov_) + ! + ! Build an overlapped descriptor for Additive Schwarz + ! with overlap enlargement; we need the overlap, + ! the (new) halo and the mapping into the new index space. + ! Here we need: 1. (orig_ovr + t_ovr_idx) -> ovrlap + ! 2. (tmp_halo) -> ext + ! 3. (t_halo_in) -> halo + ! 4. n_row(ov) current. + ! 5. n_col(ov) current. + ! + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_ensure_size') + goto 9999 + end if + orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) + cntov_o = cntov_o+counter_o-1 + orig_ovr(cntov_o:) = -1 + call psb_transfer(orig_ovr,desc_ov%ovrlap_index,info) + deallocate(tmp_ovr_idx,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='deallocate') + goto 9999 + end if + tmp_halo(counter_h:) = -1 + call psb_transfer(tmp_halo,desc_ov%ext_index,info) + call psb_transfer(t_halo_in,desc_ov%halo_index,info) + + case default + call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + + ! + ! At this point we have gathered all the indices in the halo at + ! N levels of overlap. Just call icdasb forcing to use + ! the halo_index provided. This is the same routine as gets + ! called inside CDASB. + ! + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),': converting indexes' + call psb_barrier(ictxt) + end if + + call psb_icdasb(desc_ov,info,ext_hv=.true.) + + call psb_cd_set_ovl_asb(desc_ov,info) + + if (info == 0) call psb_sp_free(blk,info) + if (info /= 0) then + ch_err='sp_free' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_ccdbldext + diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 new file mode 100644 index 000000000..96b1d6c5f --- /dev/null +++ b/base/tools/psb_cfree.f90 @@ -0,0 +1,181 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cfree.f90 +! +! Subroutine: psb_cfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfree(x, desc_a, info) + !...free dense matrix structure... + use psb_const_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + + !...locals.... + integer :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name='psb_cfree' + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + end if + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + + 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_cfree + + + +! Subroutine: psb_cfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfreev(x, desc_a, info) + !...free dense matrix structure... + use psb_const_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + + implicit none + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + + !...locals.... + integer :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name='psb_cfreev' + + + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=4000 + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cfreev diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 new file mode 100644 index 000000000..8f2447cdf --- /dev/null +++ b/base/tools/psb_cins.f90 @@ -0,0 +1,381 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_cinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - complex The source dense submatrix. +! x(:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) + !....insert dense submatrix to dense matrix ..... + use psb_descriptor_type + use psb_spmat_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer, intent(in) :: m + integer, intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + + !locals..... + integer :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer :: np, me, dupl_ + integer, allocatable :: irl(:) + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_cinsvi' + + if ((.not.allocated(desc_a%matrix_data))) then + int_err(1)=3110 + call psb_errpush(info,name) + return + end if + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < psb_cd_get_local_rows(desc_a)) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m==0) return + loc_rows = psb_cd_get_local_rows(desc_a) + loc_cols = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + allocate(irl(m),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cinsvi + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_cinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - complex The source dense submatrix. +! x(:,:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) + !....insert dense submatrix to dense matrix ..... + use psb_descriptor_type + use psb_spmat_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer, intent(in) :: m + integer, intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + complex(psb_spk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + + !locals..... + integer :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer :: np,me,dupl_ + integer, allocatable :: irl(:) + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_cinsi' + + if ((.not.allocated(desc_a%matrix_data))) then + int_err(1)=3110 + call psb_errpush(info,name) + return + end if + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < psb_cd_get_local_rows(desc_a)) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m==0) return + + loc_rows = psb_cd_get_local_rows(desc_a) + loc_cols = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cinsi + + diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 new file mode 100644 index 000000000..c829a7f1f --- /dev/null +++ b/base/tools/psb_cspalloc.f90 @@ -0,0 +1,138 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspalloc.f90 +! +! Subroutine: psb_cspalloc +! Allocate sparse matrix structure for psblas routines. +! +! Arguments: +! a - type(psb_cspmat_type). The sparse matrix to be allocated. +! desc_a - type(psb_desc_type). The communication descriptor to be updated. +! info - integer. Return code. +! nnz - integer(optional). The number of nonzeroes in the matrix. +! (local, user estimate) +! +subroutine psb_cspalloc(a, desc_a, info, nnz) + + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(inout) :: desc_a + type(psb_cspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + + !locals + integer :: ictxt, dectype + integer :: np,me,loc_row,loc_col,& + & length_ia1,length_ia2, err_act,m,n + integer :: int_err(5) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_cspall' + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + dectype = psb_cd_get_dectype(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + loc_row = psb_cd_get_local_rows(desc_a) + loc_col = psb_cd_get_local_cols(desc_a) + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + !...allocate matrix data... + if (present(nnz))then + if (nnz < 0) then + info=45 + int_err(1)=7 + int_err(2)=nnz + call psb_errpush(info,name,int_err) + goto 9999 + endif + length_ia1=nnz + length_ia2=nnz + else + length_ia1=max(1,5*loc_row) + endif + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + + !....allocate aspk, ia1, ia2..... + call psb_sp_all(loc_row,loc_col,a,length_ia1,info) + if(info /= 0) then + info=4010 + ch_err='sp_all' + call psb_errpush(info,name,int_err) + goto 9999 + end if + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ', & + & psb_cd_get_dectype(desc_a),psb_desc_bld_ + + return + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cspalloc diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 new file mode 100644 index 000000000..e22e53b2d --- /dev/null +++ b/base/tools/psb_cspasb.f90 @@ -0,0 +1,145 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspasb.f90 +! +! Subroutine: psb_cspasb +! Assemble sparse matrix +! +! Arguments: +! a - type(psb_cspmat_type). The sparse matrix to be assembled +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! afmt - character(optional) The desired output storage format. +! upd - character(optional). How will the matrix be updated? +! psb_upd_srch_ Simple strategy +! psb_upd_perm_ Permutation(more memory) +! dupl - integer(optional). Duplicate coefficient handling: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +! psb_dupl_err_ raise an error. +! +! +subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl) + + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + + !...Parameters.... + type(psb_cspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + !....Locals.... + integer :: int_err(5) + integer :: np,me,n_col, err_act + integer :: spstate + integer :: ictxt,n_row + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + info = 0 + int_err(1)=0 + name = 'psb_spasb' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(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_asb_desc(desc_a)) then + info = 600 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name) + goto 9999 + endif + + if (debug_level >= psb_debug_ext_)& + & write(debug_unit, *) me,' ',trim(name),& + & ' Begin matrix assembly...' + + !check on errors encountered in psdspins + + spstate = a%infoa(psb_state_) + if (spstate == psb_spmat_bld_) then + ! + ! 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) + a%m = n_row + a%k = n_col + end if + + call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl) + + IF (debug_level >= psb_debug_ext_)& + & write(debug_unit, *) me,' ',trim(name),': From SPCNV',& + & 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 + endif + + 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_cspasb diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 new file mode 100644 index 000000000..1214046f0 --- /dev/null +++ b/base/tools/psb_cspfree.f90 @@ -0,0 +1,96 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspfree.f90 +! +! Subroutine: psb_cspfree +! Frees a sparse matrix structure. +! +! Arguments: +! a - type(psb_cspmat_type). The sparse matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! +subroutine psb_cspfree(a, desc_a,info) + !...free sparse matrix structure... + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + !...locals.... + integer :: ictxt, err_act + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + name = 'psb_cspfree' + call psb_erractionsave(err_act) + + if (.not.allocated(desc_a%matrix_data)) then + info = 295 + call psb_errpush(info,name) + return + else + ictxt = psb_cd_get_context(desc_a) + end if + + !...deallocate a.... + call psb_sp_free(a,info) + + + if(info /= 0) then + info=2045 + call psb_errpush(info,name) + goto 9999 + end if + + 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_cspfree + + + diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 new file mode 100644 index 000000000..884cc9647 --- /dev/null +++ b/base/tools/psb_csphalo.F90 @@ -0,0 +1,394 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_csphalo.f90 +! +! Subroutine: psb_csphalo +! This routine does the retrieval of remote matrix rows. +! Note that retrieval is done through GTBLK, therefore it should work +! for any matrix format in A; as for the output, default is CSR. +! +! +! Arguments: +! a - type(psb_cspmat_type) The local part of input matrix A +! desc_a - type(psb_desc_type). The communication descriptor. +! blck - type(psb_cspmat_type) The local part of output matrix BLCK +! info - integer. Return code +! rowcnv - logical Should row/col indices be converted +! colcnv - logical to/from global numbering when sent/received? +! default is .TRUE. +! rowscale - logical Should row/col indices on output be remapped +! colscale - logical from MIN:MAX to 1:(MAX-MIN+1) ? +! default is .FALSE. +! (commmon use is ROWSCALE=.TRUE., COLSCALE=.FALSE.) +! data - integer Which index list in desc_a should be used to retrieve +! rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ DISABLED for this routine. +! +Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + + use psb_const_mod + use psb_serial_mod + use psb_descriptor_type + use psb_realloc_mod + use psb_tools_mod, psb_protect_name => psb_csphalo + use psb_error_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_cspmat_type),Intent(in) :: a + Type(psb_cspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer, intent(in), optional :: data + ! ...local scalars.... + Integer :: np,me,counter,proc,i, & + & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& + & irmin,icmin,irmax,icmax,data_,ngtz + Integer :: l1, icomm, err_act + Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), & + & rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:) + complex(psb_spk_), allocatable :: valsnd(:) + integer, pointer :: idxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_csphalo' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + Call psb_info(ictxt, me, np) + + Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + + if (info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) + case(psb_comm_halo_) + idxv => desc_a%halo_index + + case(psb_comm_ext_) + idxv => desc_a%ext_index + +! !$ case(psb_comm_ovr_) +! !$ idxv => desc_a%ovrlap_index +! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(4010,name,a_err='wrong Data selector') + goto 9999 + end select + + + l1 = 0 + + sdsz(:)=0 + rvsz(:)=0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + blk%k = a%k + blk%m = 0 + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv = idxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = idxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = idxv(counter+psb_elem_send_+j) + n_elem = psb_sp_get_nnz_row(idx,a) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + + blk%m = blk%m + n_el_recv + + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv = idxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = idxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call psb_sp_all(blk,max(iszr,1),info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',size(blk%ia1),size(blk%ia2),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + mat_recv = iszr + iszs=sum(sdsz) + call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv=idxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=idxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = idxv(counter+psb_elem_send_+j) + n_elem = psb_sp_get_nnz_row(idx,a) + + call psb_sp_getrow(idx,a,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + + ipx = ipx + 1 + + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= 0) then + info=4010 + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_complex,& + & blk%aspk,rvsz,brvindx,mpi_complex,icomm,info) + call mpi_alltoallv(iasnd,sdsz,bsdindx,mpi_integer,& + & blk%ia1,rvsz,brvindx,mpi_integer,icomm,info) + call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& + & blk%ia2,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I') + + if (info /= 0) then + info=4010 + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + blk%m=0 + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(blk%ia1(i)) + k=(blk%ia2(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + blk%aspk(l1) = blk%aspk(i) + blk%ia1(l1) = r + blk%ia2(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + blk%m = max(irmax-irmin+1,0) + blk%ia1(1:l1) = blk%ia1(1:l1) - irmin + 1 + else + blk%m = irmax + end if + if (colscale_) then + blk%k = max(icmax-icmin+1,0) + blk%ia2(1:l1) = blk%ia2(1:l1) - icmin + 1 + else + blk%k = icmax + end if + + blk%fida = 'COO' + blk%infoa(psb_nnz_) = l1 + call psb_ensure_size(1,blk%pl,info) + if (info == 0) call psb_ensure_size(1,blk%pr,info) + if (info /= 0) then + info=4010 + ch_err='psb_ensure_size' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blk%pl = 0 + blk%pr = 0 + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1,blk%m + + ! Do we expect any duplicates to appear???? + call psb_spcnv(blk,info,afmt=outfmt_,dupl=psb_dupl_add_) + if (info /= 0) then + info=4010 + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(sdid,brvindx,rvid,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + 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_csphalo diff --git a/base/tools/psb_cspins.f90 b/base/tools/psb_cspins.f90 new file mode 100644 index 000000000..51689e616 --- /dev/null +++ b/base/tools/psb_cspins.f90 @@ -0,0 +1,403 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cspins.f90 +! +! Subroutine: psb_cspins +! Takes a cloud of coefficients and inserts them into a sparse matrix. +! Note: coefficients with a row index not belonging to the current process are +! ignored. +! If desc_a is in the build state this routine implies a call to psb_cdins. +! +! Arguments: +! nz - integer. The number of points to insert. +! ia(:) - integer The row indices of the coefficients. +! ja(:) - integer The column indices of the coefficients. +! val(:) - complex The values of the coefficients to be inserted. +! a - type(psb_dspmat_type). The sparse destination matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code +! rebuild - logical Allows to reopen a matrix under +! certain circumstances. +! +subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) + + use psb_tools_mod, psb_protect_name => psb_cspins + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(inout) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + !locals..... + + integer :: nrow, err_act,mglob,ncol, spstate + integer :: ictxt,np,me + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + logical :: rebuild_ + integer, allocatable :: ila(:),jla(:) + + character(len=20) :: name, ch_err + + info = 0 + name = 'psb_cspins' + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(ia) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(val) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz==0) return + + if (present(rebuild)) then + rebuild_ = rebuild + else + rebuild_ = .false. + endif + + spstate = a%infoa(psb_state_) + if (psb_is_bld_desc(desc_a)) then + if (psb_is_large_desc(desc_a)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + + else + + call psb_cdins(nz,ia,ja,desc_a,info) + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + + end if + + else if (psb_is_asb_desc(desc_a)) then + + if (psb_is_large_desc(desc_a)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) + call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') + call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& + & info,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& + & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + info = 1122 + call psb_errpush(info,name) + goto 9999 + end if + + 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_cspins + + +subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_tools_mod, psb_protect_name => psb_cspins_2desc + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + !locals..... + + integer :: nrow, err_act, ncol, spstate + integer :: ictxt,np,me + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + integer, allocatable :: ila(:),jla(:) + character(len=20) :: name, ch_err + + info = 0 + name = 'psb_cspins' + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_ar) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc_ar)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + if (.not.psb_is_ok_desc(desc_ac)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(ia) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(val) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz==0) return + + spstate = a%infoa(psb_state_) + if (psb_is_bld_desc(desc_ac)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + ila(1:nz) = ia(1:nz) + + call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.) + + call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) + + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + nrow = psb_cd_get_local_rows(desc_ar) + ncol = psb_cd_get_local_cols(desc_ac) + + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (psb_is_asb_desc(desc_ac)) then + + write(0,*) 'Why are you calling me on an assembled desc_ac?' +!!$ if (psb_is_large_desc(desc_a)) then +!!$ +!!$ allocate(ila(nz),jla(nz),stat=info) +!!$ if (info /= 0) then +!!$ ch_err='allocate' +!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ goto 9999 +!!$ end if +!!$ +!!$ ila(1:nz) = ia(1:nz) +!!$ jla(1:nz) = ja(1:nz) +!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') +!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ +!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& +!!$ & info,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ +!!$ else +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& +!!$ & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ end if + else + info = 1122 + call psb_errpush(info,name) + goto 9999 + end if + + 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_cspins_2desc + diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 new file mode 100644 index 000000000..b671dba15 --- /dev/null +++ b/base/tools/psb_csprn.f90 @@ -0,0 +1,113 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_csprn.f90 +! +! Subroutine: psb_csprn +! Reinit sparse matrix structure for psblas routines: on output the matrix +! is in the update state. +! +! Arguments: +! a - type(psb_cspmat_type). The sparse matrix to be reinitiated. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! clear - logical, optional Whether the coefficients should be zeroed +! default .true. +! +Subroutine psb_csprn(a, desc_a,info,clear) + + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + Implicit None + + !....Parameters... + Type(psb_desc_type), intent(in) :: desc_a + Type(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + + !locals + Integer :: ictxt,np,me,err,err_act + integer :: debug_level, debug_unit + integer :: int_err(5) + character(len=20) :: name + logical :: clear_ + + info = 0 + err = 0 + int_err(1)=0 + name = 'psb_csprn' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': start ' + + if (psb_is_bld_desc(desc_a)) then + ! Should do nothing, we are called redundantly + return + endif + if (.not.psb_is_asb_desc(desc_a)) then + info=590 + call psb_errpush(info,name) + goto 9999 + endif + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + call psb_sp_reinit(a,info,clear=clear_) + + if (info /= 0) goto 9999 + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': done' + + 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_csprn diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index 21f270282..d7df6309c 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -254,7 +254,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(inout) :: desc_ac type(psb_dspmat_type), intent(inout) :: a integer, intent(in) :: nz,ia(:),ja(:) - real(kind(1.d0)), intent(in) :: val(:) + real(kind=psb_dpk_), intent(in) :: val(:) integer, intent(out) :: info !locals..... diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 new file mode 100644 index 000000000..33e7862a4 --- /dev/null +++ b/base/tools/psb_sallc.f90 @@ -0,0 +1,265 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sallc.f90 +! +! Function: psb_salloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_salloc(x, desc_a, info, n, lb) + !....allocate dense matrix for psblas routines..... + use psb_descriptor_type + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n, lb + + !locals + integer :: np,me,err,nr,i,j,err_act + integer :: ictxt,n_ + integer :: int_err(5), exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + int_err(1)=0 + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=550 + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,psb_cd_get_local_cols(desc_a)) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,psb_cd_get_local_rows(desc_a)) + else + info = 4001 + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= 0) then + info=4025 + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + x(:,:) = dzero + + 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_salloc + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +! +! +! Function: psb_sallocv +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_sallocv(x, desc_a,info,n) + !....allocate sparse matrix structure for psblas routines..... + use psb_descriptor_type + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_penv_mod + + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n + + !locals + integer :: np,me,nr,i,err_act + integer :: ictxt, int_err(5) + integer :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,psb_cd_get_local_cols(desc_a)) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,psb_cd_get_local_rows(desc_a)) + else + info = 4001 + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= 0) then + info=4025 + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + x(:) = dzero + + 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_sallocv + diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 new file mode 100644 index 000000000..582591f83 --- /dev/null +++ b/base/tools/psb_sasb.f90 @@ -0,0 +1,264 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sasb.f90 +! +! Subroutine: psb_sasb +! Assembles a dense matrix for PSBLAS routines. +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - real,allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_sasb(x, desc_a, info) + !....assembly dense matrix x ..... + use psb_descriptor_type + use psb_const_mod + use psb_comm_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer, intent(out) :: info + + ! local variables + integer :: ictxt,np,me,nrow,ncol, err_act + integer :: i1sz, i2sz + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_sgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if ((.not.allocated(desc_a%matrix_data))) then + info=3110 + call psb_errpush(info,name) + goto 9999 + endif + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & psb_cd_get_dectype(desc_a) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ',& + & psb_cd_get_dectype(desc_a) + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = psb_cd_get_context(desc_a) + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= 0) then + info=4010 + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_sasb + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - real,allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sasbv(x, desc_a, info) + !....assembly dense matrix x ..... + use psb_descriptor_type + use psb_const_mod + use psb_comm_mod + use psb_error_mod + use psb_realloc_mod + use psb_penv_mod + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer, intent(out) :: info + + ! local variables + integer :: ictxt,np,me + integer :: int_err(5), i1sz,nrow,ncol, err_act + integer :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = 0 + int_err(1) = 0 + name = 'psb_sgeasb_v' + + ictxt = psb_cd_get_context(desc_a) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= 0) then + info=4010 + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_sasbv + diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 new file mode 100644 index 000000000..035072af3 --- /dev/null +++ b/base/tools/psb_scdbldext.F90 @@ -0,0 +1,768 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_cdbldext.f90 +! +! Subroutine: psb_cdbldext +! This routine takes a matrix A with its descriptor, and builds the +! auxiliary descriptor corresponding to the number of overlap levels +! specified on input. +! +! Arguments: +! a - type(psb_sspmat_type). The input sparse matrix. +! desc_a - type(psb_desc_type). The input communication descriptor. +! novr - integer. The number of overlap levels. +! desc_ov - type(psb_desc_type). The auxiliary output communication +! descriptor. +! info - integer. Return code. +! extype - integer. Choice of type of overlap: +! psb_ovt_xhal_: build a descriptor with an extended +! stencil, i.e. enlarge the existing +! halo by novr additional layers. +! psb_ovt_asov_: build a descriptor suitable +! for Additive Schwarz preconditioner. +! This last choice implies that: +! a. The novr halo layers are added to +! the overlap; +! b. The novr layers are also copied to +! the ext_ structure to provide +! the mapping between the base +! descriptor and the overlapped one. +! c. The (novr+1)-th layer becomes the +! new halo. +! +Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) + + use psb_tools_mod, psb_protect_name => psb_scdbldext + + use psb_serial_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psi_mod +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + ! .. Array Arguments .. + integer, intent(in) :: novr + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in), target :: desc_a + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + + interface + subroutine psb_icdasb(desc_a,info,ext_hv) + use psb_descriptor_type + Type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + logical, intent(in),optional :: ext_hv + end subroutine psb_icdasb + end interface + integer icomm, err_act + + ! .. Local Scalars .. + Integer :: i, j, np, me,m,nnzero,& + & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo + Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& + & n_elem_send,tot_recv,tot_elem,cntov_o,& + & counter_t,n_elem,i_ovr,jj,proc_id,isz, & + & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ + + type(psb_sspmat_type) :: blk + Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) + Integer,allocatable :: halo(:),works(:),workr(:),t_halo_in(:),& + & t_halo_out(:),temp(:),maskr(:) + Integer,allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_scdbldext' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + Call psb_info(ictxt, me, np) + + If (debug_level >= psb_debug_outer_) & + & Write(debug_unit,*) me,' ',trim(name),': start',novr + + if (present(extype)) then + extype_ = extype + else + extype_ = psb_ovt_xhal_ + endif + m = psb_cd_get_local_rows(desc_a) + nnzero = Size(a%aspk) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-m + + if (novr<0) then + info=10 + int_err(1)=1 + int_err(2)=novr + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Calling desccpy' + call psb_cdcpy(desc_a,desc_ov,info) + if (info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':From desccpy' + if (novr==0) then + ! + ! Just copy the input. + ! + return + endif + + + + If (debug_level >= psb_debug_outer_)then + Write(debug_unit,*) me,' ',trim(name),':BEGIN ',nhalo + call psb_barrier(ictxt) + endif + + ! + ! Ok, since we are only estimating, do it as follows: + ! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average + ! nonzeros per row is the same as the global. + ! + nztot = psb_sp_get_nnzeros(a) + if (nztot>0) then + lovr = ((nztot+m-1)/m)*nhalo*novr + lworks = ((nztot+m-1)/m)*nhalo + lworkr = ((nztot+m-1)/m)*nhalo + else + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + If (debug_level >= psb_debug_outer_)& + & Write(debug_unit,*) me,' ',trim(name),':ovr_est done',novr,lovr + + index_dim = size(desc_a%halo_index) + elem_dim = size(desc_a%halo_index) + + l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) + l_tmp_halo = novr*(3*Size(desc_a%halo_index)) + + call psb_cd_set_ovl_bld(desc_ov,info) + desc_ov%base_desc => desc_a + + If (debug_level >= psb_debug_outer_) then + Write(debug_unit,*) me,' ',trim(name),':Start',lworks,lworkr + call psb_barrier(ictxt) + endif + + + Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& + & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_sp_all(blk,max(lworks,lworkr),info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blk%fida='COO' + + Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& + & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + halo(:) = desc_a%halo_index(:) + tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 + tmp_halo(:) = -1 + counter_e = 1 + tot_recv = 0 + counter_t = 1 + counter_h = 1 + counter_o = 1 + cntov_o = 1 + ! Init overlap with desc_a%ovrlap (if any) + counter = 1 + Do While (desc_a%ovrlap_index(counter) /= -1) + proc = desc_a%ovrlap_index(counter+psb_proc_id_) + n_elem_recv = desc_a%ovrlap_index(counter+psb_n_elem_recv_) + n_elem_send = desc_a%ovrlap_index(counter+n_elem_recv+psb_n_elem_send_) + + Do j=0,n_elem_recv-1 + + idx = desc_a%ovrlap_index(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + orig_ovr(cntov_o)=proc + orig_ovr(cntov_o+1)=1 + orig_ovr(cntov_o+2)=gidx + orig_ovr(cntov_o+3)=-1 + cntov_o=cntov_o+3 + end Do + counter=counter+n_elem_recv+n_elem_send+3 + end Do + + + + + ! + ! A picture is in order to understand what goes on here. + ! I is the internal part; H is halo, R row, C column. The final + ! matrix with N levels of overlap looks like this + ! + ! I | Hc1 | 0 | 0 | + ! -------|-----|-----|-----| + ! Hr1 | Hd1 | Hc2 | 0 | + ! -------|-----|-----|-----| + ! 0 | Hr2 | Hd2 | Hc2 | + ! -------|-----|-----|-----| + ! 0 | 0 | Hr3 | Hd3 | Hc3 + ! + ! At the start we already have I and Hc1, so we know the row + ! indices that will make up Hr1, and also who owns them. As we + ! actually get those rows, we receive the column indices in Hc2; + ! these define the row indices for Hr2, and so on. When we have + ! reached the desired level HrN. + ! + ! + Do i_ovr = 1, novr + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Running on overlap level ',i_ovr,' of ',novr + + ! + ! At this point, halo contains a valid halo corresponding to the + ! matrix enlarged with the elements in the frontier for I_OVR-1. + ! At the start, this is just the halo for A; the rows for indices in + ! the first halo will contain column indices defining the second halo + ! level and so on. + ! + bsdindx(:) = 0 + sdsz(:) = 0 + brvindx(:) = 0 + rvsz(:) = 0 + idxr = 0 + idxs = 0 + counter = 1 + counter_t = 1 + + desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + + Do While (halo(counter) /= -1) + tot_elem=0 + proc=halo(counter+psb_proc_id_) + n_elem_recv=halo(counter+psb_n_elem_recv_) + n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then + info = -1 + call psb_errpush(info,name) + goto 9999 + end If + tot_recv=tot_recv+n_elem_recv + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': tot_recv:',proc,n_elem_recv,tot_recv + ! + ! + ! The format of the halo vector exists in two forms: 1. Temporary + ! 2. Assembled. In this loop we are using the (assembled) halo_in and + ! copying it into (temporary) halo_out; this is because tmp_halo will + ! be enlarged with the new column indices received, and will reassemble + ! everything for the next iteration. + ! + ! + ! add recv elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_recv-1 + If((counter+psb_elem_recv_+j)>Size(halo)) then + info=-2 + call psb_errpush(info,name) + goto 9999 + end If + + idx = halo(counter+psb_elem_recv_+j) + If(idx > Size(desc_ov%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + + gidx = desc_ov%loc_to_glob(idx) + + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_halo(counter_h)=proc + tmp_halo(counter_h+1)=1 + tmp_halo(counter_h+2)=idx + tmp_halo(counter_h+3)=-1 + + counter_h=counter_h+3 + + Enddo + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) + counter = counter+n_elem_recv + + ! + ! add send elements in halo_index into ovrlap_index + ! + Do j=0,n_elem_send-1 + + idx = halo(counter+psb_elem_send_+j) + gidx = desc_ov%loc_to_glob(idx) + if (idx > psb_cd_get_local_rows(Desc_a)) & + & write(debug_unit,*) me,' ',trim(name),':Out of local rows ',i_ovr,& + & idx,psb_cd_get_local_rows(Desc_a) + + call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + tmp_ovr_idx(counter_o)=proc + tmp_ovr_idx(counter_o+1)=1 + tmp_ovr_idx(counter_o+2)=gidx + tmp_ovr_idx(counter_o+3)=-1 + counter_o=counter_o+3 + + ! + ! Prepare to exchange the halo rows with the other proc. + ! + If (i_ovr <= (novr)) Then + n_elem = psb_sp_get_nnz_row(idx,a) + call psb_ensure_size((idxs+tot_elem+n_elem),works,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + + If((n_elem) > size(blk%ia2)) Then + isz = max((3*size(blk%ia2))/2,(n_elem)) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,'Realloc blk',isz + call psb_sp_reall(blk,isz,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + End If + + call psb_sp_getblk(idx,a,blk,info) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Do jj=1,n_elem + works(idxs+tot_elem+jj)=desc_ov%loc_to_glob(blk%ia2(jj)) + End Do + tot_elem=tot_elem+n_elem + End If + + Enddo + + + if (i_ovr <= novr) then + if (tot_elem > 1) then + call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) + tot_elem=i + endif + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop Mid2',tmp_ovr_idx(1:10) + sdsz(proc+1) = tot_elem + idxs = idxs + tot_elem + end if + counter = counter+n_elem_send+3 + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':Checktmp_o_i Loop End',tmp_ovr_idx(1:10) + Enddo + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ':End phase 1', m, n_col, tot_recv + + if (i_ovr <= novr) then + ! + ! Exchange data requests with everybody else: so far we have + ! accumulated RECV requests, we have an all-to-all to build + ! matchings SENDs. + ! + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=halo(counter) + if (proc == -1) exit + n_elem_recv = halo(counter+psb_n_elem_recv_) + counter = counter+n_elem_recv + n_elem_send = halo(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_elem_send+3 + Enddo + + iszr=sum(rvsz) + if (max(iszr,1) > lworkr) then + call psb_realloc(max(iszr,1),workr,info) + if (info /= 0) then + info=4010 + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + lworkr=max(iszr,1) + end if + + call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& + & workr,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': ISZR :',iszr + + if (psb_is_large_desc(desc_ov)) then + call psb_ensure_size(iszr,maskr,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + call psi_idx_cnv(iszr,workr,maskr,desc_ov,info) + iszs = count(maskr(1:iszr)<=0) + if (iszs > size(works)) call psb_realloc(iszs,works,info) + j = 0 + do i=1,iszr + if (maskr(i) < 0) then + j=j+1 + works(j) = workr(i) + end if + end do + ! + ! fnd_owner on desc_a because we want the procs who + ! owned the rows from the beginning! + ! + call psi_fnd_owner(iszs,works,temp,desc_a,info) + n_col = psb_cd_get_local_cols(desc_ov) + + do i=1,iszs + idx = works(i) + n_col = psb_cd_get_local_cols(desc_ov) + call psi_idx_ins_cnv(idx,lidx,desc_ov,info) + if (psb_cd_get_local_cols(desc_ov) > n_col ) then + ! + ! This is a new index. Assigning a local index as + ! we receive them guarantees that all indices for HALO(I) + ! will be less than those for HALO(J) whenever I= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Added into t_halo_in from recv',& + &proc_id,n_col,idx + else if (desc_ov%glob_to_loc(idx) < 0) Then + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),':Wrong input to cdbldextbld?',& + &idx,desc_ov%glob_to_loc(idx) + End If + End Do + desc_ov%matrix_data(psb_n_col_)=n_col + + end if + + end if + ! + ! Ok, now we have a temporary halo with all the info for the + ! next round. If we need to keep going, convert the halo format + ! from temporary to final, so that we can work out the next iteration. + ! This uses one of the convert_comm internals, i.e. we are doing + ! the equivalent of a partial call to convert_comm + ! + t_halo_in(counter_t)=-1 + + If (i_ovr < (novr)) Then + + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),':Checktmp_o_i 1',tmp_ovr_idx(1:10) + write(debug_unit,*) me,' ',trim(name),':Calling Crea_index' + end if + + call psi_crea_index(desc_ov,t_halo_in,t_halo_out,.false.,& + & nxch,nsnd,nrcv,info) + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' + call psb_barrier(ictxt) + end if + call psb_transfer(t_halo_out,halo,info) + ! + ! At this point we have built the halo necessary for I_OVR+1. + ! + End If + End Do + + + select case(extype_) + case(psb_ovt_xhal_) + ! + ! Build an extended-stencil halo, but no overlap enlargement. + ! Here we need: 1. orig_ovr -> ovrlap + ! 2. (tmp_halo + t_halo_in) -> halo + ! 3. (t_ovr_idx) -> /dev/null + ! 4. n_row(ov) = n_row(a) + ! 5. n_col(ov) current. + ! + desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) + call psb_transfer(orig_ovr,desc_ov%ovrlap_index,info) + call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_ensure_size') + goto 9999 + end if + tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) + counter_h = counter_h+counter_t-1 + tmp_halo(counter_h:) = -1 + call psb_transfer(tmp_halo,desc_ov%halo_index,info) + deallocate(tmp_ovr_idx,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='deallocate') + goto 9999 + end if + + case(psb_ovt_asov_) + ! + ! Build an overlapped descriptor for Additive Schwarz + ! with overlap enlargement; we need the overlap, + ! the (new) halo and the mapping into the new index space. + ! Here we need: 1. (orig_ovr + t_ovr_idx) -> ovrlap + ! 2. (tmp_halo) -> ext + ! 3. (t_halo_in) -> halo + ! 4. n_row(ov) current. + ! 5. n_col(ov) current. + ! + call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_ensure_size') + goto 9999 + end if + orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) + cntov_o = cntov_o+counter_o-1 + orig_ovr(cntov_o:) = -1 + call psb_transfer(orig_ovr,desc_ov%ovrlap_index,info) + deallocate(tmp_ovr_idx,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='deallocate') + goto 9999 + end if + tmp_halo(counter_h:) = -1 + call psb_transfer(tmp_halo,desc_ov%ext_index,info) + call psb_transfer(t_halo_in,desc_ov%halo_index,info) + + case default + call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + goto 9999 + end select + + ! + ! At this point we have gathered all the indices in the halo at + ! N levels of overlap. Just call icdasb forcing to use + ! the halo_index provided. This is the same routine as gets + ! called inside CDASB. + ! + + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),': converting indexes' + call psb_barrier(ictxt) + end if + + call psb_icdasb(desc_ov,info,ext_hv=.true.) + + call psb_cd_set_ovl_asb(desc_ov,info) + + if (info == 0) call psb_sp_free(blk,info) + if (info /= 0) then + ch_err='sp_free' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + 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_scdbldext + diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 new file mode 100644 index 000000000..d3ad80a64 --- /dev/null +++ b/base/tools/psb_sfree.f90 @@ -0,0 +1,176 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sfree.f90 +! +! Subroutine: psb_sfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfree(x, desc_a, info) + !...free dense matrix structure... + use psb_const_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + + !...locals.... + integer :: ictxt,np,me,err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name='psb_sfree' + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + + 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_sfree + + + +! Subroutine: psb_sfreev +! frees a dense matrix structure +! +! Arguments: +! x():) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfreev(x, desc_a, info) + !...free dense matrix structure... + use psb_const_mod + use psb_descriptor_type + use psb_error_mod + use psb_penv_mod + + implicit none + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + !...locals.... + integer :: ictxt,np,me,err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name='psb_sfreev' + + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + end if + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=295 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=4000 + call psb_errpush(info,name) + endif + + 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_sfreev diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 new file mode 100644 index 000000000..5b7c354a1 --- /dev/null +++ b/base/tools/psb_sins.f90 @@ -0,0 +1,381 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - real The source dense submatrix. +! x(:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl) + !....insert dense submatrix to dense matrix ..... + use psb_const_mod + use psb_descriptor_type + use psb_spmat_type + use psb_error_mod + use psb_penv_mod + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer, intent(in) :: m + integer, intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + + !locals..... + integer :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer :: np, me, dupl_ + integer, allocatable :: irl(:) + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_sinsvi' + + if ((.not.allocated(desc_a%matrix_data))) then + int_err(1)=3110 + call psb_errpush(info,name) + return + end if + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < psb_cd_get_local_rows(desc_a)) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m==0) return + loc_rows = psb_cd_get_local_rows(desc_a) + loc_cols = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + + allocate(irl(m),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_sinsvi + + +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - real The source dense submatrix. +! x(:,:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) + !....insert dense submatrix to dense matrix ..... + use psb_descriptor_type + use psb_spmat_type + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer, intent(in) :: m + integer, intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + real(psb_spk_), intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + + !locals..... + integer :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer :: np,me,dupl_ + integer, allocatable :: irl(:) + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_sinsi' + + if ((.not.allocated(desc_a%matrix_data))) then + int_err(1)=3110 + call psb_errpush(info,name) + return + end if + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < psb_cd_get_local_rows(desc_a)) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m==0) return + + loc_rows = psb_cd_get_local_rows(desc_a) + loc_cols = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + endif + + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_sinsi + + diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 new file mode 100644 index 000000000..99be7bd0e --- /dev/null +++ b/base/tools/psb_sspalloc.f90 @@ -0,0 +1,138 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspalloc.f90 +! +! Subroutine: psb_sspalloc +! Allocate sparse matrix structure for psblas routines. +! +! Arguments: +! a - type(psb_sspmat_type). The sparse matrix to be allocated. +! desc_a - type(psb_desc_type). The communication descriptor to be updated. +! info - integer. Return code. +! nnz - integer(optional). The number of nonzeroes in the matrix. +! (local, user estimate) +! +subroutine psb_sspalloc(a, desc_a, info, nnz) + + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(inout) :: desc_a + type(psb_sspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + + !locals + integer :: ictxt, dectype + integer :: np,me,loc_row,loc_col,& + & length_ia1,length_ia2, err_act,m,n + integer :: int_err(5) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_sspall' + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + dectype = psb_cd_get_dectype(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + loc_row = psb_cd_get_local_rows(desc_a) + loc_col = psb_cd_get_local_cols(desc_a) + m = psb_cd_get_global_rows(desc_a) + n = psb_cd_get_global_cols(desc_a) + + !...allocate matrix data... + if (present(nnz))then + if (nnz < 0) then + info=45 + int_err(1)=7 + int_err(2)=nnz + call psb_errpush(info,name,int_err) + goto 9999 + endif + length_ia1=nnz + length_ia2=nnz + else + length_ia1=max(1,5*loc_row) + endif + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + + !....allocate aspk, ia1, ia2..... + call psb_sp_all(loc_row,loc_col,a,length_ia1,info) + if(info /= 0) then + info=4010 + ch_err='sp_all' + call psb_errpush(info,name,int_err) + goto 9999 + end if + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ', & + & psb_cd_get_dectype(desc_a),psb_desc_bld_ + + return + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_sspalloc diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 new file mode 100644 index 000000000..c41399697 --- /dev/null +++ b/base/tools/psb_sspasb.f90 @@ -0,0 +1,144 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspasb.f90 +! +! Subroutine: psb_sspasb +! Assemble sparse matrix +! +! Arguments: +! a - type(psb_sspmat_type). The sparse matrix to be allocated. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! afmt - character(optional) The desired output storage format. +! upd - character(optional). How will the matrix be updated? +! psb_upd_srch_ Simple strategy +! psb_upd_perm_ Permutation(more memory) +! dupl - integer(optional). Duplicate coefficient handling: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +! psb_dupl_err_ raise an error. +! +! +subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl) + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + use psb_penv_mod + implicit none + + + !...Parameters.... + type(psb_sspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + !....Locals.... + integer :: int_err(5) + integer :: np,me,n_col, err_act + integer :: spstate + integer :: ictxt,n_row + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + info = 0 + int_err(1)=0 + name = 'psb_spasb' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(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_asb_desc(desc_a)) then + info = 600 + int_err(1) = psb_cd_get_dectype(desc_a) + call psb_errpush(info,name) + goto 9999 + endif + + if (debug_level >= psb_debug_ext_)& + & write(debug_unit, *) me,' ',trim(name),& + & ' Begin matrix assembly...' + + !check on errors encountered in psdspins + + spstate = a%infoa(psb_state_) + if (spstate == psb_spmat_bld_) then + ! + ! 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) + a%m = n_row + a%k = n_col + end if + + call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl) + + IF (debug_level >= psb_debug_ext_)& + & write(debug_unit, *) me,' ',trim(name),': From SPCNV',& + & 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 + endif + + 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_sspasb diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 new file mode 100644 index 000000000..ec50bf968 --- /dev/null +++ b/base/tools/psb_sspfree.f90 @@ -0,0 +1,96 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspfree.f90 +! +! Subroutine: psb_sspfree +! Frees a sparse matrix structure. +! +! Arguments: +! a - type(psb_sspmat_type). The sparse matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code. +! +subroutine psb_sspfree(a, desc_a,info) + !...free sparse matrix structure... + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + !...locals.... + integer :: ictxt,err_act + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + name = 'psb_sspfree' + call psb_erractionsave(err_act) + + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + else + ictxt = psb_cd_get_context(desc_a) + end if + + !...deallocate a.... + call psb_sp_free(a,info) + + + if(info /= 0) then + info=2045 + call psb_errpush(info,name) + goto 9999 + end if + + 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_sspfree + + + diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 new file mode 100644 index 000000000..e130e7bd1 --- /dev/null +++ b/base/tools/psb_ssphalo.F90 @@ -0,0 +1,395 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ssphalo.f90 +! +! Subroutine: psb_ssphalo +! This routine does the retrieval of remote matrix rows. +! Note that retrieval is done through GTBLK, therefore it should work +! for any matrix format in A; as for the output, default is CSR. +! +! +! Arguments: +! a - type(psb_sspmat_type) The local part of input matrix A +! desc_a - type(psb_desc_type). The communication descriptor. +! blck - type(psb_sspmat_type) The local part of output matrix BLCK +! info - integer. Return code +! rowcnv - logical Should row/col indices be converted +! colcnv - logical to/from global numbering when sent/received? +! default is .TRUE. +! rowscale - logical Should row/col indices on output be remapped +! colscale - logical from MIN:MAX to 1:(MAX-MIN+1) ? +! default is .FALSE. +! (commmon use is ROWSCALE=.TRUE., COLSCALE=.FALSE.) +! data - integer Which index list in desc_a should be used to retrieve +! rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ DISABLED for this routine. +! +! +Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + + use psb_const_mod + use psb_serial_mod + use psb_descriptor_type + use psb_realloc_mod + use psb_tools_mod, psb_protect_name => psb_ssphalo + use psb_error_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_sspmat_type),Intent(in) :: a + Type(psb_sspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer, intent(in), optional :: data + ! ...local scalars.... + Integer :: np,me,counter,proc,i, & + & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& + & irmin,icmin,irmax,icmax,data_,ngtz + Integer :: l1, icomm, err_act + Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), & + & rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:) + real(psb_spk_), allocatable :: valsnd(:) + integer, pointer :: idxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_ssphalo' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + ictxt = psb_cd_get_context(desc_a) + icomm = psb_cd_get_mpic(desc_a) + + Call psb_info(ictxt, me, np) + + Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1),stat=info) + + if (info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) + case(psb_comm_halo_) + idxv => desc_a%halo_index + + case(psb_comm_ext_) + idxv => desc_a%ext_index + +! !$ case(psb_comm_ovr_) +! !$ idxv => desc_a%ovrlap_index +! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(4010,name,a_err='wrong Data selector') + goto 9999 + end select + + + l1 = 0 + + sdsz(:)=0 + rvsz(:)=0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + blk%k = a%k + blk%m = 0 + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv = idxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = idxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = idxv(counter+psb_elem_send_+j) + n_elem = psb_sp_get_nnz_row(idx,a) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + + blk%m = blk%m + n_el_recv + + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv = idxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = idxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call psb_sp_all(blk,max(iszr,1),info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',size(blk%ia1),size(blk%ia2),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + if (info /= 0) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + mat_recv = iszr + iszs=sum(sdsz) + call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=idxv(counter) + if (proc == -1) exit + n_el_recv=idxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=idxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = idxv(counter+psb_elem_send_+j) + n_elem = psb_sp_get_nnz_row(idx,a) + + call psb_sp_getrow(idx,a,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= 0) then + info=4010 + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + + ipx = ipx + 1 + + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= 0) then + info=4010 + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_real,& + & blk%aspk,rvsz,brvindx,mpi_real,icomm,info) + call mpi_alltoallv(iasnd,sdsz,bsdindx,mpi_integer,& + & blk%ia1,rvsz,brvindx,mpi_integer,icomm,info) + call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& + & blk%ia2,rvsz,brvindx,mpi_integer,icomm,info) + if (info /= 0) then + info=4010 + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I') + + if (info /= 0) then + info=4010 + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + blk%m=0 + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(blk%ia1(i)) + k=(blk%ia2(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + blk%aspk(l1) = blk%aspk(i) + blk%ia1(l1) = r + blk%ia2(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + blk%m = max(irmax-irmin+1,0) + blk%ia1(1:l1) = blk%ia1(1:l1) - irmin + 1 + else + blk%m = irmax + end if + if (colscale_) then + blk%k = max(icmax-icmin+1,0) + blk%ia2(1:l1) = blk%ia2(1:l1) - icmin + 1 + else + blk%k = icmax + end if + + blk%fida = 'COO' + blk%infoa(psb_nnz_) = l1 + call psb_ensure_size(1,blk%pl,info) + if (info == 0) call psb_ensure_size(1,blk%pr,info) + if (info /= 0) then + info=4010 + ch_err='psb_ensure_size' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + blk%pl = 0 + blk%pr = 0 + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1,blk%m + + ! Do we expect any duplicates to appear???? + call psb_spcnv(blk,info,afmt=outfmt_,dupl=psb_dupl_add_) + if (info /= 0) then + info=4010 + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(sdid,brvindx,rvid,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + 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_ssphalo diff --git a/base/tools/psb_sspins.f90 b/base/tools/psb_sspins.f90 new file mode 100644 index 000000000..d1359e319 --- /dev/null +++ b/base/tools/psb_sspins.f90 @@ -0,0 +1,401 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_sspins.f90 +! +! Subroutine: psb_sspins +! Takes a cloud of coefficients and inserts them into a sparse matrix. +! Note: coefficients with a row index not belonging to the current process are +! ignored. +! If desc_a is in the build state this routine implies a call to psb_cdins. +! +! Arguments: +! nz - integer. The number of points to insert. +! ia(:) - integer The row indices of the coefficients. +! ja(:) - integer The column indices of the coefficients. +! val(:) - real The values of the coefficients to be inserted. +! a - type(psb_sspmat_type). The sparse destination matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code +! rebuild - logical Allows to reopen a matrix under +! certain circumstances. +! +subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) + + use psb_tools_mod, psb_protect_name => psb_sspins + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(inout) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + !locals..... + + integer :: nrow, err_act, ncol, spstate + integer :: ictxt,np,me + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + logical :: rebuild_ + integer, allocatable :: ila(:),jla(:) + character(len=20) :: name, ch_err + + info = 0 + name = 'psb_sspins' + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc_a)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(ia) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(val) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz==0) return + + if (present(rebuild)) then + rebuild_ = rebuild + else + rebuild_ = .false. + endif + + spstate = a%infoa(psb_state_) + if (psb_is_bld_desc(desc_a)) then + if (psb_is_large_desc(desc_a)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + + else + + call psb_cdins(nz,ia,ja,desc_a,info) + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + if (spstate == psb_spmat_bld_) then + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%glob_to_loc) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + info = 1123 + call psb_errpush(info,name) + goto 9999 + end if + + end if + + else if (psb_is_asb_desc(desc_a)) then + + if (psb_is_large_desc(desc_a)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) + call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') + call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& + & info,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + nrow = psb_cd_get_local_rows(desc_a) + ncol = psb_cd_get_local_cols(desc_a) + call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& + & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + info = 1122 + call psb_errpush(info,name) + goto 9999 + end if + + 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_sspins + + +subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) + use psb_tools_mod, psb_protect_name => psb_sspins_2desc + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + + !....parameters... + type(psb_desc_type), intent(in) :: desc_ar + type(psb_desc_type), intent(inout) :: desc_ac + type(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(kind=psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + !locals..... + + integer :: nrow, err_act, ncol, spstate + integer :: ictxt,np,me + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + integer, allocatable :: ila(:),jla(:) + character(len=20) :: name, ch_err + + info = 0 + name = 'psb_sspins' + call psb_erractionsave(err_act) + + + ictxt = psb_cd_get_context(desc_ar) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_ok_desc(desc_ar)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + if (.not.psb_is_ok_desc(desc_ac)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(ia) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (size(val) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz==0) return + + spstate = a%infoa(psb_state_) + if (psb_is_bld_desc(desc_ac)) then + + allocate(ila(nz),jla(nz),stat=info) + if (info /= 0) then + ch_err='allocate' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + ila(1:nz) = ia(1:nz) + + call psb_glob_to_loc(ia(1:nz),ila(1:nz),desc_ar,info,iact='I',owned=.true.) + + call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) + + if (info /= 0) then + ch_err='psb_cdins' + call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + nrow = psb_cd_get_local_rows(desc_ar) + ncol = psb_cd_get_local_cols(desc_ac) + + call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info) + if (info /= 0) then + info=4010 + ch_err='psb_coins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else if (psb_is_asb_desc(desc_ac)) then + + write(0,*) 'Why are you calling me on an assembled desc_ac?' +!!$ if (psb_is_large_desc(desc_a)) then +!!$ +!!$ allocate(ila(nz),jla(nz),stat=info) +!!$ if (info /= 0) then +!!$ ch_err='allocate' +!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ goto 9999 +!!$ end if +!!$ +!!$ ila(1:nz) = ia(1:nz) +!!$ jla(1:nz) = ja(1:nz) +!!$ call psb_glob_to_loc(ila(1:nz),desc_a,info,iact='I') +!!$ call psb_glob_to_loc(jla(1:nz),desc_a,info,iact='I') +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ +!!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& +!!$ & info,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ +!!$ else +!!$ nrow = psb_cd_get_local_rows(desc_a) +!!$ ncol = psb_cd_get_local_cols(desc_a) +!!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& +!!$ & info,gtl=desc_a%glob_to_loc,rebuild=rebuild_) +!!$ if (info /= 0) then +!!$ info=4010 +!!$ ch_err='psb_coins' +!!$ call psb_errpush(info,name,a_err=ch_err) +!!$ goto 9999 +!!$ end if +!!$ end if + else + info = 1122 + call psb_errpush(info,name) + goto 9999 + end if + + 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_sspins_2desc + diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 new file mode 100644 index 000000000..9f57e9873 --- /dev/null +++ b/base/tools/psb_ssprn.f90 @@ -0,0 +1,113 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ssprn.f90 +! +! Subroutine: psb_ssprn +! Reinit sparse matrix structure for psblas routines: on output the matrix +! is in the update state. +! +! Arguments: +! a - type(psb_sspmat_type). The sparse matrix to be reinitiated. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! clear - logical, optional Whether the coefficients should be zeroed +! default .true. +Subroutine psb_ssprn(a, desc_a,info,clear) + + use psb_descriptor_type + use psb_spmat_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + Implicit None + + !....Parameters... + Type(psb_desc_type), intent(in) :: desc_a + Type(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + + + !locals + Integer :: ictxt,np,me,err,err_act + integer :: debug_level, debug_unit + integer :: int_err(5) + character(len=20) :: name + logical :: clear_ + + info = 0 + err = 0 + int_err(1)=0 + name = 'psb_ssprn' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': start ' + + if (psb_is_bld_desc(desc_a)) then + ! Should do nothing, we are called redundantly + return + endif + if (.not.psb_is_asb_desc(desc_a)) then + info=590 + call psb_errpush(info,name) + goto 9999 + endif + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + call psb_sp_reinit(a,info,clear=clear_) + + if (info /= 0) goto 9999 + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': done' + + 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_ssprn diff --git a/base/tools/psb_zspins.f90 b/base/tools/psb_zspins.f90 index c84167e41..bd74ac339 100644 --- a/base/tools/psb_zspins.f90 +++ b/base/tools/psb_zspins.f90 @@ -256,7 +256,7 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(inout) :: desc_ac type(psb_zspmat_type), intent(inout) :: a integer, intent(in) :: nz,ia(:),ja(:) - complex(kind(1.d0)), intent(in) :: val(:) + complex(psb_dpk_), intent(in) :: val(:) integer, intent(out) :: info !locals..... diff --git a/config/acx_lapack.m4 b/config/acx_lapack.m4 new file mode 100644 index 000000000..41041f8f5 --- /dev/null +++ b/config/acx_lapack.m4 @@ -0,0 +1,95 @@ +dnl @synopsis ACX_LAPACK([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +dnl +dnl This macro looks for a library that implements the LAPACK +dnl linear-algebra interface (see http://www.netlib.org/lapack/). On +dnl success, it sets the LAPACK_LIBS output variable to hold the +dnl requisite library linkages. +dnl +dnl To link with LAPACK, you should link with: +dnl +dnl $LAPACK_LIBS $BLAS_LIBS $LIBS $FLIBS +dnl +dnl in that order. BLAS_LIBS is the output variable of the ACX_BLAS +dnl macro, called automatically. FLIBS is the output variable of the +dnl AC_F77_LIBRARY_LDFLAGS macro (called if necessary by ACX_BLAS), and +dnl is sometimes necessary in order to link with F77 libraries. Users +dnl will also need to use AC_F77_DUMMY_MAIN (see the autoconf manual), +dnl for the same reason. +dnl +dnl The user may also use --with-lapack= in order to use some +dnl specific LAPACK library . In order to link successfully, +dnl however, be aware that you will probably need to use the same +dnl Fortran compiler (which can be set via the F77 env. var.) as was +dnl used to compile the LAPACK and BLAS libraries. +dnl +dnl ACTION-IF-FOUND is a list of shell commands to run if a LAPACK +dnl library is found, and ACTION-IF-NOT-FOUND is a list of commands to +dnl run it if it is not found. If ACTION-IF-FOUND is not specified, the +dnl default action will define HAVE_LAPACK. +dnl +dnl @category InstalledPackages +dnl @author Steven G. Johnson +dnl @version 2002-03-12 +dnl @license GPLWithACException + +AC_DEFUN([ACX_LAPACK], [ +AC_REQUIRE([ACX_BLAS]) +acx_lapack_ok=no + +AC_ARG_WITH(lapack, + [AC_HELP_STRING([--with-lapack=], [use LAPACK library ])]) +case $with_lapack in + yes | "") ;; + no) acx_lapack_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) LAPACK_LIBS="$with_lapack" ;; + *) LAPACK_LIBS="-l$with_lapack" ;; +esac + +# Get fortran linker name of LAPACK function to check for. +AC_F77_FUNC(cheev) + +# We cannot use LAPACK if BLAS is not found +if test "x$acx_blas_ok" != xyes; then + acx_lapack_ok=noblas +fi + +# First, check LAPACK_LIBS environment variable +if test "x$LAPACK_LIBS" != x; then + save_LIBS="$LIBS"; LIBS="$LAPACK_LIBS $BLAS_LIBS $LIBS $FLIBS" + AC_MSG_CHECKING([for $cheev in $LAPACK_LIBS]) + AC_TRY_LINK_FUNC($cheev, [acx_lapack_ok=yes], [LAPACK_LIBS=""]) + AC_MSG_RESULT($acx_lapack_ok) + LIBS="$save_LIBS" + if test acx_lapack_ok = no; then + LAPACK_LIBS="" + fi +fi + +# LAPACK linked to by default? (is sometimes included in BLAS lib) +if test $acx_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$LIBS $BLAS_LIBS $FLIBS" + AC_CHECK_FUNC($cheev, [acx_lapack_ok=yes]) + LIBS="$save_LIBS" +fi + +# Generic LAPACK library? +for lapack in lapack lapack_rs6k; do + if test $acx_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + AC_CHECK_LIB($lapack, $cheev, + [acx_lapack_ok=yes; LAPACK_LIBS="-l$lapack"], [], [$FLIBS]) + LIBS="$save_LIBS" + fi +done + +AC_SUBST(LAPACK_LIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x"$acx_lapack_ok" = xyes; then + ifelse([$1],,AC_DEFINE(HAVE_LAPACK,1,[Define if you have LAPACK library.]),[$1]) + : +else + acx_lapack_ok=no + $2 +fi +])dnl ACX_LAPACK diff --git a/configure b/configure index 886ae1646..f236cc544 100755 --- a/configure +++ b/configure @@ -706,6 +706,7 @@ GREP EGREP FLIBS BLAS_LIBS +LAPACK_LIBS FDEFINES CDEFINES BASELIBNAME @@ -1356,6 +1357,7 @@ Optional Packages: --with-module-path additional MODULE_PATH flags to be added: will prepend to MODULE_PATH --with-blas= use BLAS library + --with-lapack= use LAPACK library --with-blacs=LIB Specify BLACSLIBNAME or -lBLACSLIBNAME or the absolute library filename. --with-metis=LIB Specify -lMETISLIBNAME or the absolute library @@ -9382,6 +9384,315 @@ fi +acx_lapack_ok=no + + +# Check whether --with-lapack was given. +if test "${with_lapack+set}" = set; then + withval=$with_lapack; +fi + +case $with_lapack in + yes | "") ;; + no) acx_lapack_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) LAPACK_LIBS="$with_lapack" ;; + *) LAPACK_LIBS="-l$with_lapack" ;; +esac + +# Get fortran linker name of LAPACK function to check for. +ac_ext=f +ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' +ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_f77_compiler_gnu +case $ac_cv_f77_mangling in + upper*) ac_val="CHEEV" ;; + lower*) ac_val="cheev" ;; + *) ac_val="unknown" ;; +esac +case $ac_cv_f77_mangling in *," underscore"*) ac_val="$ac_val"_ ;; esac + +cheev="$ac_val" + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +# We cannot use LAPACK if BLAS is not found +if test "x$acx_blas_ok" != xyes; then + acx_lapack_ok=noblas +fi + +# First, check LAPACK_LIBS environment variable +if test "x$LAPACK_LIBS" != x; then + save_LIBS="$LIBS"; LIBS="$LAPACK_LIBS $BLAS_LIBS $LIBS $FLIBS" + { echo "$as_me:$LINENO: checking for $cheev in $LAPACK_LIBS" >&5 +echo $ECHO_N "checking for $cheev in $LAPACK_LIBS... $ECHO_C" >&6; } + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $cheev (); +#ifdef F77_DUMMY_MAIN + +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } + +#endif +int +main () +{ +return $cheev (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + acx_lapack_ok=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + LAPACK_LIBS="" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext + { echo "$as_me:$LINENO: result: $acx_lapack_ok" >&5 +echo "${ECHO_T}$acx_lapack_ok" >&6; } + LIBS="$save_LIBS" + if test acx_lapack_ok = no; then + LAPACK_LIBS="" + fi +fi + +# LAPACK linked to by default? (is sometimes included in BLAS lib) +if test $acx_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$LIBS $BLAS_LIBS $FLIBS" + as_ac_var=`echo "ac_cv_func_$cheev" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $cheev" >&5 +echo $ECHO_N "checking for $cheev... $ECHO_C" >&6; } +if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $cheev to an innocuous variant, in case declares $cheev. + For example, HP-UX 11i declares gettimeofday. */ +#define $cheev innocuous_$cheev + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $cheev (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $cheev + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $cheev (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$cheev || defined __stub___$cheev +choke me +#endif + +#ifdef F77_DUMMY_MAIN + +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } + +#endif +int +main () +{ +return $cheev (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_var=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +fi +ac_res=`eval echo '${'$as_ac_var'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_var'}'` = yes; then + acx_lapack_ok=yes +fi + + LIBS="$save_LIBS" +fi + +# Generic LAPACK library? +for lapack in lapack lapack_rs6k; do + if test $acx_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + as_ac_Lib=`echo "ac_cv_lib_$lapack''_$cheev" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $cheev in -l$lapack" >&5 +echo $ECHO_N "checking for $cheev in -l$lapack... $ECHO_C" >&6; } +if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-l$lapack $FLIBS $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $cheev (); +#ifdef F77_DUMMY_MAIN + +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } + +#endif +int +main () +{ +return $cheev (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + eval "$as_ac_Lib=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_Lib=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +ac_res=`eval echo '${'$as_ac_Lib'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_Lib'}'` = yes; then + acx_lapack_ok=yes; LAPACK_LIBS="-l$lapack" +fi + + LIBS="$save_LIBS" + fi +done + + + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x"$acx_lapack_ok" = xyes; then + FDEFINES="$psblas_cv_define_prepend-DHAVE_LAPACK $FDEFINES" + : +else + acx_lapack_ok=no + +fi + + + ############################################################################### # BLACS library presence checks ############################################################################### @@ -10291,11 +10602,12 @@ UTILLIBNAME=libpsb_util.a + if test "X$psblas_make_gnumake" == "Xyes" ; then PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) # Warning : these rules are only valid with GNU make! @@ -10324,7 +10636,7 @@ $(.mod).o: else PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) @@ -11110,12 +11422,12 @@ GREP!$GREP$ac_delim EGREP!$EGREP$ac_delim FLIBS!$FLIBS$ac_delim BLAS_LIBS!$BLAS_LIBS$ac_delim +LAPACK_LIBS!$LAPACK_LIBS$ac_delim FDEFINES!$FDEFINES$ac_delim CDEFINES!$CDEFINES$ac_delim BASELIBNAME!$BASELIBNAME$ac_delim F90!$F90$ac_delim F90COPT!$F90COPT$ac_delim -MPF90!$MPF90$ac_delim _ACEOF if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then @@ -11157,6 +11469,7 @@ _ACEOF ac_delim='%!_!# ' for ac_last_try in false false false false false :; do cat >conf$$subs.sed <<_ACEOF +MPF90!$MPF90$ac_delim MPF77!$MPF77$ac_delim MPCC!$MPCC$ac_delim FCOPT!$FCOPT$ac_delim @@ -11185,7 +11498,7 @@ LIBOBJS!$LIBOBJS$ac_delim LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 26; then + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 27; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 @@ -11507,7 +11820,7 @@ echo "$as_me: executing $ac_file commands" >&6;} # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. - if sed 10q "$mf" | grep '^#.*generated by automake' > /dev/null 2>&1; then + if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`$as_dirname -- "$mf" || $as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$mf" : 'X\(//\)[^/]' \| \ diff --git a/configure.ac b/configure.ac index dc617a95d..5baec23bb 100755 --- a/configure.ac +++ b/configure.ac @@ -546,6 +546,9 @@ AR="${AR} -cur" AC_LANG([C]) ACX_BLAS([], [AC_MSG_ERROR([[Cannot find BLAS library, specify a path using --with-blas=DIR/LIB (for example --with-blas=/usr/path/lib/libcxml.a)]])]) +ACX_LAPACK( +[FDEFINES="$psblas_cv_define_prepend-DHAVE_LAPACK $FDEFINES"], +) ############################################################################### @@ -644,13 +647,14 @@ AC_SUBST(INSTALL_INCLUDEDIR) AC_SUBST(BLAS_LIBS) AC_SUBST(BLACS_LIBS) AC_SUBST(METIS_LIBS) +AC_SUBST(LAPACK_LIBS) AC_SUBST(CINCLUDES) AC_SUBST(FINCLUDES) if test "X$psblas_make_gnumake" == "Xyes" ; then PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) # Warning : these rules are only valid with GNU make! @@ -679,7 +683,7 @@ $(.mod).o: else PSBLASRULES=' -PSBLDLIBS=$(BLACS) $(BLAS) $(METIS_LIB) $(LIBS) +PSBLDLIBS=$(BLACS) $(LAPACK) $(BLAS) $(METIS_LIB) $(LIBS) CDEFINES=$(PSBCDEFINES) FDEFINES=$(PSBFDEFINES) diff --git a/krylov/Makefile b/krylov/Makefile index 791ed1400..fcc707ac1 100644 --- a/krylov/Makefile +++ b/krylov/Makefile @@ -7,6 +7,10 @@ LIBDIR=../lib MODOBJS= psb_krylov_mod.o F90OBJS= psb_dcgstab.o psb_dcg.o psb_dcgs.o \ psb_dbicg.o psb_dcgstabl.o psb_drgmres.o\ + psb_scgstab.o psb_scg.o psb_scgs.o \ + psb_sbicg.o psb_scgstabl.o psb_srgmres.o\ + psb_ccgstab.o psb_ccg.o psb_ccgs.o \ + psb_cbicg.o psb_ccgstabl.o psb_crgmres.o\ psb_zcgstab.o psb_zcg.o psb_zcgs.o \ psb_zbicg.o psb_zcgstabl.o psb_zrgmres.o OBJS=$(F90OBJS) $(MODOBJS) diff --git a/krylov/psb_cbicg.f90 b/krylov/psb_cbicg.f90 new file mode 100644 index 000000000..d87433eb5 --- /dev/null +++ b/krylov/psb_cbicg.f90 @@ -0,0 +1,336 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! File: psb_cbicg.f90 +! +! Subroutine: psb_cbicg +! This subroutine implements the BiCG method. +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b(:) - complex Input: vector containing the +! right hand side B +! x(:) - complex Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_cbicg + implicit none + +!!$ parameters + type(psb_cspmat_type), intent(in) :: a + type(psb_cprec_type), intent(in) :: prec + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: b(:) + complex(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace, istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err +!!$ local data + complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + complex(psb_spk_), pointer :: ww(:), q(:),& + & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) + integer :: int_err(5) + integer ::itmax_, naux, mglob, it, itrace_,& + & np,me, n_row, n_col, istop_, err_act + integer :: debug_level, debug_unit + logical, parameter :: exchange=.true., noexchange=.false. + integer, parameter :: irmax = 8 + integer :: itx, isvch, ictxt + complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name,ch_err + character(len=*), parameter :: methdname='BiCG' + + info = 0 + name = 'psb_cbicg' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + ! + ! istop_ = 1: normwise backward error, infinity norm + ! istop_ = 2: ||r||/||b|| norm 2 + ! + + if ((istop_ < 1 ).or.(istop_ > 2 ) ) then + info=5001 + int_err=istop_ + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + + naux=4*n_col + + allocate(aux(naux),stat=info) + if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) + if (info == 0) call psb_geasb(wwrk,desc_a,info) + if(info /= 0) then + info=4011 + ch_err='psb_asb' + err=info + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + q => wwrk(:,1) + qt => wwrk(:,2) + r => wwrk(:,3) + rt => wwrk(:,4) + p => wwrk(:,5) + pt => wwrk(:,6) + z => wwrk(:,7) + zt => wwrk(:,8) + ww => wwrk(:,9) + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + itx = 0 + + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + restart: do +!!$ +!!$ r0 = b-ax0 +!!$ + if (itx >= itmax_) exit restart + it = 0 + call psb_geaxpby(cone,b,czero,r,desc_a,info) + if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),' Cone spmm',info + if (info == 0) call psb_geaxpby(cone,r,czero,rt,desc_a,info) + if(info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = czero + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + it = it + 1 + itx = itx + 1 + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx + + call psb_precaply(prec,r,z,desc_a,info,work=aux) + if (info == 0) call psb_precaply(prec,rt,zt,desc_a,info,trans='c',work=aux) + + rho_old = rho + rho = psb_gedot(rt,z,desc_a,info) + if (rho==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown r',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(cone,z,czero,p,desc_a,info) + call psb_geaxpby(cone,zt,czero,pt,desc_a,info) + else + beta = (rho/rho_old) + call psb_geaxpby(cone,z,(beta),p,desc_a,info) + call psb_geaxpby(cone,zt,(beta),pt,desc_a,info) + end if + + call psb_spmm(cone,a,p,czero,q,desc_a,info,& + & work=aux) + call psb_spmm(cone,a,pt,czero,qt,desc_a,info,& + & work=aux,trans='c') + + sigma = psb_gedot(pt,q,desc_a,info) + if (sigma==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown s1', sigma + exit iteration + endif + + alpha = rho/sigma + + + call psb_geaxpby((alpha),p,cone,x,desc_a,info) + call psb_geaxpby(-(alpha),q,cone,r,desc_a,info) + call psb_geaxpby(-(alpha),qt,cone,rt,desc_a,info) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux, stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cbicg + + diff --git a/krylov/psb_ccg.f90 b/krylov/psb_ccg.f90 new file mode 100644 index 000000000..92862d0ff --- /dev/null +++ b/krylov/psb_ccg.f90 @@ -0,0 +1,285 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_ccg.f90 +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_ccg.f90 +! +! Subroutine: psb_ccg +! This subroutine implements the Conjugate Gradient method. +! +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b(:) - complex Input: vector containing the +! right hand side B +! x(:) - complex Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_ccg + implicit none + +!!$ Parameters + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_cprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ Local data + complex(psb_spk_), allocatable, target :: aux(:), wwrk(:,:) + complex(psb_spk_), pointer :: q(:), p(:), r(:), z(:), w(:) + complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma + integer :: itmax_, istop_, naux, mglob, it, itx, itrace_,& + & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) + integer :: debug_level, debug_unit + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name + character(len=*), parameter :: methdname='CG' + + info = 0 + name = 'psb_ccg' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + allocate(aux(naux), stat=info) + if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) + if (info == 0) call psb_geasb(wwrk,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + p => wwrk(:,1) + q => wwrk(:,2) + r => wwrk(:,3) + z => wwrk(:,4) + w => wwrk(:,5) + + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + itx=0 + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + restart: do +!!$ +!!$ r0 = b-Ax0 +!!$ + if (itx>= itmax_) exit restart + + it = 0 + call psb_geaxpby(cone,b,czero,r,desc_a,info) + if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = czero + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + + it = it + 1 + itx = itx + 1 + + call psb_precaply(prec,r,z,desc_a,info,work=aux) + rho_old = rho + rho = psb_gedot(r,z,desc_a,info) + + if (it==1) then + call psb_geaxpby(cone,z,czero,p,desc_a,info) + else + if (rho_old==czero) then + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': CG Iteration breakdown rho' + exit iteration + endif + beta = rho/rho_old + call psb_geaxpby(cone,z,beta,p,desc_a,info) + end if + + call psb_spmm(cone,a,p,czero,q,desc_a,info,work=aux) + sigma = psb_gedot(p,q,desc_a,info) + if (sigma==czero) then + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': CG Iteration breakdown sigma' + exit iteration + endif + + alpha = rho/sigma + call psb_geaxpby(alpha,p,cone,x,desc_a,info) + call psb_geaxpby(-alpha,q,cone,r,desc_a,info) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + call psb_gefree(wwrk,desc_a,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_ccg + + diff --git a/krylov/psb_ccgs.f90 b/krylov/psb_ccgs.f90 new file mode 100644 index 000000000..ff0d758d2 --- /dev/null +++ b/krylov/psb_ccgs.f90 @@ -0,0 +1,328 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_ccgs.f90 +! +! Subroutine: psb_ccgs +! Implements the Conjugate Gradient Squared method. +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b - complex,dimension(:) Input: vector containing the +! right hand side B +! x - complex,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_ccgs + implicit none + +!!$ parameters + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_cprec_type), Intent(in) :: prec + Complex(psb_spk_), Intent(in) :: b(:) + Complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + Complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + Complex(psb_spk_), Pointer :: ww(:), q(:),& + & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) + Integer :: itmax_, naux, mglob, it, itrace_,int_err(5),& + & np,me, n_row, n_col,istop_, err_act + Integer :: itx, isvch, ictxt + integer :: debug_level, debug_unit + complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name + character(len=*), parameter :: methdname='CGS' + + info = 0 + name = 'psb_ccgs' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + If (Present(istop)) Then + istop_ = istop + Else + istop_ = 1 + Endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + Allocate(aux(naux),stat=info) + if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == 0) Call psb_geasb(wwrk,desc_a,info) + if (info /= 0) Then + info=4011 + call psb_errpush(info,name) + goto 9999 + End If + + q => wwrk(:,1) + qt => wwrk(:,2) + r => wwrk(:,3) + rt => wwrk(:,4) + p => wwrk(:,5) + v => wwrk(:,6) + uv => wwrk(:,7) + z => wwrk(:,8) + f => wwrk(:,9) + s => wwrk(:,10) + ww => wwrk(:,11) + + + If (Present(itmax)) Then + itmax_ = itmax + Else + itmax_ = 1000 + Endif + + If (Present(itrace)) Then + itrace_ = itrace + Else + itrace_ = 0 + End If + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + itx = 0 + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + restart: Do +!!$ +!!$ r0 = b-ax0 +!!$ + if (itx >= itmax_) exit restart + it = 0 + call psb_geaxpby(cone,b,czero,r,desc_a,info) + if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == 0) call psb_geaxpby(cone,r,czero,rt,desc_a,info) + if (info/=0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + rho = czero + + iteration: do + it = it + 1 + itx = itx + 1 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx + + rho_old = rho + rho = psb_gedot(rt,r,desc_a,info) + + if (rho==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown r',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(cone,r,czero,uv,desc_a,info) + if (info == 0) call psb_geaxpby(cone,r,czero,p,desc_a,info) + else + beta = (rho/rho_old) + call psb_geaxpby(cone,r,czero,uv,desc_a,info) + if (info == 0) call psb_geaxpby(beta,q,cone,uv,desc_a,info) + if (info == 0) call psb_geaxpby(cone,q,beta,p,desc_a,info) + if (info == 0) call psb_geaxpby(cone,uv,beta,p,desc_a,info) + end if + + if (info == 0) call psb_precaply(prec,p,f,desc_a,info,work=aux) + + if (info == 0) call psb_spmm(cone,a,f,czero,v,desc_a,info,& + & work=aux) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='First loop part ') + goto 9999 + end if + + sigma = psb_gedot(rt,v,desc_a,info) + if (sigma==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown s1', sigma + exit iteration + endif + + alpha = rho/sigma + + if (info == 0) call psb_geaxpby(cone,uv,czero,q,desc_a,info) + if (info == 0) call psb_geaxpby(-alpha,v,cone,q,desc_a,info) + if (info == 0) call psb_geaxpby(cone,uv,czero,s,desc_a,info) + if (info == 0) call psb_geaxpby(cone,q,cone,s,desc_a,info) + + if (info == 0) call psb_precaply(prec,s,z,desc_a,info,work=aux) + + if (info == 0) call psb_geaxpby(alpha,z,cone,x,desc_a,info) + + if (info == 0) call psb_spmm(cone,a,z,czero,qt,desc_a,info,& + & work=aux) + + if (info == 0) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='X update ') + goto 9999 + end if + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_ccgs diff --git a/krylov/psb_ccgstab.f90 b/krylov/psb_ccgstab.f90 new file mode 100644 index 000000000..03ea52961 --- /dev/null +++ b/krylov/psb_ccgstab.f90 @@ -0,0 +1,357 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_ccgstab.f90 +! +! Subroutine: psb_ccgstab +! This subroutine implements the BiCG Stabilized method. +! +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b - complex,dimension(:) Input: vector containing the +! right hand side B +! x - complex,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_ccgstab + Implicit None +!!$ parameters + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_cprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + Complex(psb_spk_), Intent(in) :: b(:) + Complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ Local data + Complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + Complex(psb_spk_), Pointer :: q(:),& + & r(:), p(:), v(:), s(:), t(:), z(:), f(:) + Integer :: itmax_, naux, mglob, it,itrace_,& + & np,me, n_row, n_col + integer :: debug_level, debug_unit + Integer :: itx, isvch, ictxt, err_act + Integer :: istop_ + complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma, omega, tau + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr +!!$ Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme +!!$ Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event + character(len=20) :: name + character(len=*), parameter :: methdname='BiCGStab' + + info = 0 + name = 'psb_ccgstab' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + If (Present(istop)) Then + istop_ = istop + Else + istop_ = 1 + Endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + naux=6*n_col + allocate(aux(naux),stat=info) + if (info==0) call psb_geall(wwrk,desc_a,info,n=8) + if (info==0) call psb_geasb(wwrk,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + End If + + Q => WWRK(:,1) + R => WWRK(:,2) + P => WWRK(:,3) + V => WWRK(:,4) + F => WWRK(:,5) + S => WWRK(:,6) + T => WWRK(:,7) + Z => WWRK(:,8) + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + itx = 0 + + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + + restart: Do +!!$ +!!$ r0 = b-Ax0 +!!$ + if (itx >= itmax_) exit restart + it = 0 + call psb_geaxpby(cone,b,czero,r,desc_a,info) + if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == 0) call psb_geaxpby(cone,r,czero,q,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = czero + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' On entry to AMAX: B: ',Size(b) + + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: Do + it = it + 1 + itx = itx + 1 + If (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration: ',itx + + rho_old = rho + rho = psb_gedot(q,r,desc_a,info) + + if (rho==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown R',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(cone,r,czero,p,desc_a,info) + else + beta = (rho/rho_old)*(alpha/omega) + call psb_geaxpby(-omega,v,cone,p,desc_a,info) + if (info == 0) call psb_geaxpby(cone,r,beta,p,desc_a,info) + end if + + if (info == 0) call psb_precaply(prec,p,f,desc_a,info,work=aux) + + if (info == 0) call psb_spmm(cone,a,f,czero,v,desc_a,info,& + & work=aux) + + if (info == 0) sigma = psb_gedot(q,v,desc_a,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='First step') + goto 9999 + end if + + if (sigma==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown S1', sigma + exit iteration + endif + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' SIGMA:',sigma + alpha = rho/sigma + + call psb_geaxpby(cone,r,czero,s,desc_a,info) + if (info == 0) call psb_geaxpby(-alpha,v,cone,s,desc_a,info) + if (info == 0) call psb_precaply(prec,s,z,desc_a,info,work=aux) + if (info == 0) call psb_spmm(cone,a,z,czero,t,desc_a,info,& + & work=aux) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Second step ') + goto 9999 + end if + + sigma = psb_gedot(t,t,desc_a,info) + if (sigma==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown S2', sigma + exit iteration + endif + + tau = psb_gedot(t,s,desc_a,info) + omega = tau/sigma + + if (omega==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown O',omega + exit iteration + endif + + if (info == 0) call psb_geaxpby(alpha,f,cone,x,desc_a,info) + if (info == 0) call psb_geaxpby(omega,z,cone,x,desc_a,info) + if (info == 0) call psb_geaxpby(cone,s,czero,r,desc_a,info) + if (info == 0) call psb_geaxpby(-omega,t,cone,r,desc_a,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='X update ') + goto 9999 + end if + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + 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_ccgstab + diff --git a/krylov/psb_ccgstabl.f90 b/krylov/psb_ccgstabl.f90 new file mode 100644 index 000000000..f36b940b5 --- /dev/null +++ b/krylov/psb_ccgstabl.f90 @@ -0,0 +1,413 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ C [5] G. Sleijpen, D. Fokkema C +!!$ C BICGSTAB(L) for linear equations involving unsymmetric C +!!$ C matrices with complex spectrum C +!!$ C Electronic Trans. on Numer. Analysis, Vol. 1, pp. 11-32, C +!!$ C Sep. 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_ccgstabl.f90 +! +! Subroutine: psb_ccgstabl +! Implements the BICGSTAB(L) method +! +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b(:) - complex Input: vector containing the +! right hand side B +! x(:) - complex Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration +! is stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! irst - integer(optional) Input: restart parameter L +! +! +! +Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_ccgstabl + implicit none + +!!$ parameters + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_cprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) + complex(psb_spk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & + & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) + + Integer :: itmax_, naux, mglob, it, itrace_,& + & np,me, n_row, n_col, nl, err_act + Logical, Parameter :: exchange=.True., noexchange=.False. + Integer, Parameter :: irmax = 8 + Integer :: itx, i, isvch, ictxt,istop_,j, int_err(5) + integer :: debug_level, debug_unit + complex(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& + & omega + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name + character(len=*), parameter :: methdname='BiCGStab(L)' + + info = 0 + name = 'psb_ccgstabl' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + if (present(irst)) then + nl = irst + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'present: irst: ',irst,nl + else + nl = 1 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' not present: irst: ',irst,nl + endif + if (nl <=0 ) then + info=5001 + int_err(1)=nl + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + allocate(aux(naux),gamma(0:nl),gamma1(nl),& + &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) + + if (info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) + if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == 0) Call psb_geasb(wwrk,desc_a,info) + if (info == 0) Call psb_geasb(uh,desc_a,info) + if (info == 0) Call psb_geasb(rh,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + q => wwrk(:,1) + r => wwrk(:,2) + p => wwrk(:,3) + v => wwrk(:,4) + f => wwrk(:,5) + s => wwrk(:,6) + t => wwrk(:,7) + z => wwrk(:,8) + ww => wwrk(:,9) + rt0 => wwrk(:,10) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + itx = 0 + restart: do +!!$ +!!$ r0 = b-ax0 +!!$ + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it + if (itx >= itmax_) exit restart + + it = 0 + call psb_geaxpby(cone,b,czero,r,desc_a,info) + if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + + if (info == 0) call psb_precaply(prec,r,desc_a,info) + + if (info == 0) call psb_geaxpby(cone,r,czero,rt0,desc_a,info) + if (info == 0) call psb_geaxpby(cone,r,czero,rh(:,0),desc_a,info) + if (info == 0) call psb_geaxpby(czero,r,czero,uh(:,0),desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = cone + alpha = czero + omega = cone + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' on entry to amax: b: ',Size(b) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + it = it + nl + itx = itx + nl + rho = -omega*rho + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration: ',itx, rho,rh(1,0) + + do j = 0, nl -1 + If (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl + + rho_old = rho + rho = psb_gedot(rh(:,j),rt0,desc_a,info) + if (rho==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bi-cgstab iteration breakdown r',rho + exit iteration + endif + + beta = alpha*rho/rho_old + rho_old = rho + call psb_geaxpby(cone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) + call psb_spmm(cone,a,uh(:,j),czero,uh(:,j+1),desc_a,info,work=aux) + + call psb_precaply(prec,uh(:,j+1),desc_a,info) + + gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) + + if (gamma(j)==czero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bi-cgstab iteration breakdown s2',gamma(j) + exit iteration + endif + alpha = rho/gamma(j) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) + + call psb_geaxpby(-alpha,uh(:,1:j+1),cone,rh(:,0:j),desc_a,info) + call psb_geaxpby(alpha,uh(:,0),cone,x,desc_a,info) + call psb_spmm(cone,a,rh(:,j),czero,rh(:,j+1),desc_a,info,work=aux) + + call psb_precaply(prec,rh(:,j+1),desc_a,info) + + enddo + + do j=1, nl + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' mod g-s part: ',j, nl,rh(1,0) + + do i=1, j-1 + taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) + taum(i,j) = taum(i,j)/sigma(i) + call psb_geaxpby(-taum(i,j),rh(:,i),cone,rh(:,j),desc_a,info) + enddo + sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) + gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) + gamma1(j) = gamma1(j)/sigma(j) + enddo + + gamma(nl) = gamma1(nl) + omega = gamma(nl) + + do j=nl-1,1,-1 + gamma(j) = gamma1(j) + do i=j+1,nl + gamma(j) = gamma(j) - taum(j,i) * gamma(i) + enddo + enddo + + do j=1,nl-1 + gamma2(j) = gamma(j+1) + do i=j+1,nl-1 + gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) + enddo + enddo + + call psb_geaxpby(gamma(1),rh(:,0),cone,x,desc_a,info) + call psb_geaxpby(-gamma1(nl),rh(:,nl),cone,rh(:,0),desc_a,info) + call psb_geaxpby(-gamma(nl),uh(:,nl),cone,uh(:,0),desc_a,info) + + do j=1, nl-1 + call psb_geaxpby(-gamma(j),uh(:,j),cone,uh(:,0),desc_a,info) + call psb_geaxpby(gamma2(j),rh(:,j),cone,x,desc_a,info) + call psb_geaxpby(-gamma1(j),rh(:,j),cone,rh(:,0),desc_a,info) + enddo + + if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info == 0) call psb_gefree(uh,desc_a,info) + if (info == 0) call psb_gefree(rh,desc_a,info) + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +End Subroutine psb_ccgstabl + + diff --git a/krylov/psb_crgmres.f90 b/krylov/psb_crgmres.f90 new file mode 100644 index 000000000..2bf656959 --- /dev/null +++ b/krylov/psb_crgmres.f90 @@ -0,0 +1,590 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Contributions to this routine: +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR +!!$ +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ C [5] G. Sleijpen, D. Fokkema C +!!$ C BICGSTAB(L) for linear equations involving unsymmetric C +!!$ C matrices with complex spectrum C +!!$ C Electronic Trans. on Numer. Analysis, Vol. 1, pp. 11-32, C +!!$ C Sep. 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_crgmres.f90 +! +! Subroutine: psb_crgmres +! This subroutine implements the restarted GMRES method with right +! preconditioning. +! +! Arguments: +! +! a - type(psb_cspmat_type) Input: sparse matrix containing A. +! prec - type(psb_cprec_type) Input: preconditioner +! b - complex,dimension(:) Input: vector containing the +! right hand side B +! x - complex,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! irst - integer(optional) Input: restart parameter +! +Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_crgmres + implicit none + +!!$ Parameters + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_cprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + complex(psb_spk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) + complex(psb_spk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) + Real(psb_spk_) :: tmp + complex(psb_spk_) :: rti, rti1, scal + Integer ::litmax, naux, mglob, it,k, itrace_,& + & np,me, n_row, n_col, nl, int_err(5) + Logical, Parameter :: exchange=.True., noexchange=.False. + Integer, Parameter :: irmax = 8 + Integer :: itx, i, isvch, ictxt,istop_, err_act + integer :: debug_level, debug_unit + Real(psb_dpk_) :: rni, xni, bni, ani,bn2 + real(psb_dpk_) :: errnum, errden, deps, derr + character(len=20) :: name + character(len=*), parameter :: methdname='RGMRES' + + info = 0 + name = 'psb_cgmres' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + ! + ! ISTOP_ = 1: Normwise backward error, infinity norm + ! ISTOP_ = 2: ||r||/||b||, 2-norm + ! + + if ((istop_ < 1 ).or.(istop_ > 2 ) ) then + info=5001 + int_err(1)=istop_ + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if (present(itmax)) then + litmax = itmax + else + litmax = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + if (present(irst)) then + nl = irst + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' present: irst: ',irst,nl + else + nl = 10 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' not present: irst: ',irst,nl + endif + if (nl <=0 ) then + info=5001 + int_err(1)=nl + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + + naux=4*n_col + allocate(aux(naux),h(nl+1,nl+1),& + &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) + + if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1) + if (info == 0) Call psb_geall(w,desc_a,info) + if (info == 0) Call psb_geall(w1,desc_a,info) + if (info == 0) Call psb_geall(xt,desc_a,info) + if (info == 0) Call psb_geasb(v,desc_a,info) + if (info == 0) Call psb_geasb(w,desc_a,info) + if (info == 0) Call psb_geasb(w1,desc_a,info) + if (info == 0) Call psb_geasb(xt,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Size of V,W,W1 ',size(v),size(v,1),& + & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + if (istop_ == 1) then + ani = psb_spnrmi(a,desc_a,info) + bni = psb_geamax(b,desc_a,info) + else if (istop_ == 2) then + bn2 = psb_genrm2(b,desc_a,info) + endif + errnum = dzero + errden = done + deps = eps + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + + itx = 0 + restart: do + + ! compute r0 = b-ax0 + ! check convergence + ! compute v1 = r0/||r0||_2 + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' restart: ',itx,it + it = 0 + call psb_geaxpby(cone,b,czero,v(:,1),desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_spmm(-cone,a,x,cone,v(:,1),desc_a,info,work=aux) + if (info /= 0) Then + info=4011 + call psb_errpush(info,name) + goto 9999 + End If + + rs(1) = psb_genrm2(v(:,1),desc_a,info) + rs(2:) = czero + if (info /= 0) Then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' on entry to amax: b: ',Size(b),rs(1),scal + + ! + ! check convergence + ! + if (istop_ == 1) then + rni = psb_geamax(v(:,1),desc_a,info) + xni = psb_geamax(x,desc_a,info) + errnum = rni + errden = (ani*xni+bni) + else if (istop_ == 2) then + rni = psb_genrm2(v(:,1),desc_a,info) + errnum = rni + errden = bn2 + endif + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + if (errnum <= deps*errden) exit restart + + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) + + v(:,1) = v(:,1) * scal + + if (itx >= litmax) exit restart + + ! + ! inner iterations + ! + + inner: Do i=1,nl + itx = itx + 1 + + call psb_precaply(prec,v(:,i),w1,desc_a,info) + Call psb_spmm(cone,a,w1,czero,w,desc_a,info,work=aux) + ! + + do k = 1, i + h(k,i) = psb_gedot(v(:,k),w,desc_a,info) + call psb_geaxpby(-h(k,i),v(:,k),cone,w,desc_a,info) + end do + h(i+1,i) = psb_genrm2(w,desc_a,info) + scal=done/h(i+1,i) + call psb_geaxpby(scal,w,czero,v(:,i+1),desc_a,info) + do k=2,i + call crot(1,h(k-1,i),1,h(k,i),1,real(c(k-1)),s(k-1)) + enddo + + rti = h(i,i) + rti1 = h(i+1,i) + call crotg(rti,rti1,tmp,s(i)) + c(i) = cmplx(tmp,szero) + call crot(1,h(i,i),1,h(i+1,i),1,real(c(i)),s(i)) + h(i+1,i) = czero + call crot(1,rs(i),1,rs(i+1),1,real(c(i)),s(i)) + + if (istop_ == 1) then + ! + ! build x and then compute the residual and its infinity norm + ! + rst = rs + xt = czero + call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rst,size(rst,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rst(1:nl) + do k=1, i + call psb_geaxpby(rst(k),v(:,k),cone,xt,desc_a,info) + end do + call psb_precaply(prec,xt,desc_a,info) + call psb_geaxpby(cone,x,cone,xt,desc_a,info) + call psb_geaxpby(cone,b,czero,w1,desc_a,info) + call psb_spmm(-cone,a,xt,cone,w1,desc_a,info,work=aux) + rni = psb_geamax(w1,desc_a,info) + xni = psb_geamax(xt,desc_a,info) + errnum = rni + errden = (ani*xni+bni) + ! + + else if (istop_ == 2) then + ! + ! compute the residual 2-norm as byproduct of the solution + ! procedure of the least-squares problem + ! + rni = abs(rs(i+1)) + errnum = rni + errden = bn2 + endif + + If (errnum <= deps*errden) Then + + if (istop_ == 1) then + x = xt + else if (istop_ == 2) then + ! + ! build x + ! + call ctrsm('l','u','n','n',i,1,cone,h,size(h,1),rs,size(rs,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rs(1:nl) + w1 = czero + do k=1, i + call psb_geaxpby(rs(k),v(:,k),cone,w1,desc_a,info) + end do + call psb_precaply(prec,w1,w,desc_a,info) + call psb_geaxpby(cone,w,cone,x,desc_a,info) + end if + + exit restart + + end if + + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) + + end do inner + + if (istop_ == 1) then + x = xt + else if (istop_ == 2) then + ! + ! build x + ! + call ctrsm('l','u','n','n',nl,1,cone,h,size(h,1),rs,size(rs,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rs(1:nl) + w1 = czero + do k=1, nl + call psb_geaxpby(rs(k),v(:,k),cone,w1,desc_a,info) + end do + call psb_precaply(prec,w1,w,desc_a,info) + call psb_geaxpby(cone,w,cone,x,desc_a,info) + end if + + end do restart + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,1,errnum,errden,deps) + + call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) + + if (present(err)) then + err = derr + end if + + + deallocate(aux,h,c,s,rs,rst, stat=info) + if (info == 0) call psb_gefree(v,desc_a,info) + if (info == 0) call psb_gefree(w,desc_a,info) + if (info == 0) call psb_gefree(w1,desc_a,info) + if (info == 0) call psb_gefree(xt,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine crot( 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(psb_spk_) c + complex(psb_spk_) s + ! .. + ! .. array arguments .. + complex(psb_spk_) 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(psb_dpk_) stemp + ! .. + ! .. intrinsic functions .. + ! .. + ! .. executable statements .. + ! + if( n <= 0 ) return + if( incx == 1 .and. incy == 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) - conjg(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 < 0 )ix = ( -n+1 )*incx + 1 + if( incy < 0 )iy = ( -n+1 )*incy + 1 + do i = 1, n + stemp = c*cx(ix) + s*cy(iy) + cy(iy) = c*cy(iy) - conjg(s)*cx(ix) + cx(ix) = stemp + ix = ix + incx + iy = iy + incy + end do + end if + return + end subroutine crot + ! + ! + subroutine crotg(ca,cb,c,s) + complex(psb_spk_) ca,cb,s + real(psb_spk_) c + real(psb_spk_) norm,scale + complex(psb_spk_) alpha + ! + if (cabs(ca) == 0.0) then + ! + c = 0.0d0 + s = (1.0,0.0) + ca = cb + return + end if + ! + + scale = cabs(ca) + cabs(cb) + norm = scale*sqrt((cabs(ca/cmplx(scale,0.0)))**2 +& + & (cabs(cb/cmplx(scale,0.0)))**2) + alpha = ca /cabs(ca) + c = cabs(ca) / norm + s = alpha * conjg(cb) / norm + ca = alpha * norm + ! + + return + end subroutine crotg +End Subroutine psb_crgmres diff --git a/krylov/psb_dcg.f90 b/krylov/psb_dcg.F90 similarity index 87% rename from krylov/psb_dcg.f90 rename to krylov/psb_dcg.F90 index 466e601c0..80fa348f5 100644 --- a/krylov/psb_dcg.f90 +++ b/krylov/psb_dcg.F90 @@ -95,7 +95,7 @@ ! estimate of) residual. ! ! -subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) +subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) use psb_base_mod use psb_prec_mod use psb_krylov_mod, psb_protect_name => psb_dcg @@ -111,15 +111,17 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) integer, intent(out) :: info Integer, Optional, Intent(in) :: itmax, itrace, istop Integer, Optional, Intent(out) :: iter - Real(psb_dpk_), Optional, Intent(out) :: err + Real(psb_dpk_), Optional, Intent(out) :: err,cond !!$ Local data - real(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:) + real(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:), td(:),tu(:),eig(:),ewrk(:) + integer, allocatable :: ibl(:), ispl(:), iwrk(:) real(psb_dpk_), pointer :: q(:), p(:), r(:), z(:), w(:) - real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma + real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old integer :: itmax_, istop_, naux, mglob, it, itx, itrace_,& - & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5) + & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5), ieg,nspl, istebz integer :: debug_level, debug_unit type(psb_itconv_type) :: stopdat + logical :: do_cond character(len=20) :: name character(len=*), parameter :: methdname='CG' @@ -138,6 +140,7 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) n_row = psb_cd_get_local_rows(desc_a) n_col = psb_cd_get_local_cols(desc_a) + if (present(istop)) then istop_ = istop else @@ -181,6 +184,19 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itrace_ = 0 end if + do_cond=present(cond) + if (do_cond) then + istebz = 0 + allocate(td(itmax_),tu(itmax_), eig(itmax_),& + & ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),& + & stat=info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + end if + itx=0 ! Ensure global coherence for convergence checks. @@ -239,8 +255,18 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & ': CG Iteration breakdown sigma' exit iteration endif - + alpha_old = alpha alpha = rho/sigma + if (do_cond) then + istebz = istebz + 1 + if (istebz == 1) then + td(istebz) = done/alpha + else + td(istebz) = done/alpha + beta/alpha_old + tu(istebz-1) = sqrt(beta)/alpha_old + end if + end if + call psb_geaxpby(alpha,p,done,x,desc_a,info) call psb_geaxpby(-alpha,q,done,r,desc_a,info) @@ -253,6 +279,24 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end do iteration end do restart + if (do_cond) then + if (me==0) then +#if defined(HAVE_LAPACK) + call dstebz('A','E',istebz,dzero,dzero,0,0,-done,td,tu,& + & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) + if (info < 0) then + call psb_errpush(4013,name,a_err='dstebz',i_err=(/info,0,0,0,0/)) + info = 4013 + goto 9999 + end if + cond = eig(ieg)/eig(1) +#else + cond = -1.0 +#endif + info = 0 + end if + call psb_bcast(ictxt,cond,root=0) + end if call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) call psb_gefree(wwrk,desc_a,info) diff --git a/krylov/psb_krylov_mod.f90 b/krylov/psb_krylov_mod.f90 index d4e29415b..95c048d82 100644 --- a/krylov/psb_krylov_mod.f90 +++ b/krylov/psb_krylov_mod.f90 @@ -39,12 +39,27 @@ Module psb_krylov_mod public interface psb_krylov - module procedure psb_dkrylov, psb_zkrylov + module procedure psb_skrylov, psb_dkrylov, psb_ckrylov, psb_zkrylov end interface interface psb_cg + subroutine psb_scg(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop,cond) + use psb_base_mod + use psb_prec_mod + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_sprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err,cond + end subroutine psb_scg subroutine psb_dcg(a,prec,b,x,eps,& - & desc_a,info,itmax,iter,err,itrace,istop) + & desc_a,info,itmax,iter,err,itrace,istop,cond) use psb_base_mod use psb_prec_mod type(psb_dspmat_type), intent(in) :: a @@ -56,8 +71,23 @@ Module psb_krylov_mod integer, intent(out) :: info integer, optional, intent(in) :: itmax, itrace,istop integer, optional, intent(out) :: iter - real(psb_dpk_), optional, intent(out) :: err + real(psb_dpk_), optional, intent(out) :: err,cond end subroutine psb_dcg + subroutine psb_ccg(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: b(:) + complex(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_cprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_ccg subroutine psb_zcg(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod @@ -76,30 +106,60 @@ Module psb_krylov_mod end interface interface psb_bicg + subroutine psb_sbicg(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_sprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_sbicg subroutine psb_dbicg(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), intent(in) :: b(:) - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), intent(in) :: eps + real(psb_dpk_), intent(in) :: b(:) + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), intent(in) :: eps type(psb_dprec_type), intent(in) :: prec integer, intent(out) :: info integer, optional, intent(in) :: itmax, itrace,istop integer, optional, intent(out) :: iter real(psb_dpk_), optional, intent(out) :: err end subroutine psb_dbicg + subroutine psb_cbicg(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: b(:) + complex(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_cprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_cbicg subroutine psb_zbicg(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod use psb_prec_mod type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), intent(in) :: b(:) - complex(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), intent(in) :: eps + complex(psb_dpk_), intent(in) :: b(:) + complex(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), intent(in) :: eps type(psb_zprec_type), intent(in) :: prec integer, intent(out) :: info integer, optional, intent(in) :: itmax, itrace,istop @@ -109,6 +169,21 @@ Module psb_krylov_mod end interface interface psb_bicgstab + subroutine psb_scgstab(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_sprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_scgstab subroutine psb_dcgstab(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod @@ -124,6 +199,21 @@ Module psb_krylov_mod integer, optional, intent(out) :: iter real(psb_dpk_), optional, intent(out) :: err end subroutine psb_dcgstab + subroutine psb_ccgstab(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: b(:) + complex(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_cprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_ccgstab subroutine psb_zcgstab(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod @@ -142,6 +232,21 @@ Module psb_krylov_mod end interface interface psb_bicgstabl + Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err, itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_sprec_type), intent(in) :: prec + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err + end subroutine psb_scgstabl Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err, itrace,irst,istop) use psb_base_mod @@ -157,6 +262,21 @@ Module psb_krylov_mod Integer, Optional, Intent(out) :: iter Real(psb_dpk_), Optional, Intent(out) :: err end subroutine psb_dcgstabl + Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err + end subroutine psb_ccgstabl Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) use psb_base_mod @@ -175,6 +295,21 @@ Module psb_krylov_mod end interface interface psb_rgmres + Subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_sprec_type), intent(in) :: prec + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err + end subroutine psb_srgmres Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) use psb_base_mod @@ -190,6 +325,21 @@ Module psb_krylov_mod Integer, Optional, Intent(out) :: iter Real(psb_dpk_), Optional, Intent(out) :: err end subroutine psb_drgmres + Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err + end subroutine psb_crgmres Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) use psb_base_mod @@ -208,6 +358,21 @@ Module psb_krylov_mod end interface interface psb_cgs + subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_scgs subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) use psb_base_mod @@ -223,6 +388,21 @@ Module psb_krylov_mod integer, optional, intent(out) :: iter real(psb_dpk_), optional, intent(out) :: err end subroutine psb_dcgs + subroutine psb_ccgs(a,prec,b,x,eps,& + & desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: b(:) + complex(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + type(psb_cprec_type), intent(in) :: prec + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace,istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err + end subroutine psb_ccgs subroutine psb_zcgs(a,prec,b,x,eps,& & desc_a,info,itmax,iter,err,itrace,istop) use psb_base_mod @@ -243,15 +423,17 @@ Module psb_krylov_mod interface psb_init_conv - module procedure psb_d_init_conv, psb_z_init_conv + module procedure psb_s_init_conv, psb_d_init_conv,& + & psb_c_init_conv, psb_z_init_conv end interface interface psb_check_conv - module procedure psb_d_check_conv, psb_z_check_conv + module procedure psb_s_check_conv, psb_d_check_conv,& + & psb_c_check_conv, psb_z_check_conv end interface interface psb_end_conv - module procedure psb_end_conv + module procedure psb_d_end_conv end interface integer, parameter, private :: bni_=1, rni_=2, ani_=3, xni_=4, bn2_=5, xn2_=6 @@ -260,11 +442,129 @@ Module psb_krylov_mod integer, parameter, private :: ivsz_=16 type psb_itconv_type private - integer :: controls(ivsz_) + integer :: controls(ivsz_) real(psb_dpk_) :: values(ivsz_) end type psb_itconv_type contains + + ! Subroutine: psb_skrylov + ! + ! Front-end for the Krylov subspace iterations, real version + ! + ! Arguments: + ! + ! methd - character The specific method; can take the values: + ! CG + ! CGS + ! BICG + ! BICGSTAB + ! BICGSTABL + ! RGMRES + ! + ! a - type(psb_sspmat_type) Input: sparse matrix containing A. + ! prec - type(psb_sprec_type) Input: preconditioner + ! b - real,dimension(:) Input: vector containing the + ! right hand side B + ! x - real,dimension(:) Input/Output: vector containing the + ! initial guess and final solution X. + ! eps - real Input: Stopping tolerance; the iteration is + ! stopped when the error + ! estimate |err| <= eps + ! desc_a - type(psb_desc_type). Input: The communication descriptor. + ! info - integer. Output: Return code + ! + ! itmax - integer(optional) Input: maximum number of iterations to be + ! performed. + ! iter - integer(optional) Output: how many iterations have been + ! performed. + ! err - real (optional) Output: error estimate on exit + ! itrace - integer(optional) Input: print an informational message + ! with the error estimate every itrace + ! iterations + ! irst - integer(optional) Input: restart parameter for RGMRES and + ! BICGSTAB(L) methods + ! istop - integer(optional) Input: stopping criterion, or how + ! to estimate the error. + ! 1: err = |r|/|b| + ! 2: err = |r|/(|a||x|+|b|) + ! where r is the (preconditioned, recursive + ! estimate of) residual + ! + + Subroutine psb_skrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop,cond) + + use psb_base_mod + use psb_prec_mod + + character(len=*) :: method + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_sprec_type), intent(in) :: prec + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err,cond + + integer :: ictxt,me,np,err_act + character(len=20) :: name + + info = 0 + name = 'psb_krylov' + call psb_erractionsave(err_act) + + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + select case(psb_toupper(method)) + case('CG') + call psb_cg(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop,cond) + case('CGS') + call psb_cgs(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('BICG') + call psb_bicg(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('BICGSTAB') + call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('RGMRES') + call psb_rgmres(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + case('BICGSTABL') + call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + case default + if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + & ', defaulting to BiCGSTAB' + call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + end select + + if(info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + 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 + + end subroutine psb_skrylov + + ! Subroutine: psb_dkrylov ! ! Front-end for the Krylov subspace iterations, real version @@ -309,7 +609,7 @@ contains ! estimate of) residual ! - Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop,cond) use psb_base_mod use psb_prec_mod @@ -324,7 +624,7 @@ contains integer, intent(out) :: info Integer, Optional, Intent(in) :: itmax, itrace, irst,istop Integer, Optional, Intent(out) :: iter - Real(psb_dpk_), Optional, Intent(out) :: err + Real(psb_dpk_), Optional, Intent(out) :: err,cond integer :: ictxt,me,np,err_act character(len=20) :: name @@ -341,7 +641,7 @@ contains select case(psb_toupper(method)) case('CG') call psb_cg(a,prec,b,x,eps,desc_a,info,& - &itmax,iter,err,itrace,istop) + &itmax,iter,err,itrace,istop,cond) case('CGS') call psb_cgs(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) @@ -382,6 +682,122 @@ contains end subroutine psb_dkrylov + ! + ! Subroutine: psb_ckrylov + ! + ! Front-end for the Krylov subspace iterations, complexversion + ! + ! Arguments: + ! + ! methd - character The specific method; can take the values: + ! CG + ! CGS + ! BICG + ! BICGSTAB + ! BICGSTABL + ! RGMRES + ! + ! a - type(psb_cspmat_type) Input: sparse matrix containing A. + ! prec - type(psb_cprec_type) Input: preconditioner + ! b - complex,dimension(:) Input: vector containing the + ! right hand side B + ! x - complex,dimension(:) Input/Output: vector containing the + ! initial guess and final solution X. + ! eps - real Input: Stopping tolerance; the iteration is + ! stopped when the error + ! estimate |err| <= eps + ! + ! desc_a - type(psb_desc_type). Input: The communication descriptor. + ! info - integer. Output: Return code + ! + ! itmax - integer(optional) Input: maximum number of iterations to be + ! performed. + ! iter - integer(optional) Output: how many iterations have been + ! performed. + ! err - real (optional) Output: error estimate on exit + ! itrace - integer(optional) Input: print an informational message + ! with the error estimate every itrace + ! iterations + ! irst - integer(optional) Input: restart parameter for RGMRES and + ! BICGSTAB(L) methods + ! istop - integer(optional) Input: stopping criterion, or how + ! to estimate the error. + ! 1: err = |r|/|b| + ! 2: err = |r|/(|a||x|+|b|) + ! where r is the (preconditioned, recursive + ! estimate of) residual + ! + Subroutine psb_ckrylov(method,a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + character(len=*) :: method + Type(psb_cspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_), Intent(in) :: b(:) + complex(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err + + integer :: ictxt,me,np,err_act + character(len=20) :: name + + info = 0 + name = 'psb_krylov' + call psb_erractionsave(err_act) + + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + select case(psb_toupper(method)) + case('CG') + call psb_cg(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('CGS') + call psb_cgs(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('BICG') + call psb_bicg(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + case('BICGSTAB') + call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& + & itmax,iter,err,itrace,istop) + case('RGMRES') + call psb_rgmres(a,prec,b,x,eps,desc_a,info,& + & itmax,iter,err,itrace,irst,istop) + case('BICGSTABL') + call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,irst,istop) + case default + if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + & ', defaulting to BiCGSTAB' + call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& + &itmax,iter,err,itrace,istop) + end select + + if(info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + 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 + + end subroutine psb_ckrylov + ! ! Subroutine: psb_zkrylov ! @@ -519,7 +935,7 @@ contains implicit none character(len=*), intent(in) :: methdname integer, intent(in) :: me, itx, itrace - real(psb_dpk_), intent(in) :: errnum, errden, eps + real(psb_dpk_), intent(in) :: errnum, errden, eps character(len=*), parameter :: fmt='(a18,1x,i4,3(2x,es15.9))' integer, parameter :: outlen=18 character(len=len(methdname)) :: mname @@ -574,6 +990,73 @@ contains end subroutine log_end + subroutine psb_s_init_conv(methdname,stopc,trace,itmax,a,b,eps,desc_a,stopdat,info) + use psb_base_mod + implicit none + character(len=*), intent(in) :: methdname + integer, intent(in) :: stopc, trace,itmax + type(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: b(:), eps + type(psb_desc_type), intent(in) :: desc_a + type(psb_itconv_type) :: stopdat + integer, intent(out) :: info + + integer :: ictxt, me, np, err_act + character(len=20) :: name + + info = 0 + name = 'psb_init_conv' + call psb_erractionsave(err_act) + + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + stopdat%controls(:) = 0 + stopdat%values(:) = 0.0d0 + + stopdat%controls(stopc_) = stopc + stopdat%controls(trace_) = trace + stopdat%controls(itmax_) = itmax + + select case(stopdat%controls(stopc_)) + case (1) + stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) + if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + + case (2) + stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) + + case default + info=5001 + call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) + goto 9999 + end select + if (info /= 0) then + call psb_errpush(4001,name,a_err="Init conv check data") + goto 9999 + end if + + stopdat%values(eps_) = eps + stopdat%values(errnum_) = dzero + stopdat%values(errden_) = done + + if ((stopdat%controls(trace_) > 0).and. (me == 0))& + & call log_header(methdname) + + 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 + + end subroutine psb_s_init_conv + subroutine psb_d_init_conv(methdname,stopc,trace,itmax,a,b,eps,desc_a,stopdat,info) use psb_base_mod implicit none @@ -641,6 +1124,74 @@ contains end subroutine psb_d_init_conv + subroutine psb_c_init_conv(methdname,stopc,trace,itmax,a,b,eps,desc_a,stopdat,info) + use psb_base_mod + implicit none + character(len=*), intent(in) :: methdname + integer, intent(in) :: stopc, trace, itmax + type(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(in) :: eps + type(psb_desc_type), intent(in) :: desc_a + type(psb_itconv_type) :: stopdat + integer, intent(out) :: info + + integer :: ictxt, me, np, err_act + character(len=20) :: name + + info = 0 + name = 'psb_init_conv' + call psb_erractionsave(err_act) + + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + stopdat%controls(:) = 0 + stopdat%values(:) = 0.0d0 + + stopdat%controls(stopc_) = stopc + stopdat%controls(trace_) = trace + stopdat%controls(itmax_) = itmax + + select case(stopdat%controls(stopc_)) + case (1) + stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) + if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + + case (2) + stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) + + case default + info=5001 + call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) + goto 9999 + end select + if (info /= 0) then + call psb_errpush(4001,name,a_err="Init conv check data") + goto 9999 + end if + + stopdat%values(eps_) = eps + stopdat%values(errnum_) = dzero + stopdat%values(errden_) = done + + if ((stopdat%controls(trace_) > 0).and. (me == 0))& + & call log_header(methdname) + + 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 + + end subroutine psb_c_init_conv + subroutine psb_z_init_conv(methdname,stopc,trace,itmax,a,b,eps,desc_a,stopdat,info) use psb_base_mod implicit none @@ -710,6 +1261,79 @@ contains end subroutine psb_z_init_conv + function psb_s_check_conv(methdname,it,x,r,desc_a,stopdat,info) + use psb_base_mod + implicit none + character(len=*), intent(in) :: methdname + integer, intent(in) :: it + real(psb_spk_), intent(in) :: x(:), r(:) + type(psb_desc_type), intent(in) :: desc_a + type(psb_itconv_type) :: stopdat + logical :: psb_s_check_conv + integer, intent(out) :: info + + integer :: ictxt, me, np, err_act + character(len=20) :: name + + info = 0 + name = 'psb_check_conv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + + psb_s_check_conv = .false. + + select case(stopdat%controls(stopc_)) + case(1) + stopdat%values(rni_) = psb_geamax(r,desc_a,info) + if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + stopdat%values(errnum_) = stopdat%values(rni_) + stopdat%values(errden_) = & + & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) + case(2) + stopdat%values(rn2_) = psb_genrm2(r,desc_a,info) + stopdat%values(errnum_) = stopdat%values(rn2_) + stopdat%values(errden_) = stopdat%values(bn2_) + + case default + info=4001 + call psb_errpush(info,name,a_err="Control data in stopdat messed up!") + goto 9999 + end select + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + if (stopdat%values(errden_) == dzero) then + psb_s_check_conv = (stopdat%values(errnum_) <= stopdat%values(eps_)) + else + psb_s_check_conv = & + & (stopdat%values(errnum_) <= stopdat%values(eps_)*stopdat%values(errden_)) + end if + + psb_s_check_conv = (psb_s_check_conv.or.(stopdat%controls(itmax_) <= it)) + + if ( (stopdat%controls(trace_) > 0).and.& + & ((mod(it,stopdat%controls(trace_))==0).or.psb_s_check_conv)) then + call log_conv(methdname,me,it,1,stopdat%values(errnum_),& + & stopdat%values(errden_),stopdat%values(eps_)) + end if + + 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 + + end function psb_s_check_conv + function psb_d_check_conv(methdname,it,x,r,desc_a,stopdat,info) use psb_base_mod implicit none @@ -784,6 +1408,78 @@ contains end function psb_d_check_conv + function psb_c_check_conv(methdname,it,x,r,desc_a,stopdat,info) + use psb_base_mod + implicit none + character(len=*), intent(in) :: methdname + integer, intent(in) :: it + complex(psb_spk_), intent(in) :: x(:), r(:) + type(psb_desc_type), intent(in) :: desc_a + type(psb_itconv_type) :: stopdat + logical :: psb_c_check_conv + integer, intent(out) :: info + + integer :: ictxt, me, np, err_act + character(len=20) :: name + + info = 0 + name = 'psb_check_conv' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt,me,np) + psb_c_check_conv = .false. + + select case(stopdat%controls(stopc_)) + case(1) + stopdat%values(rni_) = psb_geamax(r,desc_a,info) + if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + stopdat%values(errnum_) = stopdat%values(rni_) + stopdat%values(errden_) = & + & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) + case(2) + stopdat%values(rn2_) = psb_genrm2(r,desc_a,info) + stopdat%values(errnum_) = stopdat%values(rn2_) + stopdat%values(errden_) = stopdat%values(bn2_) + + case default + info=4001 + call psb_errpush(info,name,a_err="Control data in stopdat messed up!") + goto 9999 + end select + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + if (stopdat%values(errden_) == dzero) then + psb_c_check_conv = (stopdat%values(errnum_) <= stopdat%values(eps_)) + else + psb_c_check_conv = & + & (stopdat%values(errnum_) <= stopdat%values(eps_)*stopdat%values(errden_)) + end if + + psb_c_check_conv = (psb_c_check_conv.or.(stopdat%controls(itmax_) <= it)) + + if ( (stopdat%controls(trace_) > 0).and.& + & ((mod(it,stopdat%controls(trace_))==0).or.psb_c_check_conv)) then + call log_conv(methdname,me,it,1,stopdat%values(errnum_),& + & stopdat%values(errden_),stopdat%values(eps_)) + end if + + 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 + + end function psb_c_check_conv + function psb_z_check_conv(methdname,it,x,r,desc_a,stopdat,info) use psb_base_mod implicit none @@ -856,7 +1552,7 @@ contains end function psb_z_check_conv - subroutine psb_end_conv(methdname,it,desc_a,stopdat,info,err,iter) + subroutine psb_d_end_conv(methdname,it,desc_a,stopdat,info,err,iter) use psb_base_mod implicit none character(len=*), intent(in) :: methdname @@ -868,7 +1564,7 @@ contains integer, optional, intent(out) :: iter integer :: ictxt, me, np, err_act - real(psb_dpk_) :: errnum, errden, eps + real(psb_dpk_) :: errnum, errden, eps character(len=20) :: name info = 0 @@ -877,16 +1573,12 @@ contains ictxt = psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) - errnum = stopdat%values(errnum_) errden = stopdat%values(errden_) eps = stopdat%values(eps_) - call log_end(methdname,me,it,errnum,errden,eps,err,iter) - - end subroutine psb_end_conv - + end subroutine psb_d_end_conv end module psb_krylov_mod diff --git a/krylov/psb_sbicg.f90 b/krylov/psb_sbicg.f90 new file mode 100644 index 000000000..6dc032284 --- /dev/null +++ b/krylov/psb_sbicg.f90 @@ -0,0 +1,337 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! File: psb_sbicg.f90 +! +! Subroutine: psb_sbicg +! This subroutine implements the BiCG method. +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_sbicg + implicit none + +!!$ parameters + type(psb_sspmat_type), intent(in) :: a + type(psb_sprec_type), intent(in) :: prec + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: b(:) + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(in) :: eps + integer, intent(out) :: info + integer, optional, intent(in) :: itmax, itrace, istop + integer, optional, intent(out) :: iter + real(psb_spk_), optional, intent(out) :: err +!!$ local data + real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + real(psb_spk_), pointer :: ww(:), q(:),& + & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:) + integer :: int_err(5) + integer ::itmax_, naux, mglob, it, itrace_,& + & np,me, n_row, n_col, istop_, err_act + integer :: debug_level, debug_unit + logical, parameter :: exchange=.true., noexchange=.false. + integer, parameter :: irmax = 8 + integer :: itx, isvch, ictxt + real(psb_spk_) :: alpha, beta, rho, rho_old, sigma + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name,ch_err + character(len=*), parameter :: methdname='BiCG' + + info = 0 + name = 'psb_sbicg' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + ! + ! istop_ = 1: normwise backward error, infinity norm + ! istop_ = 2: ||r||/||b|| norm 2 + ! + + if ((istop_ < 1 ).or.(istop_ > 2 ) ) then + info=5001 + int_err=istop_ + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + + naux=4*n_col + + allocate(aux(naux),stat=info) + if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) + if (info == 0) call psb_geasb(wwrk,desc_a,info) + if(info /= 0) then + info=4011 + ch_err='psb_asb' + err=info + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + q => wwrk(:,1) + qt => wwrk(:,2) + r => wwrk(:,3) + rt => wwrk(:,4) + p => wwrk(:,5) + pt => wwrk(:,6) + z => wwrk(:,7) + zt => wwrk(:,8) + ww => wwrk(:,9) + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + itx = 0 + + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + restart: do +!!$ +!!$ r0 = b-ax0 +!!$ + if (itx >= itmax_) exit restart + it = 0 + call psb_geaxpby(sone,b,szero,r,desc_a,info) + if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),' Done spmm',info + if (info == 0) call psb_geaxpby(sone,r,szero,rt,desc_a,info) + if(info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = szero + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + it = it + 1 + itx = itx + 1 + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx + + call psb_precaply(prec,r,z,desc_a,info,work=aux) + if (info == 0) call psb_precaply(prec,rt,zt,desc_a,info,trans='t',work=aux) + + rho_old = rho + rho = psb_gedot(rt,z,desc_a,info) + if (rho==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown r',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(sone,z,szero,p,desc_a,info) + call psb_geaxpby(sone,zt,szero,pt,desc_a,info) + else + beta = (rho/rho_old) + call psb_geaxpby(sone,z,beta,p,desc_a,info) + call psb_geaxpby(sone,zt,beta,pt,desc_a,info) + end if + + call psb_spmm(sone,a,p,szero,q,desc_a,info,& + & work=aux) + call psb_spmm(sone,a,pt,szero,qt,desc_a,info,& + & work=aux,trans='t') + + sigma = psb_gedot(pt,q,desc_a,info) + if (sigma==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown s1', sigma + exit iteration + endif + + alpha = rho/sigma + + + call psb_geaxpby(alpha,p,sone,x,desc_a,info) + call psb_geaxpby(-alpha,q,sone,r,desc_a,info) + call psb_geaxpby(-alpha,qt,sone,rt,desc_a,info) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux, stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sbicg + + diff --git a/krylov/psb_scg.F90 b/krylov/psb_scg.F90 new file mode 100644 index 000000000..f66018753 --- /dev/null +++ b/krylov/psb_scg.F90 @@ -0,0 +1,329 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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_scg.f90 +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_scg.f90 +! +! Subroutine: psb_scg +! This subroutine implements the Conjugate Gradient method. +! +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_scg + implicit none + +!!$ Parameters + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err,cond +!!$ Local data + real(psb_spk_), allocatable, target :: aux(:), wwrk(:,:), td(:),tu(:),eig(:),ewrk(:) + integer, allocatable :: ibl(:), ispl(:), iwrk(:) + real(psb_spk_), pointer :: q(:), p(:), r(:), z(:), w(:) + real(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old + integer :: itmax_, istop_, naux, mglob, it, itx, itrace_,& + & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5), ieg,nspl, istebz + real(psb_dpk_) :: derr + integer :: debug_level, debug_unit + type(psb_itconv_type) :: stopdat + logical :: do_cond + character(len=20) :: name + character(len=*), parameter :: methdname='CG' + + info = 0 + name = 'psb_scg' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + allocate(aux(naux), stat=info) + if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) + if (info == 0) call psb_geasb(wwrk,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + p => wwrk(:,1) + q => wwrk(:,2) + r => wwrk(:,3) + z => wwrk(:,4) + w => wwrk(:,5) + + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + do_cond=present(cond) + if (do_cond) then + istebz = 0 + allocate(td(itmax_),tu(itmax_), eig(itmax_),& + & ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),& + & stat=info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + end if + + itx=0 + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + restart: do +!!$ +!!$ r0 = b-Ax0 +!!$ + if (itx>= itmax_) exit restart + + it = 0 + call psb_geaxpby(sone,b,szero,r,desc_a,info) + if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = szero + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + + it = it + 1 + itx = itx + 1 + + call psb_precaply(prec,r,z,desc_a,info,work=aux) + rho_old = rho + rho = psb_gedot(r,z,desc_a,info) + + if (it==1) then + call psb_geaxpby(sone,z,szero,p,desc_a,info) + else + if (rho_old==szero) then + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': CG Iteration breakdown rho' + exit iteration + endif + beta = rho/rho_old + call psb_geaxpby(sone,z,beta,p,desc_a,info) + end if + + call psb_spmm(sone,a,p,szero,q,desc_a,info,work=aux) + sigma = psb_gedot(p,q,desc_a,info) + if (sigma==szero) then + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': CG Iteration breakdown sigma' + exit iteration + endif + alpha_old = alpha + alpha = rho/sigma + if (do_cond) then + istebz = istebz + 1 + if (istebz == 1) then + td(istebz) = sone/alpha + else + td(istebz) = sone/alpha + beta/alpha_old + tu(istebz-1) = sqrt(beta)/alpha_old + end if + end if + + call psb_geaxpby(alpha,p,sone,x,desc_a,info) + call psb_geaxpby(-alpha,q,sone,r,desc_a,info) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + if (do_cond) then + if (me==0) then +#if defined(HAVE_LAPACK) + call sstebz('A','E',istebz,szero,szero,0,0,-sone,td,tu,& + & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) + if (info < 0) then + call psb_errpush(4013,name,a_err='sstebz',i_err=(/info,0,0,0,0/)) + info = 4013 + goto 9999 + end if + cond = eig(ieg)/eig(1) +#else + cond = -1.0 +#endif + info = 0 + end if + call psb_bcast(ictxt,cond,root=0) + end if + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + call psb_gefree(wwrk,desc_a,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_scg + + diff --git a/krylov/psb_scgs.f90 b/krylov/psb_scgs.f90 new file mode 100644 index 000000000..bb0ac487c --- /dev/null +++ b/krylov/psb_scgs.f90 @@ -0,0 +1,329 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_scgs.f90 +! +! Subroutine: psb_scgs +! Implements the Conjugate Gradient Squared method. +! +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_scgs + implicit none + +!!$ parameters + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_sprec_type), Intent(in) :: prec + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + Real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + Real(psb_spk_), Pointer :: ww(:), q(:),& + & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:) + Integer :: itmax_, naux, mglob, it, itrace_,int_err(5),& + & np,me, n_row, n_col,istop_, err_act + Integer :: itx, isvch, ictxt + integer :: debug_level, debug_unit + Real(psb_spk_) :: alpha, beta, rho, rho_old, sigma + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name + character(len=*), parameter :: methdname='CGS' + + info = 0 + name = 'psb_scgs' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + If (Present(istop)) Then + istop_ = istop + Else + istop_ = 1 + Endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + Allocate(aux(naux),stat=info) + if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == 0) Call psb_geasb(wwrk,desc_a,info) + if (info /= 0) Then + info=4011 + call psb_errpush(info,name) + goto 9999 + End If + + q => wwrk(:,1) + qt => wwrk(:,2) + r => wwrk(:,3) + rt => wwrk(:,4) + p => wwrk(:,5) + v => wwrk(:,6) + uv => wwrk(:,7) + z => wwrk(:,8) + f => wwrk(:,9) + s => wwrk(:,10) + ww => wwrk(:,11) + + + If (Present(itmax)) Then + itmax_ = itmax + Else + itmax_ = 1000 + Endif + + If (Present(itrace)) Then + itrace_ = itrace + Else + itrace_ = 0 + End If + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + itx = 0 + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + restart: Do +!!$ +!!$ r0 = b-ax0 +!!$ + if (itx >= itmax_) exit restart + it = 0 + call psb_geaxpby(sone,b,szero,r,desc_a,info) + if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info == 0) call psb_geaxpby(sone,r,szero,rt,desc_a,info) + if (info/=0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + rho = szero + + iteration: do + it = it + 1 + itx = itx + 1 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx + + rho_old = rho + rho = psb_gedot(rt,r,desc_a,info) + + if (rho==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown r',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(sone,r,szero,uv,desc_a,info) + if (info == 0) call psb_geaxpby(sone,r,szero,p,desc_a,info) + else + beta = (rho/rho_old) + call psb_geaxpby(sone,r,szero,uv,desc_a,info) + if (info == 0) call psb_geaxpby(beta,q,sone,uv,desc_a,info) + if (info == 0) call psb_geaxpby(sone,q,beta,p,desc_a,info) + if (info == 0) call psb_geaxpby(sone,uv,beta,p,desc_a,info) + end if + + if (info == 0) call psb_precaply(prec,p,f,desc_a,info,work=aux) + + if (info == 0) call psb_spmm(sone,a,f,szero,v,desc_a,info,& + & work=aux) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='First loop part ') + goto 9999 + end if + + sigma = psb_gedot(rt,v,desc_a,info) + if (sigma==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration breakdown s1', sigma + exit iteration + endif + + alpha = rho/sigma + + if (info == 0) call psb_geaxpby(sone,uv,szero,q,desc_a,info) + if (info == 0) call psb_geaxpby(-alpha,v,sone,q,desc_a,info) + if (info == 0) call psb_geaxpby(sone,uv,szero,s,desc_a,info) + if (info == 0) call psb_geaxpby(sone,q,sone,s,desc_a,info) + + if (info == 0) call psb_precaply(prec,s,z,desc_a,info,work=aux) + + if (info == 0) call psb_geaxpby(alpha,z,sone,x,desc_a,info) + + if (info == 0) call psb_spmm(sone,a,z,szero,qt,desc_a,info,& + & work=aux) + + if (info == 0) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='X update ') + goto 9999 + end if + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +End Subroutine psb_scgs diff --git a/krylov/psb_scgstab.F90 b/krylov/psb_scgstab.F90 new file mode 100644 index 000000000..6a6f4fda2 --- /dev/null +++ b/krylov/psb_scgstab.F90 @@ -0,0 +1,406 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_scgstab.f90 +! +! Subroutine: psb_scgstab +! This subroutine implements the BiCG Stabilized method. +! +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! +! +! +Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_scgstab + Implicit None +!!$ parameters + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ Local data + Real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) + Real(psb_spk_), Pointer :: q(:),& + & r(:), p(:), v(:), s(:), t(:), z(:), f(:) + Integer :: itmax_, naux, mglob, it,itrace_,& + & np,me, n_row, n_col + integer :: debug_level, debug_unit + Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. + Integer, Parameter :: irmax = 8 + Integer :: itx, isvch, ictxt, err_act + Integer :: istop_ + real(psb_dpk_) :: derr + Real(psb_spk_) :: alpha, beta, omega + Real(psb_dpk_) :: rho, rho_old, sigma, tau + type(psb_itconv_type) :: stopdat + +#ifdef MPE_KRYLOV + Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme + Integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event +#endif + character(len=20) :: name + character(len=*), parameter :: methdname='BiCGStab' + + info = 0 + name = 'psb_scgstab' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + +#ifdef MPE_KRYLOV + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(irank,ictxt,me) + istpb = mpe_log_get_event_number() + istpe = mpe_log_get_event_number() + ifctb = mpe_log_get_event_number() + ifcte = mpe_log_get_event_number() + immb = mpe_log_get_event_number() + imme = mpe_log_get_event_number() + if (irank==0) then + info = mpe_describe_state(istpb,istpe,"Solver","WhiteSmoke") + info = mpe_describe_state(ifctb,ifcte,"PREC","SteelBlue") + info = mpe_describe_state(immb,imme,"SPMM","DarkOrange") + endif +#endif + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + If (Present(istop)) Then + istop_ = istop + Else + istop_ = 1 + Endif + ! + ! ISTOP_ = 1: Normwise backward error, infinity norm + ! ISTOP_ = 2: ||r||/||b|| norm 2 + ! + +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( istpb, 0, "st CGSTAB" ) +#endif + + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + naux=6*n_col + allocate(aux(naux),stat=info) + if (info == 0) call psb_geall(wwrk,desc_a,info,n=8) + if (info == 0) call psb_geasb(wwrk,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + End If + + Q => WWRK(:,1) + R => WWRK(:,2) + P => WWRK(:,3) + V => WWRK(:,4) + F => WWRK(:,5) + S => WWRK(:,6) + T => WWRK(:,7) + Z => WWRK(:,8) + + If (Present(itmax)) Then + itmax_ = itmax + Else + itmax_ = 1000 + Endif + + If (Present(itrace)) Then + itrace_ = itrace + Else + itrace_ = 0 + End If + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + itx = 0 + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + restart: Do + + if (itx >= itmax_) exit restart + + it = 0 + call psb_geaxpby(sone,b,szero,r,desc_a,info) +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( immb, 0, "st SPMM" ) +#endif + if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( imme, 0, "ed SPMM" ) +#endif + if (info == 0) call psb_geaxpby(sone,r,szero,q,desc_a,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='Init residual') + goto 9999 + end if + + ! Perhaps we already satisfy the convergence criterion... + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + rho = szero + + iteration: Do + it = it + 1 + itx = itx + 1 + + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration: ',itx + + rho_old = rho + rho = psb_gexdot(q,r,desc_a,info) + + if (rho==dzero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown R',rho + exit iteration + endif + + if (it==1) then + call psb_geaxpby(sone,r,szero,p,desc_a,info) + else + beta = (rho/rho_old)*(alpha/omega) + call psb_geaxpby(-omega,v,sone,p,desc_a,info) + call psb_geaxpby(sone,r,beta,p,desc_a,info) + End If + +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( ifctb, 0, "st PREC" ) +#endif + call psb_precaply(prec,p,f,desc_a,info,work=aux) +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) + imerr = MPE_Log_event( immb, 0, "st SPMM" ) +#endif + call psb_spmm(sone,a,f,szero,v,desc_a,info,& + & work=aux) +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( imme, 0, "ed SPMM" ) +#endif + + sigma = psb_gexdot(q,v,desc_a,info) + if (sigma==dzero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown S1', sigma + exit iteration + endif + + alpha = rho/sigma + call psb_geaxpby(sone,r,szero,s,desc_a,info) + if (info == 0) call psb_geaxpby(-alpha,v,sone,s,desc_a,info) + + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_geaxpby') + goto 9999 + end if + +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( ifctb, 0, "st PREC" ) +#endif + call psb_precaply(prec,s,z,desc_a,info,work=aux) + +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) + imerr = MPE_Log_event( immb, 0, "st SPMM" ) +#endif + if (info == 0) Call psb_spmm(sone,a,z,szero,t,desc_a,info,& + & work=aux) + +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( imme, 0, "ed SPMM" ) +#endif + if(info /= 0) then + call psb_errpush(4010,name,a_err='precaply/spmm') + goto 9999 + end if + + sigma = psb_gexdot(t,t,desc_a,info) + if (sigma==dzero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown S2', sigma + exit iteration + endif + + tau = psb_gexdot(t,s,desc_a,info) + omega = tau/sigma + + if (omega==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Iteration breakdown O',omega + exit iteration + endif + + call psb_geaxpby(alpha,f,sone,x,desc_a,info) + if (info == 0) call psb_geaxpby(omega,z,sone,x,desc_a,info) + if (info == 0) call psb_geaxpby(sone,s,szero,r,desc_a,info) + if (info == 0) call psb_geaxpby(-omega,t,sone,r,desc_a,info) + if (info /= 0) Then + call psb_errpush(4010,name,a_err='X/R update ') + goto 9999 + End If + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if(info/=0) then + call psb_errpush(info,name) + goto 9999 + end if +#ifdef MPE_KRYLOV + imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" ) +#endif + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + 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_scgstab + diff --git a/krylov/psb_scgstabl.f90 b/krylov/psb_scgstabl.f90 new file mode 100644 index 000000000..ffaa4303a --- /dev/null +++ b/krylov/psb_scgstabl.f90 @@ -0,0 +1,413 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ C [5] G. Sleijpen, D. Fokkema C +!!$ C BICGSTAB(L) for linear equations involving unsymmetric C +!!$ C matrices with complex spectrum C +!!$ C Electronic Trans. on Numer. Analysis, Vol. 1, pp. 11-32, C +!!$ C Sep. 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_scgstabl.f90 +! +! Subroutine: psb_scgstabl +! Implements the BICGSTAB(L) method +! +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! irst - integer(optional) Input: restart parameter L +! +! +! +Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_scgstabl + implicit none + +!!$ parameters + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + Real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:) + Real(psb_spk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), & + & s(:), t(:), z(:), f(:), gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:) + + Integer :: itmax_, naux, mglob, it, itrace_,& + & np,me, n_row, n_col, nl, err_act + Logical, Parameter :: exchange=.True., noexchange=.False. + Integer, Parameter :: irmax = 8 + Integer :: itx, i, isvch, ictxt,istop_,j, int_err(5) + integer :: debug_level, debug_unit + Real(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& + & omega + type(psb_itconv_type) :: stopdat + real(psb_dpk_) :: derr + character(len=20) :: name + character(len=*), parameter :: methdname='BiCGStab(L)' + + info = 0 + name = 'psb_scgstabl' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif + + if (present(itmax)) then + itmax_ = itmax + else + itmax_ = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + if (present(irst)) then + nl = irst + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'present: irst: ',irst,nl + else + nl = 1 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' not present: irst: ',irst,nl + endif + if (nl <=0 ) then + info=5001 + int_err(1)=nl + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X/B') + goto 9999 + end if + + naux=4*n_col + allocate(aux(naux),gamma(0:nl),gamma1(nl),& + &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) + + if (info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) + if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == 0) Call psb_geasb(wwrk,desc_a,info) + if (info == 0) Call psb_geasb(uh,desc_a,info) + if (info == 0) Call psb_geasb(rh,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + q => wwrk(:,1) + r => wwrk(:,2) + p => wwrk(:,3) + v => wwrk(:,4) + f => wwrk(:,5) + s => wwrk(:,6) + t => wwrk(:,7) + z => wwrk(:,8) + ww => wwrk(:,9) + rt0 => wwrk(:,10) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + + call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + itx = 0 + restart: do +!!$ +!!$ r0 = b-ax0 +!!$ + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it + if (itx >= itmax_) exit restart + + it = 0 + call psb_geaxpby(sone,b,szero,r,desc_a,info) + if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + + if (info == 0) call psb_precaply(prec,r,desc_a,info) + + if (info == 0) call psb_geaxpby(sone,r,szero,rt0,desc_a,info) + if (info == 0) call psb_geaxpby(sone,r,szero,rh(:,0),desc_a,info) + if (info == 0) call psb_geaxpby(szero,r,szero,uh(:,0),desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rho = sone + alpha = szero + omega = sone + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' on entry to amax: b: ',Size(b) + + if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + iteration: do + it = it + nl + itx = itx + nl + rho = -omega*rho + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' iteration: ',itx, rho,rh(1,0) + + do j = 0, nl -1 + If (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl + + rho_old = rho + rho = psb_gedot(rh(:,j),rt0,desc_a,info) + if (rho==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bi-cgstab iteration breakdown r',rho + exit iteration + endif + + beta = alpha*rho/rho_old + rho_old = rho + call psb_geaxpby(sone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info) + call psb_spmm(sone,a,uh(:,j),szero,uh(:,j+1),desc_a,info,work=aux) + + call psb_precaply(prec,uh(:,j+1),desc_a,info) + + gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) + + if (gamma(j)==szero) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bi-cgstab iteration breakdown s2',gamma(j) + exit iteration + endif + alpha = rho/gamma(j) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' bicg part: alpha=r/g ',alpha,rho,gamma(j) + + call psb_geaxpby(-alpha,uh(:,1:j+1),sone,rh(:,0:j),desc_a,info) + call psb_geaxpby(alpha,uh(:,0),sone,x,desc_a,info) + call psb_spmm(sone,a,rh(:,j),szero,rh(:,j+1),desc_a,info,work=aux) + + call psb_precaply(prec,rh(:,j+1),desc_a,info) + + enddo + + do j=1, nl + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' mod g-s part: ',j, nl,rh(1,0) + + do i=1, j-1 + taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info) + taum(i,j) = taum(i,j)/sigma(i) + call psb_geaxpby(-taum(i,j),rh(:,i),sone,rh(:,j),desc_a,info) + enddo + sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info) + gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info) + gamma1(j) = gamma1(j)/sigma(j) + enddo + + gamma(nl) = gamma1(nl) + omega = gamma(nl) + + do j=nl-1,1,-1 + gamma(j) = gamma1(j) + do i=j+1,nl + gamma(j) = gamma(j) - taum(j,i) * gamma(i) + enddo + enddo + + do j=1,nl-1 + gamma2(j) = gamma(j+1) + do i=j+1,nl-1 + gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1) + enddo + enddo + + call psb_geaxpby(gamma(1),rh(:,0),sone,x,desc_a,info) + call psb_geaxpby(-gamma1(nl),rh(:,nl),sone,rh(:,0),desc_a,info) + call psb_geaxpby(-gamma(nl),uh(:,nl),sone,uh(:,0),desc_a,info) + + do j=1, nl-1 + call psb_geaxpby(-gamma(j),uh(:,j),sone,uh(:,0),desc_a,info) + call psb_geaxpby(gamma2(j),rh(:,j),sone,x,desc_a,info) + call psb_geaxpby(-gamma1(j),rh(:,j),sone,rh(:,0),desc_a,info) + enddo + + if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart + if (info /= 0) Then + call psb_errpush(4011,name) + goto 9999 + End If + + end do iteration + end do restart + + call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,stat=info) + if (info == 0) call psb_gefree(wwrk,desc_a,info) + if (info == 0) call psb_gefree(uh,desc_a,info) + if (info == 0) call psb_gefree(rh,desc_a,info) + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +End Subroutine psb_scgstabl + + diff --git a/krylov/psb_srgmres.f90 b/krylov/psb_srgmres.f90 new file mode 100644 index 000000000..611040a16 --- /dev/null +++ b/krylov/psb_srgmres.f90 @@ -0,0 +1,520 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Contributions to this routine: +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR +!!$ +!!$ 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. +!!$ +!!$ +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!!$ C C +!!$ C References: C +!!$ C [1] Duff, I., Marrone, M., Radicati, G., and Vittoli, C. C +!!$ C Level 3 basic linear algebra subprograms for sparse C +!!$ C matrices: a user level interface C +!!$ C ACM Trans. Math. Softw., 23(3), 379-401, 1997. C +!!$ C C +!!$ C C +!!$ C [2] S. Filippone, M. Colajanni C +!!$ C PSBLAS: A library for parallel linear algebra C +!!$ C computation on sparse matrices C +!!$ C ACM Trans. on Math. Softw., 26(4), 527-550, Dec. 2000. C +!!$ C C +!!$ C [3] M. Arioli, I. Duff, M. Ruiz C +!!$ C Stopping criteria for iterative solvers C +!!$ C SIAM J. Matrix Anal. Appl., Vol. 13, pp. 138-144, 1992 C +!!$ C C +!!$ C C +!!$ C [4] R. Barrett et al C +!!$ C Templates for the solution of linear systems C +!!$ C SIAM, 1993 C +!!$ C C +!!$ C C +!!$ C [5] G. Sleijpen, D. Fokkema C +!!$ C BICGSTAB(L) for linear equations involving unsymmetric C +!!$ C matrices with complex spectrum C +!!$ C Electronic Trans. on Numer. Analysis, Vol. 1, pp. 11-32, C +!!$ C Sep. 1993 C +!!$ C C +!!$ C C +!!$ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! File: psb_srgmres.f90 +! +! Subroutine: psb_srgmres +! This subroutine implements the restarted GMRES method with right +! preconditioning. +! +! Arguments: +! +! a - type(psb_sspmat_type) Input: sparse matrix containing A. +! prec - type(psb_sprec_type) Input: preconditioner +! b - real,dimension(:) Input: vector containing the +! right hand side B +! x - real,dimension(:) Input/Output: vector containing the +! initial guess and final solution X. +! eps - real Input: Stopping tolerance; the iteration is +! stopped when the error estimate |err| <= eps +! desc_a - type(psb_desc_type). Input: The communication descriptor. +! info - integer. Output: Return code +! +! itmax - integer(optional) Input: maximum number of iterations to be +! performed. +! iter - integer(optional) Output: how many iterations have been +! performed. +! performed. +! err - real (optional) Output: error estimate on exit. If the +! denominator of the estimate is exactly +! 0, it is changed into 1. +! itrace - integer(optional) Input: print an informational message +! with the error estimate every itrace +! iterations +! istop - integer(optional) Input: stopping criterion, or how +! to estimate the error. +! 1: err = |r|/|b|; here the iteration is +! stopped when |r| <= eps * |b| +! 2: err = |r|/(|a||x|+|b|); here the iteration is +! stopped when |r| <= eps * (|a||x|+|b|) +! where r is the (preconditioned, recursive +! estimate of) residual. +! irst - integer(optional) Input: restart parameter +! +! +subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop) + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod, psb_protect_name => psb_srgmres + implicit none + +!!$ Parameters + Type(psb_sspmat_type), Intent(in) :: a + Type(psb_sprec_type), Intent(in) :: prec + Type(psb_desc_type), Intent(in) :: desc_a + Real(psb_spk_), Intent(in) :: b(:) + Real(psb_spk_), Intent(inout) :: x(:) + Real(psb_spk_), Intent(in) :: eps + integer, intent(out) :: info + Integer, Optional, Intent(in) :: itmax, itrace, irst,istop + Integer, Optional, Intent(out) :: iter + Real(psb_spk_), Optional, Intent(out) :: err +!!$ local data + Real(psb_spk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:) + Real(psb_spk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:) + Real(psb_spk_) :: scal, gm, rti, rti1 + Integer ::litmax, naux, mglob, it,k, itrace_,& + & np,me, n_row, n_col, nl, int_err(5) + Logical, Parameter :: exchange=.True., noexchange=.False., use_drot=.true. + Integer, Parameter :: irmax = 8 + Integer :: itx, i, isvch, ictxt,istop_, err_act + integer :: debug_level, debug_unit + Real(psb_spk_) :: rni, xni, bni, ani,bn2, dt + real(psb_dpk_) :: errnum, errden, deps, derr + character(len=20) :: name + character(len=*), parameter :: methdname='RGMRES' + + info = 0 + name = 'psb_sgmres' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc_a) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_)& + & write(debug_unit,*) me,' ',trim(name),': from psb_info',np + + mglob = psb_cd_get_global_rows(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + + if (present(istop)) then + istop_ = istop + else + istop_ = 1 + endif +! +! ISTOP_ = 1: Normwise backward error, infinity norm +! ISTOP_ = 2: ||r||/||b||, 2-norm +! + + if ((istop_ < 1 ).or.(istop_ > 2 ) ) then + info=5001 + int_err(1)=istop_ + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + if (present(itmax)) then + litmax = itmax + else + litmax = 1000 + endif + + if (present(itrace)) then + itrace_ = itrace + else + itrace_ = 0 + end if + + if (present(irst)) then + nl = irst + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' present: irst: ',irst,nl + else + nl = 10 + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' not present: irst: ',irst,nl + endif + if (nl <=0 ) then + info=5001 + int_err(1)=nl + err=info + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on X') + goto 9999 + end if + call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_chkvect on B') + goto 9999 + end if + + + naux=4*n_col + allocate(aux(naux),h(nl+1,nl+1),& + &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) + + if (info == 0) call psb_geall(v,desc_a,info,n=nl+1) + if (info == 0) call psb_geall(w,desc_a,info) + if (info == 0) call psb_geall(w1,desc_a,info) + if (info == 0) call psb_geall(xt,desc_a,info) + if (info == 0) call psb_geasb(v,desc_a,info) + if (info == 0) call psb_geasb(w,desc_a,info) + if (info == 0) call psb_geasb(w1,desc_a,info) + if (info == 0) call psb_geasb(xt,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Size of V,W,W1 ',size(v),size(v,1),& + & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1)) + + ! Ensure global coherence for convergence checks. + call psb_set_coher(ictxt,isvch) + + if (istop_ == 1) then + ani = psb_spnrmi(a,desc_a,info) + bni = psb_geamax(b,desc_a,info) + else if (istop_ == 2) then + bn2 = psb_genrm2(b,desc_a,info) + endif + errnum = dzero + errden = done + deps = eps + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + + itx = 0 + restart: do + + ! compute r0 = b-ax0 + ! check convergence + ! compute v1 = r0/||r0||_2 + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' restart: ',itx,it + it = 0 + call psb_geaxpby(sone,b,szero,v(:,1),desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_spmm(-sone,a,x,sone,v(:,1),desc_a,info,work=aux) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + rs(1) = psb_genrm2(v(:,1),desc_a,info) + rs(2:) = szero + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + scal=sone/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT? + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' on entry to amax: b: ',Size(b),rs(1),scal + + ! + ! check convergence + ! + if (istop_ == 1) then + rni = psb_geamax(v(:,1),desc_a,info) + xni = psb_geamax(x,desc_a,info) + errnum = rni + errden = (ani*xni+bni) + else if (istop_ == 2) then + rni = psb_genrm2(v(:,1),desc_a,info) + errnum = rni + errden = bn2 + endif + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + if (errnum <= eps*errden) exit restart + + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) + + v(:,1) = v(:,1) * scal + + if (itx >= litmax) exit restart + + ! + ! inner iterations + ! + + inner: Do i=1,nl + itx = itx + 1 + + call psb_precaply(prec,v(:,i),w1,desc_a,info) + call psb_spmm(sone,a,w1,szero,w,desc_a,info,work=aux) + ! + + do k = 1, i + h(k,i) = psb_gedot(v(:,k),w,desc_a,info) + call psb_geaxpby(-h(k,i),v(:,k),sone,w,desc_a,info) + end do + h(i+1,i) = psb_genrm2(w,desc_a,info) + scal=sone/h(i+1,i) + call psb_geaxpby(scal,w,szero,v(:,i+1),desc_a,info) + if (use_drot) then + do k=2,i + call drot(1,h(k-1,i),1,h(k,i),1,c(k-1),s(k-1)) + enddo + + rti = h(i,i) + rti1 = h(i+1,i) + call srotg(rti,rti1,c(i),s(i)) + call srot(1,h(i,i),1,h(i+1,i),1,c(i),s(i)) + h(i+1,i) = szero + call srot(1,rs(i),1,rs(i+1),1,c(i),s(i)) + + else + do k=2,i + dt = h(k-1,i) + h(k-1,i) = c(k-1)*dt + s(k-1)*h(k,i) + h(k,i) = -s(k-1)*dt + c(k-1)*h(k,i) + enddo + gm = safe_dn2(h(i,i),h(i+1,i)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' GM : ',gm + gm = max(gm,s_epstol) + + c(i) = h(i,i)/gm + s(i) = h(i+1,i)/gm + rs(i+1) = -s(i)*rs(i) + rs(i) = c(i)*rs(i) + h(i,i) = c(i)*h(i,i)+s(i)*h(i+1,i) + endif + if (istop_ == 1) then + ! + ! build x and then compute the residual and its infinity norm + ! + rst = rs + xt = szero + call strsm('l','u','n','n',i,1,sone,h,size(h,1),rst,size(rst,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rst(1:nl) + do k=1, i + call psb_geaxpby(rst(k),v(:,k),sone,xt,desc_a,info) + end do + call psb_precaply(prec,xt,desc_a,info) + call psb_geaxpby(sone,x,sone,xt,desc_a,info) + call psb_geaxpby(sone,b,szero,w1,desc_a,info) + call psb_spmm(-sone,a,xt,sone,w1,desc_a,info,work=aux) + rni = psb_geamax(w1,desc_a,info) + xni = psb_geamax(xt,desc_a,info) + errnum = rni + errden = (ani*xni+bni) + ! + + else if (istop_ == 2) then + ! + ! compute the residual 2-norm as byproduct of the solution + ! procedure of the least-squares problem + ! + rni = abs(rs(i+1)) + errnum = rni + errden = bn2 + endif + + if (errnum <= eps*errden) then + + if (istop_ == 1) then + x = xt + else if (istop_ == 2) then + ! + ! build x + ! + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild RS:',rs(1:i) + if ((debug_level >= psb_debug_ext_).and.(me==0)) then + + write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild RS H:' + do k=1,i + write(debug_unit,*) h(k,1:i) + end do + end if + + call strsm('l','u','n','n',i,1,sone,h,size(h,1),rs,size(rs,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rs(1:nl) + w1 = szero + do k=1, i + call psb_geaxpby(rs(k),v(:,k),sone,w1,desc_a,info) + end do + call psb_precaply(prec,w1,w,desc_a,info) + call psb_geaxpby(sone,w,sone,x,desc_a,info) + end if + + exit restart + + end if + + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,itrace_,errnum,errden,deps) + + end do inner + + if (istop_ == 1) then + x = xt + else if (istop_ == 2) then + ! + ! build x + ! + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild RS:',rs(1:nl) + call strsm('l','u','n','n',nl,1,sone,h,size(h,1),rs,size(rs,1)) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Rebuild x-> RS:',rs(1:nl) + w1 = szero + do k=1, nl + call psb_geaxpby(rs(k),v(:,k),sone,w1,desc_a,info) + end do + call psb_precaply(prec,w1,w,desc_a,info) + call psb_geaxpby(sone,w,sone,x,desc_a,info) + end if + + end do restart + if (itrace_ > 0) & + & call log_conv(methdname,me,itx,1,errnum,errden,deps) + + call log_end(methdname,me,itx,errnum,errden,deps,err=derr,iter=iter) + + if (present(err)) then + err = derr + end if + + deallocate(aux,h,c,s,rs,rst, stat=info) + if (info == 0) call psb_gefree(v,desc_a,info) + if (info == 0) call psb_gefree(w,desc_a,info) + if (info == 0) call psb_gefree(w1,desc_a,info) + if (info == 0) call psb_gefree(xt,desc_a,info) + if (info /= 0) then + info=4011 + call psb_errpush(info,name) + goto 9999 + end if + + ! restore external global coherence behaviour + call psb_restore_coher(ictxt,isvch) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + function safe_dn2(a,b) + real(psb_spk_), intent(in) :: a, b + real(psb_spk_) :: safe_dn2 + real(psb_spk_) :: 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_srgmres + + diff --git a/krylov/psb_zcg.f90 b/krylov/psb_zcg.F90 similarity index 100% rename from krylov/psb_zcg.f90 rename to krylov/psb_zcg.F90 diff --git a/prec/Makefile b/prec/Makefile index c73e46595..5fe1b5954 100644 --- a/prec/Makefile +++ b/prec/Makefile @@ -8,6 +8,14 @@ F90OBJS= psb_dbjac_bld.o psb_dilu_fct.o\ psb_ddiagsc_bld.o \ psb_dprc_aply.o \ psb_dgprec_aply.o psb_dbjac_aply.o\ + psb_sbjac_bld.o psb_silu_fct.o\ + psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ + psb_sdiagsc_bld.o \ + psb_sprc_aply.o psb_sgprec_aply.o psb_sbjac_aply.o\ + psb_cbjac_bld.o psb_cilu_fct.o\ + psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ + psb_cdiagsc_bld.o \ + psb_cprc_aply.o psb_cgprec_aply.o psb_cbjac_aply.o\ psb_zbjac_bld.o psb_zilu_fct.o\ psb_zprecbld.o psb_zprecset.o psb_zprecinit.o \ psb_zdiagsc_bld.o \ @@ -27,8 +35,10 @@ lib: $(OBJS) /bin/cp -p $(LIBMOD) $(LOCAL_MODS) $(LIBDIR) $(OBJS): $(LIBDIR)/psb_base_mod$(.mod) -$(F90OBJS): psb_prec_mod$(.mod) -psb_prec_mod$(.mod): psb_prec_type$(.mod) + +$(F90OBJS): $(MODOBJS) + +psb_prec_mod.o: psb_prec_type.o veryclean: clean /bin/rm -f $(LIBNAME) diff --git a/prec/psb_cbjac_aply.f90 b/prec/psb_cbjac_aply.f90 new file mode 100644 index 000000000..5e1ab23db --- /dev/null +++ b/prec/psb_cbjac_aply.f90 @@ -0,0 +1,166 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + ! + ! Compute Y <- beta*Y + alpha*K^-1 X + ! where K is a a Block Jacobi preconditioner stored in prec + ! Note that desc_data may or may not be the same as prec%desc_data, + ! but since both are INTENT(IN) this should be legal. + ! + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cbjac_aply + implicit none + + type(psb_desc_type), intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + complex(psb_spk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name, ch_err + + name='psb_bjac_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row=desc_data%matrix_data(psb_n_row_) + n_col=desc_data%matrix_data(psb_n_col_) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + + call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux) + if(info /=0) goto 9999 + call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_, work=aux) + if(info /=0) goto 9999 + + case('T') + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_, work=aux) + if(info /=0) goto 9999 + call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + if(info /=0) goto 9999 + + case('C') + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=conjg(prec%d),choice=psb_none_, work=aux) + if(info /=0) goto 9999 + call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + if(info /=0) goto 9999 + + end select + + + case default + info = 4001 + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cbjac_aply diff --git a/prec/psb_cbjac_bld.f90 b/prec/psb_cbjac_bld.f90 new file mode 100644 index 000000000..148a53c97 --- /dev/null +++ b/prec/psb_cbjac_bld.f90 @@ -0,0 +1,191 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cbjac_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cbjac_bld + implicit none + ! + ! .. Scalar Arguments .. + integer, intent(out) :: info + ! .. array Arguments .. + type(psb_cspmat_type), intent(in), target :: a + type(psb_cprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_cspmat_type) :: atmp + real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8 + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name, ch_err + + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_cbjac_bld' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + m = a%m + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + call psb_nullify_sp(atmp) + + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + select case(p%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(p%av)) then + if (size(p%av) < psb_bp_ilu_avsz) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + endif + end if + if (.not.allocated(p%av)) then + allocate(p%av(psb_max_avsz),stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_cd_get_local_rows(desc_a) + nztota = psb_sp_get_nnzeros(a) + + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-nrow_a + n_row = p%desc_data%matrix_data(psb_n_row_) + p%av(psb_l_pr_)%m = n_row + p%av(psb_l_pr_)%k = n_row + p%av(psb_u_pr_)%m = n_row + p%av(psb_u_pr_)%k = n_row + call psb_sp_all(n_row,n_row,p%av(psb_l_pr_),nztota,info) + if (info == 0) call psb_sp_all(n_row,n_row,p%av(psb_u_pr_),nztota,info) + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(p%d)) then + if (size(p%d) < n_row) then + deallocate(p%d) + endif + endif + if (.not.allocated(p%d)) then + allocate(p%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + t3 = psb_wtime() + ! This is where we have mo renumbering, thus no need + ! for ATMP + + call psb_ilu_fct(a,p%av(psb_l_pr_),p%av(psb_u_pr_),p%d,info) + if(info/=0) then + info=4010 + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (psb_sp_getifld(psb_upd_,p%av(psb_u_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(psb_u_pr_),info) + endif + + if (psb_sp_getifld(psb_upd_,p%av(psb_l_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(psb_l_pr_),info) + endif + + + case(psb_f_none_) + info=4010 + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=4010 + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_cbjac_bld + + diff --git a/prec/psb_cdiagsc_bld.f90 b/prec/psb_cdiagsc_bld.f90 new file mode 100644 index 000000000..e19fca921 --- /dev/null +++ b/prec/psb_cdiagsc_bld.f90 @@ -0,0 +1,133 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cdiagsc_bld(a,desc_a,p,upd,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cdiagsc_bld + Implicit None + + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_cprec_type),intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + + + ! Local scalars + Integer :: err, n_row, n_col,I,ictxt,& + & me,np,mglob,err_act + integer :: int_err(5) + + integer,parameter :: iroot=psb_root_,iout=60,ilout=40 + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + call psb_erractionsave(err_act) + name = 'psb_diagsc_bld' + + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + call psb_info(ictxt, me, np) + + ! diagonal scaling + + call psb_realloc(n_col,p%d,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 + end if + + ! + ! Retrieve the diagonal entries of the matrix A + ! + call psb_sp_getdiag(a,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getdiag' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! + ! Copy into p%desc_data the descriptor associated to A + ! + call psb_cdcpy(desc_a,p%desc_Data,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdcpy') + goto 9999 + end if + + ! + ! The i-th diagonal entry of the preconditioner is set to one if the + ! corresponding entry a_ii of the sparse matrix A is zero; otherwise + ! it is set to one/a_ii + ! + do i=1,n_row + if (p%d(i) == czero) then + p%d(i) = cone + else + p%d(i) = cone/p%d(i) + endif + end do + + if (a%pl(1) /= 0) then + ! + ! Apply the same row permutation as in the sparse matrix A + ! + call psb_gelp('n',a%pl,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cdiagsc_bld + diff --git a/prec/psb_cgprec_aply.f90 b/prec/psb_cgprec_aply.f90 new file mode 100644 index 000000000..e4f204fbc --- /dev/null +++ b/prec/psb_cgprec_aply.f90 @@ -0,0 +1,140 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + ! + ! Compute Y <- beta*Y + alpha*K^-1 X + ! where K is a a basic preconditioner stored in prec + ! + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cgprec_aply + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,int_err(5) + complex(psb_spk_), pointer :: ww(:) + character :: trans_ + integer :: ictxt,np,me, err_act + character(len=20) :: name, ch_err + + + name='psb_cgprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + + select case(trans_) + case('N') + case('T','C') + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + select case(prec%iprcparm(psb_p_type_)) + + case(psb_noprec_) + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + + case(psb_diag_) + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + end if + + n_row=desc_data%matrix_data(psb_n_row_) + if (trans_=='C') then + ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row)) + else + ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) + endif + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Deallocate') + goto 9999 + end if + end if + + case(psb_bjac_) + + call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='psb_bjac_aply' + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='Invalid prectype') + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cgprec_aply + diff --git a/prec/psb_cilu_fct.f90 b/prec/psb_cilu_fct.f90 new file mode 100644 index 000000000..3b0def18a --- /dev/null +++ b/prec/psb_cilu_fct.f90 @@ -0,0 +1,462 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cilu_fct(a,l,u,d,info,blck) + + ! + ! This routine copies and factors "on the fly" from A and BLCK + ! into L/D/U. + ! + ! + use psb_base_mod + implicit none + ! .. Scalar Arguments .. + integer, intent(out) :: info + ! .. Array Arguments .. + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + ! .. Local Scalars .. + integer :: l1, l2,m,err_act + type(psb_cspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + name='psb_ccsrlu' + info = 0 + call psb_erractionsave(err_act) + ! .. Executable Statements .. + ! + + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_nullify_sp(blck_) ! Why do we need this? Who knows.... + call psb_sp_all(0,0,blck_,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blck_%m=0 + endif + + call psb_cilu_fctint(m,a%m,a,blck_%m,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if(info /= 0) then + info=4010 + ch_err='psb_cilu_fctint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + subroutine psb_cilu_fctint(m,ma,a,mb,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + implicit none + + type(psb_cspmat_type) :: a,b + integer :: m,ma,mb,l1,l2,info + integer, dimension(:) :: lia1,lia2,uia1,uia2 + complex(psb_spk_), dimension(:) :: laspk,uaspk,d + + integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act + complex(psb_spk_) :: dia,temp + integer, parameter :: nrb=16 + type(psb_cspmat_type) :: trw + integer :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_cilu_fctint' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + call psb_nullify_sp(trw) + trw%m=0 + trw%k=0 + + call psb_sp_all(trw,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + lia2(1) = 1 + uia2(1) = 1 + l1=0 + l2=0 + m = ma+mb + + do i = 1, ma + d(i) = zzero + + ! + ! Here we take a fast shortcut if possible, otherwise + ! use spgtblk, slower but able (in principle) to handle + ! anything. + ! + if (a%fida=='CSR') then + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + ! write(0,*)'KKKKK',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = a%aspk(j) + lia1(l1) = k + else if (k == i) then + d(i) = a%aspk(j) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = a%aspk(j) + uia1(l2) = k + end if + enddo + + else + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(ma-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == i) then + d(i) = trw%aspk(ktrw) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end if + +!!$ + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! compute element alo(i,k) of incomplete factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! update the rest of row i using alo(i,k) + low1 = kk + 1 + low2 = uia2(i) + updateloop: do jj = uia2(k), uia2(k+1) - 1 + j = uia1(jj) + ! + if (j < i) then + ! search alo(i,*) for matching index J + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + ! + else if (j == i) then + ! j=i update diagonal + ! write(0,*)'aggiorno dia',dia,'temp',temp,'jj',jj,'u%aspk',uaspk(jj) + dia = dia - temp*uaspk(jj) + ! write(0,*)'dia',dia,'temp',temp,'jj',jj,'aspk',uaspk(jj) + cycle updateloop + ! + else if (j > i) then + ! search aup(i,*) for matching index j + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! for milu al=1.; for ilu al=0. + ! al = 1.d0 + ! dia = dia - al*temp*aup(jj) + enddo updateloop + enddo + ! + ! + ! Non singularity + ! + if (abs(dia) < s_epstol) then + ! + ! Pivot too small: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + dia = zone/dia + end if + d(i) = dia + ! write(6,*)'diag(',i,')=',d(i) + ! Scale row i of upper triangle + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + do i = ma+1, m + d(i) = zzero + + + if (b%fida=='CSR') then + + do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1 + k = b%ia1(j) + ! if (me == 2) write(0,*)'ecco k=',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = b%aspk(j) + lia1(l1) = k + ! if(me == 2) write(0,*)'scrivo l' + else if (k == i) then + d(i) = b%aspk(j) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = b%aspk(j) + ! write(0,*)'KKKKK',k + uia1(l2) = k + end if + enddo + + else + + if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i-ma,b,trw,info,lrw=i-ma+irb-1) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + ! write(0,*)'KKKKK',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == i) then + d(i) = trw%aspk(ktrw) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + endif + + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! compute element alo(i,k) of incomplete factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! update the rest of row i using alo(i,k) + low1 = kk + 1 + low2 = uia2(i) + updateloopb: do jj = uia2(k), uia2(k+1) - 1 + j = uia1(jj) + ! + if (j < i) then + ! search alo(i,*) for matching index J + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloopb + end if + enddo + ! + else if (j == i) then + ! j=i update diagonal + dia = dia - temp*uaspk(jj) + cycle updateloopb + ! + else if (j > i) then + ! search aup(i,*) for matching index j + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloopb + end if + enddo + end if + ! + ! for milu al=1.; for ilu al=0. + ! al = 1.d0 + ! dia = dia - al*temp*aup(jj) + enddo updateloopb + enddo + ! + ! + ! Non singularity + ! + if (abs(dia) < s_epstol) then + ! + ! Pivot too small: unstable factorization + ! + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + info = 2 + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + dia = zone/dia + end if + d(i) = dia + ! Scale row i of upper triangle + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + call psb_sp_free(trw,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine psb_cilu_fctint +end subroutine psb_cilu_fct diff --git a/prec/psb_cprc_aply.f90 b/prec/psb_cprc_aply.f90 new file mode 100644 index 000000000..842b77e8b --- /dev/null +++ b/prec/psb_cprc_aply.f90 @@ -0,0 +1,188 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans, work) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprc_aply + + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_), optional, target :: work(:) + + ! Local variables + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_cprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + end if + + call psb_gprec_aply(cone,prec,x,czero,y,desc_data,trans_,work_,info) + + ! If the original distribution has an overlap we should fix that. + + if (present(work)) then + else + deallocate(work_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_cprc_aply + + +!!$ +!!$ +!!$ MD2P4 +!!$ Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS +!!$ for +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR +!!$ +!!$ 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 MD2P4 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 MD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprc_aply1 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + ! Local variables + character :: trans_ + integer :: ictxt,np,me, err_act + complex(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_cprec1' + info = 0 + call psb_erractionsave(err_act) + + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + call psb_cprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + if(info /=0) goto 9999 + x(:) = ww(:) + deallocate(ww,W1) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_cprc_aply1 diff --git a/prec/psb_cprecbld.f90 b/prec/psb_cprecbld.f90 new file mode 100644 index 000000000..de984ccbe --- /dev/null +++ b/prec/psb_cprecbld.f90 @@ -0,0 +1,144 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cprecbld(a,desc_a,p,info,upd) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprecbld + Implicit None + + type(psb_cspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(psb_cprec_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + + + ! Local scalars + Integer :: err, n_row, n_col,ictxt,& + & me,np,mglob, err_act + integer :: int_err(5) + character :: upd_ + + integer,parameter :: iroot=psb_root_,iout=60,ilout=40 + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + call psb_erractionsave(err_act) + name = 'psb_precbld' + + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_='F' + endif + if ((upd_ == 'F').or.(upd_ == 'T')) then + ! ok + else + upd_='F' + endif + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + ! + ! Should add check to ensure all procs have the same... + ! + ! ALso should define symbolic names for the preconditioners. + ! + + call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& + & psb_diag_,is_legal_prec) + + call psb_nullify_desc(p%desc_data) + + select case(p%iprcparm(psb_p_type_)) + case (psb_noprec_) + ! Do nothing. + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (psb_diag_) + + call psb_diagsc_bld(a,desc_a,p,upd_,info) + if(info /= 0) then + info=4010 + ch_err='psb_diagsc_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (psb_bjac_) + + call psb_check_def(p%iprcparm(psb_f_type_),'fact',& + & psb_f_ilu_n_,is_legal_ml_fact) + + call psb_bjac_bld(a,desc_a,p,upd_,info) + + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_bjac_bld') + goto 9999 + end if + + case default + info=4010 + ch_err='Unknown psb_p_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_cprecbld + diff --git a/prec/psb_cprecinit.f90 b/prec/psb_cprecinit.f90 new file mode 100644 index 000000000..dff9b3e66 --- /dev/null +++ b/prec/psb_cprecinit.f90 @@ -0,0 +1,74 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cprecinit(p,ptype,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprecinit + implicit none + + type(psb_cprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + + info = 0 + + call psb_realloc(psb_ifpsz,p%iprcparm,info) + if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) + if (info /= 0) return + p%iprcparm(:) = 0 + + select case(psb_toupper(ptype(1:len_trim(ptype)))) + case ('NONE','NOPREC') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_noprec_ + p%iprcparm(psb_f_type_) = psb_f_none_ + + case ('DIAG') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_diag_ + p%iprcparm(psb_f_type_) = psb_f_none_ + + case ('BJAC') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_bjac_ + p%iprcparm(psb_f_type_) = psb_f_ilu_n_ + p%iprcparm(psb_ilu_fill_in_) = 0 + + case default + write(0,*) 'Unknown preconditioner type request "',ptype,'"' + + info = 2 + + end select + + +end subroutine psb_cprecinit diff --git a/prec/psb_cprecset.f90 b/prec/psb_cprecset.f90 new file mode 100644 index 000000000..854236314 --- /dev/null +++ b/prec/psb_cprecset.f90 @@ -0,0 +1,106 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_cprecseti(p,what,val,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprecseti + implicit none + type(psb_cprec_type), intent(inout) :: p + integer :: what, val + integer, intent(out) :: info + + info = 0 + + select case(what) + case (psb_f_type_) + if (p%iprcparm(psb_p_type_) /= psb_bjac_) then + write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + p%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + p%iprcparm(psb_ilu_fill_in_) = val + + case default + write(0,*) 'WHAT is invalid, ignoring user specification' + + end select + return + +end subroutine psb_cprecseti + + +subroutine psb_cprecsetd(p,what,val,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_cprecsetd + implicit none + type(psb_cprec_type), intent(inout) :: p + integer :: what + real(psb_spk_) :: val + integer, intent(out) :: info + +! +! This will have to be changed if/when we put together an ILU(eps) +! factorization. +! + select case(what) +!!$ case (psb_f_type_) +!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then +!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& +!!$ & 'ignoring user specification' +!!$ return +!!$ endif +!!$ p%iprcparm(psb_f_type_) = val +!!$ +!!$ case (psb_ilu_fill_in_) +!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then +!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& +!!$ & 'ignoring user specification' +!!$ return +!!$ endif +!!$ p%iprcparm(psb_ilu_fill_in_) = val + + case default + write(0,*) 'WHAT is invalid, ignoring user specification' + + end select + return + +end subroutine psb_cprecsetd diff --git a/prec/psb_prec_mod.f90 b/prec/psb_prec_mod.f90 index af1ca738f..54631a6e9 100644 --- a/prec/psb_prec_mod.f90 +++ b/prec/psb_prec_mod.f90 @@ -34,6 +34,16 @@ module psb_prec_mod use psb_prec_type interface psb_precbld + subroutine psb_sprecbld(a,desc_a,prec,info,upd) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(psb_sprec_type), intent(inout) :: prec + integer, intent(out) :: info + character, intent(in),optional :: upd + end subroutine psb_sprecbld subroutine psb_dprecbld(a,desc_a,prec,info,upd) use psb_base_mod use psb_prec_type @@ -44,6 +54,16 @@ module psb_prec_mod integer, intent(out) :: info character, intent(in),optional :: upd end subroutine psb_dprecbld + subroutine psb_cprecbld(a,desc_a,prec,info,upd) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(psb_cprec_type), intent(inout) :: prec + integer, intent(out) :: info + character, intent(in),optional :: upd + end subroutine psb_cprecbld subroutine psb_zprecbld(a,desc_a,prec,info,upd) use psb_base_mod use psb_prec_type @@ -57,6 +77,14 @@ module psb_prec_mod end interface interface psb_precinit + subroutine psb_sprecinit(prec,ptype,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + end subroutine psb_sprecinit subroutine psb_dprecinit(prec,ptype,info) use psb_base_mod use psb_prec_type @@ -65,6 +93,14 @@ module psb_prec_mod character(len=*), intent(in) :: ptype integer, intent(out) :: info end subroutine psb_dprecinit + subroutine psb_cprecinit(prec,ptype,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + end subroutine psb_cprecinit subroutine psb_zprecinit(prec,ptype,info) use psb_base_mod use psb_prec_type @@ -74,8 +110,25 @@ module psb_prec_mod integer, intent(out) :: info end subroutine psb_zprecinit end interface - + interface psb_precset + subroutine psb_sprecseti(prec,what,val,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_sprec_type), intent(inout) :: prec + integer :: what, val + integer, intent(out) :: info + end subroutine psb_sprecseti + subroutine psb_sprecsets(prec,what,val,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_sprec_type), intent(inout) :: prec + integer :: what + real(psb_spk_) :: val + integer, intent(out) :: info + end subroutine psb_sprecsets subroutine psb_dprecseti(prec,what,val,info) use psb_base_mod use psb_prec_type @@ -93,6 +146,23 @@ module psb_prec_mod real(psb_dpk_) :: val integer, intent(out) :: info end subroutine psb_dprecsetd + subroutine psb_cprecseti(prec,what,val,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_cprec_type), intent(inout) :: prec + integer :: what, val + integer, intent(out) :: info + end subroutine psb_cprecseti + subroutine psb_cprecsetd(prec,what,val,info) + use psb_base_mod + use psb_prec_type + implicit none + type(psb_cprec_type), intent(inout) :: prec + integer :: what + real(psb_dpk_) :: val + integer, intent(out) :: info + end subroutine psb_cprecsetd subroutine psb_zprecseti(prec,what,val,info) use psb_base_mod use psb_prec_type @@ -114,6 +184,26 @@ module psb_prec_mod interface psb_precaply + subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_sprc_aply + subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_sprc_aply1 subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_prec_type @@ -134,6 +224,26 @@ module psb_prec_mod integer, intent(out) :: info character(len=1), optional :: trans end subroutine psb_dprc_aply1 + subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_cprc_aply + subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_cprc_aply1 subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_prec_type @@ -158,33 +268,65 @@ module psb_prec_mod interface psb_bjac_aply - subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use psb_prec_type - type(psb_desc_type), intent(in) :: desc_data - type(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - end subroutine psb_dbjac_aply - subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use psb_prec_type - type(psb_desc_type), intent(in) :: desc_data - type(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_dpk_),target :: work(:) - integer, intent(out) :: info - end subroutine psb_zbjac_aply + subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_sbjac_aply + subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(in) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_dpk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dbjac_aply + subroutine psb_cbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_cbjac_aply + subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type), intent(in) :: desc_data + type(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(in) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_dpk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zbjac_aply end interface interface psb_ilu_fct + subroutine psb_silu_fct(a,l,u,d,info,blck) + use psb_base_mod + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine psb_silu_fct subroutine psb_dilu_fct(a,l,u,d,info,blck) use psb_base_mod integer, intent(out) :: info @@ -193,6 +335,14 @@ module psb_prec_mod type(psb_dspmat_type),intent(in), optional, target :: blck real(psb_dpk_), intent(inout) :: d(:) end subroutine psb_dilu_fct + subroutine psb_cilu_fct(a,l,u,d,info,blck) + use psb_base_mod + integer, intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + end subroutine psb_cilu_fct subroutine psb_zilu_fct(a,l,u,d,info,blck) use psb_base_mod integer, intent(out) :: info @@ -204,6 +354,15 @@ module psb_prec_mod end interface interface psb_bjac_bld + subroutine psb_sbjac_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target :: a + type(psb_sprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + end subroutine psb_sbjac_bld subroutine psb_dbjac_bld(a,desc_a,p,upd,info) use psb_base_mod use psb_prec_type @@ -213,6 +372,15 @@ module psb_prec_mod type(psb_desc_type), intent(in) :: desc_a character, intent(in) :: upd end subroutine psb_dbjac_bld + subroutine psb_cbjac_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), target :: a + type(psb_cprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + end subroutine psb_cbjac_bld subroutine psb_zbjac_bld(a,desc_a,p,upd,info) use psb_base_mod use psb_prec_type @@ -225,6 +393,15 @@ module psb_prec_mod end interface interface psb_diagsc_bld + subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target :: a + type(psb_sprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + end subroutine psb_sdiagsc_bld subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) use psb_base_mod use psb_prec_type @@ -234,6 +411,15 @@ module psb_prec_mod type(psb_desc_type), intent(in) :: desc_a character, intent(in) :: upd end subroutine psb_ddiagsc_bld + subroutine psb_cdiagsc_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_type + integer, intent(out) :: info + type(psb_cspmat_type), intent(in), target :: a + type(psb_cprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + end subroutine psb_cdiagsc_bld subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) use psb_base_mod use psb_prec_type @@ -246,31 +432,54 @@ module psb_prec_mod end interface interface psb_gprec_aply - subroutine psb_dgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use psb_prec_type - type(psb_desc_type),intent(in) :: desc_data - type(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - end subroutine psb_dgprec_aply - - subroutine psb_zgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use psb_prec_type - type(psb_desc_type),intent(in) :: desc_data - type(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(in) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - complex(psb_dpk_),target :: work(:) - integer, intent(out) :: info - end subroutine psb_zgprec_aply + subroutine psb_sgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_sgprec_aply + subroutine psb_dgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(in) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_dpk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_dgprec_aply + subroutine psb_cgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(in) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_spk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_cgprec_aply + subroutine psb_zgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + use psb_base_mod + use psb_prec_type + type(psb_desc_type),intent(in) :: desc_data + type(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(in) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1) :: trans + complex(psb_dpk_),target :: work(:) + integer, intent(out) :: info + end subroutine psb_zgprec_aply end interface end module psb_prec_mod diff --git a/prec/psb_prec_type.f90 b/prec/psb_prec_type.f90 index c5ed142e0..3e05e8fa2 100644 --- a/prec/psb_prec_type.f90 +++ b/prec/psb_prec_type.f90 @@ -38,8 +38,9 @@ module psb_prec_type ! Reduces size of .mod file. use psb_const_mod - use psb_base_mod, only : psb_dspmat_type, psb_zspmat_type, psb_desc_type,& - & psb_sizeof + use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,& + & psb_dspmat_type, psb_zspmat_type,& + & psb_desc_type, psb_sizeof integer, parameter :: psb_min_prec_=0, psb_noprec_=0, psb_diag_=1, & & psb_bjac_=2, psb_max_prec_=2 @@ -63,6 +64,16 @@ module psb_prec_type integer, parameter :: psb_max_avsz=psb_bp_ilu_avsz + type psb_sprec_type + type(psb_sspmat_type), allocatable :: av(:) + real(psb_spk_), allocatable :: d(:) + type(psb_desc_type) :: desc_data + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + integer, allocatable :: perm(:), invperm(:) + integer :: prec, base_prec + end type psb_sprec_type + type psb_dprec_type type(psb_dspmat_type), allocatable :: av(:) real(psb_dpk_), allocatable :: d(:) @@ -73,6 +84,17 @@ module psb_prec_type integer :: prec, base_prec end type psb_dprec_type + type psb_cprec_type + type(psb_cspmat_type), allocatable :: av(:) + complex(psb_spk_), allocatable :: d(:) + type(psb_desc_type) :: desc_data + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + integer, allocatable :: perm(:), invperm(:) + integer :: prec, base_prec + end type psb_cprec_type + + type psb_zprec_type type(psb_zspmat_type), allocatable :: av(:) complex(psb_dpk_), allocatable :: d(:) @@ -89,34 +111,51 @@ module psb_prec_type & 'ILU(eps) '/) interface psb_precfree - module procedure psb_d_precfree, psb_z_precfree + module procedure psb_s_precfree, psb_d_precfree,& + & psb_c_precfree, psb_z_precfree end interface interface psb_nullify_prec - module procedure psb_nullify_dprec, psb_nullify_zprec + module procedure psb_nullify_sprec, psb_nullify_dprec,& + & psb_nullify_cprec, psb_nullify_zprec end interface interface psb_check_def - module procedure psb_icheck_def, psb_dcheck_def + module procedure psb_icheck_def, psb_scheck_def, psb_dcheck_def end interface interface psb_prec_descr module procedure psb_out_prec_descr, psb_file_prec_descr, & + & psb_sout_prec_descr, psb_sfile_prec_descr, & + & psb_cout_prec_descr, psb_cfile_prec_descr, & & psb_zout_prec_descr, psb_zfile_prec_descr end interface interface psb_sizeof - module procedure psb_dprec_sizeof, psb_zprec_sizeof + module procedure psb_sprec_sizeof, psb_dprec_sizeof,& + & psb_cprec_sizeof, psb_zprec_sizeof end interface contains + subroutine psb_sout_prec_descr(p) + use psb_base_mod + type(psb_sprec_type), intent(in) :: p + call psb_sfile_prec_descr(6,p) + end subroutine psb_sout_prec_descr + subroutine psb_out_prec_descr(p) use psb_base_mod type(psb_dprec_type), intent(in) :: p call psb_file_prec_descr(6,p) end subroutine psb_out_prec_descr + subroutine psb_cout_prec_descr(p) + use psb_base_mod + type(psb_cprec_type), intent(in) :: p + call psb_cfile_prec_descr(6,p) + end subroutine psb_cout_prec_descr + subroutine psb_zout_prec_descr(p) use psb_base_mod type(psb_zprec_type), intent(in) :: p @@ -141,6 +180,41 @@ contains end subroutine psb_file_prec_descr + subroutine psb_sfile_prec_descr(iout,p) + use psb_base_mod + integer, intent(in) :: iout + type(psb_sprec_type), intent(in) :: p + + write(iout,*) 'Preconditioner description' + select case(p%iprcparm(psb_p_type_)) + case(psb_noprec_) + write(iout,*) 'No preconditioning' + case(psb_diag_) + write(iout,*) 'Diagonal scaling' + case(psb_bjac_) + write(iout,*) 'Block Jacobi with: ',& + & fact_names(p%iprcparm(psb_f_type_)) + end select + + end subroutine psb_sfile_prec_descr + + subroutine psb_cfile_prec_descr(iout,p) + use psb_base_mod + integer, intent(in) :: iout + type(psb_cprec_type), intent(in) :: p + + write(iout,*) 'Preconditioner description' + select case(p%iprcparm(psb_p_type_)) + case(psb_noprec_) + write(iout,*) 'No preconditioning' + case(psb_diag_) + write(iout,*) 'Diagonal scaling' + case(psb_bjac_) + write(iout,*) 'Block Jacobi with: ',& + & fact_names(p%iprcparm(psb_f_type_)) + end select + end subroutine psb_cfile_prec_descr + subroutine psb_zfile_prec_descr(iout,p) use psb_base_mod integer, intent(in) :: iout @@ -203,6 +277,25 @@ contains end if end subroutine psb_icheck_def + subroutine psb_scheck_def(ip,name,id,is_legal) + use psb_base_mod + real(psb_spk_), intent(inout) :: ip + real(psb_spk_), intent(in) :: id + character(len=*), intent(in) :: name + interface + function is_legal(i) + use psb_const_mod + real(psb_spk_), intent(in) :: i + logical :: is_legal + end function is_legal + end interface + + if (.not.is_legal(ip)) then + write(0,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id + ip = id + end if + end subroutine psb_scheck_def + subroutine psb_dcheck_def(ip,name,id,is_legal) use psb_base_mod real(psb_dpk_), intent(inout) :: ip @@ -222,6 +315,80 @@ contains end if end subroutine psb_dcheck_def + subroutine psb_s_precfree(p,info) + use psb_base_mod + type(psb_sprec_type), intent(inout) :: p + integer, intent(out) :: info + integer :: me, err_act,i + character(len=20) :: name + if(psb_get_errstatus() /= 0) return + info=0 + name = 'psb_precfree' + call psb_erractionsave(err_act) + + me=-1 + + ! Actually we migh just deallocate the top level array, except + ! for the inner UMFPACK or SLU stuff + + if (allocated(p%d)) then + deallocate(p%d,stat=info) + end if + + if (allocated(p%av)) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + end if + + if (allocated(p%desc_data%matrix_data)) & + & call psb_cdfree(p%desc_data,info) + + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + + if (allocated(p%perm)) then + deallocate(p%perm,stat=info) + endif + + if (allocated(p%invperm)) then + deallocate(p%invperm,stat=info) + endif + + if (allocated(p%iprcparm)) then + deallocate(p%iprcparm,stat=info) + end if + call psb_nullify_prec(p) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine psb_s_precfree + + subroutine psb_nullify_sprec(p) + use psb_base_mod + type(psb_sprec_type), intent(inout) :: p + +!!$ nullify(p%av,p%d,p%iprcparm,p%rprcparm,p%perm,p%invperm,p%mlia,& +!!$ & p%nlaggr,p%base_a,p%base_desc,p%dorig,p%desc_data, p%desc_ac) + + end subroutine psb_nullify_sprec + subroutine psb_d_precfree(p,info) use psb_base_mod type(psb_dprec_type), intent(inout) :: p @@ -296,6 +463,71 @@ contains end subroutine psb_nullify_dprec + subroutine psb_c_precfree(p,info) + use psb_base_mod + type(psb_cprec_type), intent(inout) :: p + integer, intent(out) :: info + integer :: err_act,i + character(len=20) :: name + if(psb_get_errstatus() /= 0) return + info=0 + name = 'psb_precfree' + call psb_erractionsave(err_act) + + if (allocated(p%d)) then + deallocate(p%d,stat=info) + end if + + if (allocated(p%av)) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + + end if + if (allocated(p%desc_data%matrix_data)) & + & call psb_cdfree(p%desc_data,info) + + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + + if (allocated(p%perm)) then + deallocate(p%perm,stat=info) + endif + + if (allocated(p%invperm)) then + deallocate(p%invperm,stat=info) + endif + + if (allocated(p%iprcparm)) then + deallocate(p%iprcparm,stat=info) + end if + call psb_nullify_prec(p) + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine psb_c_precfree + + subroutine psb_nullify_cprec(p) + use psb_base_mod + type(psb_cprec_type), intent(inout) :: p + + + end subroutine psb_nullify_cprec + subroutine psb_z_precfree(p,info) use psb_base_mod type(psb_zprec_type), intent(inout) :: p @@ -405,6 +637,29 @@ contains end function psb_dprec_sizeof + function psb_sprec_sizeof(prec) + use psb_base_mod + type(psb_sprec_type), intent(in) :: prec + integer :: psb_sprec_sizeof + integer :: val,i + + val = 0 + if (allocated(prec%iprcparm)) val = val + psb_sizeof_int * size(prec%iprcparm) + if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) + if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) + if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) + if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) + val = val + psb_sizeof(prec%desc_data) + if (allocated(prec%av)) then + do i=1,size(prec%av) + val = val + psb_sizeof(prec%av(i)) + end do + end if + + psb_sprec_sizeof = val + + end function psb_sprec_sizeof + function psb_zprec_sizeof(prec) use psb_base_mod type(psb_zprec_type), intent(in) :: prec @@ -427,6 +682,29 @@ contains psb_zprec_sizeof = val end function psb_zprec_sizeof + + function psb_cprec_sizeof(prec) + use psb_base_mod + type(psb_cprec_type), intent(in) :: prec + integer :: psb_cprec_sizeof + integer :: val,i + + val = 0 + if (allocated(prec%iprcparm)) val = val + psb_sizeof_int * size(prec%iprcparm) + if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) + if (allocated(prec%d)) val = val + 2 * psb_sizeof_sp * size(prec%d) + if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) + if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) + val = val + psb_sizeof(prec%desc_data) + if (allocated(prec%av)) then + do i=1,size(prec%av) + val = val + psb_sizeof(prec%av(i)) + end do + end if + + psb_cprec_sizeof = val + + end function psb_cprec_sizeof end module psb_prec_type diff --git a/prec/psb_sbjac_aply.f90 b/prec/psb_sbjac_aply.f90 new file mode 100644 index 000000000..608ee9f39 --- /dev/null +++ b/prec/psb_sbjac_aply.f90 @@ -0,0 +1,158 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + ! + ! Compute Y <- beta*Y + alpha*K^-1 X + ! where K is a a Block Jacobi preconditioner stored in prec + ! Note that desc_data may or may not be the same as prec%desc_data, + ! but since both are INTENT(IN) this should be legal. + ! + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sbjac_aply + implicit none + + type(psb_desc_type), intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:) + integer :: ictxt,np,me, err_act, int_err(5) + integer :: debug_level, debug_unit + character :: trans_ + character(len=20) :: name, ch_err + + name='psb_bjac_aply' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_data) + call psb_info(ictxt, me, np) + + + trans_ = psb_toupper(trans) + select case(trans_) + case('N','T','C') + ! Ok + case default + call psb_errpush(40,name) + goto 9999 + end select + + + n_row=desc_data%matrix_data(psb_n_row_) + n_col=desc_data%matrix_data(psb_n_col_) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + endif + + + select case(prec%iprcparm(psb_f_type_)) + case(psb_f_ilu_n_) + + select case(trans_) + case('N') + + call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux) + if(info /=0) goto 9999 + call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_, work=aux) + if(info /=0) goto 9999 + + case('T','C') + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,unit='L',diag=prec%d,choice=psb_none_, work=aux) + if(info /=0) goto 9999 + call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,unit='U',choice=psb_none_,work=aux) + if(info /=0) goto 9999 + + end select + + + case default + info = 4001 + call psb_errpush(info,name,a_err='Invalid factorization') + goto 9999 + end select + + call psb_halo(y,desc_data,info,data=psb_comm_mov_) + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sbjac_aply diff --git a/prec/psb_sbjac_bld.f90 b/prec/psb_sbjac_bld.f90 new file mode 100644 index 000000000..c69e51527 --- /dev/null +++ b/prec/psb_sbjac_bld.f90 @@ -0,0 +1,191 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sbjac_bld(a,desc_a,p,upd,info) + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sbjac_bld + implicit none + ! + ! .. Scalar Arguments .. + integer, intent(out) :: info + ! .. array Arguments .. + type(psb_sspmat_type), intent(in), target :: a + type(psb_sprec_type), intent(inout) :: p + type(psb_desc_type), intent(in) :: desc_a + character, intent(in) :: upd + + ! .. Local Scalars .. + integer :: i, m + integer :: int_err(5) + character :: trans, unitd + type(psb_sspmat_type) :: atmp + real(psb_spk_) :: t1,t2,t3,t4,t5,t6, t7, t8 + integer nztota, err_act, n_row, nrow_a,n_col, nhalo + integer :: ictxt,np,me + character(len=20) :: name, ch_err + + + if(psb_get_errstatus() /= 0) return + info=0 + name='psb_sbjac_bld' + call psb_erractionsave(err_act) + + ictxt=psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + + m = a%m + if (m < 0) then + info = 10 + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + trans = 'N' + unitd = 'U' + call psb_nullify_sp(atmp) + + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + select case(p%iprcparm(psb_f_type_)) + + case(psb_f_ilu_n_) + + if (allocated(p%av)) then + if (size(p%av) < psb_bp_ilu_avsz) then + do i=1,size(p%av) + call psb_sp_free(p%av(i),info) + if (info /= 0) then + ! Actually, we don't care here about this. + ! Just let it go. + ! return + end if + enddo + deallocate(p%av,stat=info) + endif + end if + if (.not.allocated(p%av)) then + allocate(p%av(psb_max_avsz),stat=info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + endif + + nrow_a = psb_cd_get_local_rows(desc_a) + nztota = psb_sp_get_nnzeros(a) + + n_col = psb_cd_get_local_cols(desc_a) + nhalo = n_col-nrow_a + n_row = p%desc_data%matrix_data(psb_n_row_) + p%av(psb_l_pr_)%m = n_row + p%av(psb_l_pr_)%k = n_row + p%av(psb_u_pr_)%m = n_row + p%av(psb_u_pr_)%k = n_row + call psb_sp_all(n_row,n_row,p%av(psb_l_pr_),nztota,info) + if (info == 0) call psb_sp_all(n_row,n_row,p%av(psb_u_pr_),nztota,info) + if(info/=0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(p%d)) then + if (size(p%d) < n_row) then + deallocate(p%d) + endif + endif + if (.not.allocated(p%d)) then + allocate(p%d(n_row),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + endif + t3 = psb_wtime() + ! This is where we have mo renumbering, thus no need + ! for ATMP + + call psb_ilu_fct(a,p%av(psb_l_pr_),p%av(psb_u_pr_),p%d,info) + if(info/=0) then + info=4010 + ch_err='psb_ilu_fct' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (psb_sp_getifld(psb_upd_,p%av(psb_u_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(psb_u_pr_),info) + endif + + if (psb_sp_getifld(psb_upd_,p%av(psb_l_pr_),info) /= psb_upd_perm_) then + call psb_sp_trim(p%av(psb_l_pr_),info) + endif + + + case(psb_f_none_) + info=4010 + ch_err='Inconsistent prec psb_f_none_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + case default + info=4010 + ch_err='Unknown psb_f_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_sbjac_bld + + diff --git a/prec/psb_sdiagsc_bld.f90 b/prec/psb_sdiagsc_bld.f90 new file mode 100644 index 000000000..24e776a30 --- /dev/null +++ b/prec/psb_sdiagsc_bld.f90 @@ -0,0 +1,133 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sdiagsc_bld + Implicit None + + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in) :: desc_a + type(psb_sprec_type),intent(inout) :: p + character, intent(in) :: upd + integer, intent(out) :: info + + + ! Local scalars + Integer :: err, n_row, n_col,I,ictxt,& + & me,np,mglob, err_act + integer :: int_err(5) + + integer,parameter :: iroot=psb_root_,iout=60,ilout=40 + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + call psb_erractionsave(err_act) + name = 'psb_diagsc_bld' + + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + + call psb_info(ictxt, me, np) + + ! diagonal scaling + + call psb_realloc(n_col,p%d,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 + end if + + ! + ! Retrieve the diagonal entries of the matrix A + ! + call psb_sp_getdiag(a,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getdiag' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! + ! Copy into p%desc_data the descriptor associated to A + ! + call psb_cdcpy(desc_a,p%desc_Data,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdcpy') + goto 9999 + end if + + ! + ! The i-th diagonal entry of the preconditioner is set to one if the + ! corresponding entry a_ii of the sparse matrix A is zero; otherwise + ! it is set to one/a_ii + ! + do i=1,n_row + if (p%d(i) == dzero) then + p%d(i) = done + else + p%d(i) = done/p%d(i) + endif + end do + + if (a%pl(1) /= 0) then + ! + ! Apply the same row permutation as in the sparse matrix A + ! + call psb_gelp('n',a%pl,p%d,info) + if(info /= 0) then + info=4010 + ch_err='psb_gelp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sdiagsc_bld + diff --git a/prec/psb_sgprec_aply.f90 b/prec/psb_sgprec_aply.f90 new file mode 100644 index 000000000..408e3a9c4 --- /dev/null +++ b/prec/psb_sgprec_aply.f90 @@ -0,0 +1,135 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) + ! + ! Compute Y <- beta*Y + alpha*K^-1 X + ! where K is a a basic preconditioner stored in prec + ! + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sgprec_aply + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1) :: trans + real(psb_spk_),target :: work(:) + integer, intent(out) :: info + + ! Local variables + integer :: n_row,int_err(5) + real(psb_spk_), pointer :: ww(:) + character :: trans_ + integer :: ictxt,np,me, err_act + character(len=20) :: name, ch_err + + name='psb_sgprec_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + + trans_ = psb_toupper(trans) + + select case(trans_) + case('N') + case('T','C') + case default + info=40 + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + select case(prec%iprcparm(psb_p_type_)) + + case(psb_noprec_) + + call psb_geaxpby(alpha,x,beta,y,desc_data,info) + + case(psb_diag_) + + if (size(work) >= size(x)) then + ww => work + else + allocate(ww(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + end if + + n_row=desc_data%matrix_data(psb_n_row_) + ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + + if (size(work) < size(x)) then + deallocate(ww,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Deallocate') + goto 9999 + end if + end if + + case(psb_bjac_) + + call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) + if(info /= 0) then + info=4010 + ch_err='psb_bjac_aply' + goto 9999 + end if + + case default + info = 4001 + call psb_errpush(info,name,a_err='Invalid prectype') + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sgprec_aply + diff --git a/prec/psb_silu_fct.f90 b/prec/psb_silu_fct.f90 new file mode 100644 index 000000000..34f85832d --- /dev/null +++ b/prec/psb_silu_fct.f90 @@ -0,0 +1,462 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_silu_fct(a,l,u,d,info,blck) + + ! + ! This routine copies and factors "on the fly" from A and BLCK + ! into L/D/U. + ! + ! + use psb_base_mod + implicit none + ! .. Scalar Arguments .. + integer, intent(out) :: info + ! .. Array Arguments .. + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + ! .. Local Scalars .. + integer :: l1,l2,m,err_act + type(psb_sspmat_type), pointer :: blck_ + character(len=20) :: name, ch_err + name='psb_ilu_fct' + info = 0 + call psb_erractionsave(err_act) + ! .. Executable Statements .. + ! + + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + call psb_nullify_sp(blck_) ! Why do we need this? Who knows.... + call psb_sp_all(0,0,blck_,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + blck_%m=0 + endif + + call psb_silu_fctint(m,a%m,a,blck_%m,blck_,& + & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + if(info /= 0) then + info=4010 + ch_err='psb_silu_fctint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l%infoa(1) = l1 + l%fida = 'CSR' + l%descra = 'TLU' + u%infoa(1) = l2 + u%fida = 'CSR' + u%descra = 'TUU' + l%m = m + l%k = m + u%m = m + u%k = m + if (present(blck)) then + blck_ => null() + else + call psb_sp_free(blck_,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + subroutine psb_silu_fctint(m,ma,a,mb,b,& + & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + implicit none + + type(psb_sspmat_type) :: a,b + integer :: m,ma,mb,l1,l2,info + integer, dimension(:) :: lia1,lia2,uia1,uia2 + real(psb_spk_), dimension(:) :: laspk,uaspk,d + + integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act + real(psb_spk_) :: dia,temp + integer, parameter :: nrb=16 + type(psb_sspmat_type) :: trw + integer :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_silu_fctint' + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + call psb_nullify_sp(trw) + trw%m=0 + trw%k=0 + + call psb_sp_all(trw,1,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + lia2(1) = 1 + uia2(1) = 1 + l1=0 + l2=0 + m = ma+mb + + do i = 1, ma + d(i) = dzero + + ! + ! Here we take a fast shortcut if possible, otherwise + ! use spgtblk, slower but able (in principle) to handle + ! anything. + ! + if (a%fida=='CSR') then + do j = a%ia2(i), a%ia2(i+1) - 1 + k = a%ia1(j) + ! write(0,*)'KKKKK',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = a%aspk(j) + lia1(l1) = k + else if (k == i) then + d(i) = a%aspk(j) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = a%aspk(j) + uia1(l2) = k + end if + enddo + + else + + if ((mod(i,nrb) == 1).or.(nrb==1)) then + irb = min(ma-i+1,nrb) + call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == i) then + d(i) = trw%aspk(ktrw) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end if + +!!$ + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! compute element alo(i,k) of incomplete factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! update the rest of row i using alo(i,k) + low1 = kk + 1 + low2 = uia2(i) + updateloop: do jj = uia2(k), uia2(k+1) - 1 + j = uia1(jj) + ! + if (j < i) then + ! search alo(i,*) for matching index J + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + ! + else if (j == i) then + ! j=i update diagonal + ! write(0,*)'aggiorno dia',dia,'temp',temp,'jj',jj,'u%aspk',uaspk(jj) + dia = dia - temp*uaspk(jj) + ! write(0,*)'dia',dia,'temp',temp,'jj',jj,'aspk',uaspk(jj) + cycle updateloop + ! + else if (j > i) then + ! search aup(i,*) for matching index j + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! for milu al=1.; for ilu al=0. + ! al = 1.d0 + ! dia = dia - al*temp*aup(jj) + enddo updateloop + enddo + ! + ! + ! Non singularity + ! + if (abs(dia) < s_epstol) then + ! + ! Pivot too small: unstable factorization + ! + info = 2 + int_err(1) = i + write(ch_err,'(g20.10)') dia + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + dia = done/dia + end if + d(i) = dia + ! write(6,*)'diag(',i,')=',d(i) + ! Scale row i of upper triangle + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + do i = ma+1, m + d(i) = dzero + + + if (b%fida=='CSR') then + + do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1 + k = b%ia1(j) + ! if (me == 2) write(0,*)'ecco k=',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = b%aspk(j) + lia1(l1) = k + ! if(me == 2) write(0,*)'scrivo l' + else if (k == i) then + d(i) = b%aspk(j) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = b%aspk(j) + ! write(0,*)'KKKKK',k + uia1(l2) = k + end if + enddo + + else + + if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then + irb = min(m-i+1,nrb) + call psb_sp_getblk(i-ma,b,trw,info,lrw=i-ma+irb-1) + if(info /= 0) then + info=4010 + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + do + if (ktrw > trw%infoa(psb_nnz_)) exit + if (trw%ia1(ktrw) > i) exit + k = trw%ia2(ktrw) + ! write(0,*)'KKKKK',k + if ((k < i).and.(k >= 1)) then + l1 = l1 + 1 + laspk(l1) = trw%aspk(ktrw) + lia1(l1) = k + else if (k == i) then + d(i) = trw%aspk(ktrw) + else if ((k > i).and.(k <= m)) then + l2 = l2 + 1 + uaspk(l2) = trw%aspk(ktrw) + uia1(l2) = k + end if + ktrw = ktrw + 1 + enddo + + endif + + + lia2(i+1) = l1 + 1 + uia2(i+1) = l2 + 1 + + dia = d(i) + do kk = lia2(i), lia2(i+1) - 1 + ! + ! compute element alo(i,k) of incomplete factorization + ! + temp = laspk(kk) + k = lia1(kk) + laspk(kk) = temp*d(k) + ! update the rest of row i using alo(i,k) + low1 = kk + 1 + low2 = uia2(i) + updateloopb: do jj = uia2(k), uia2(k+1) - 1 + j = uia1(jj) + ! + if (j < i) then + ! search alo(i,*) for matching index J + do ll = low1, lia2(i+1) - 1 + l = lia1(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + laspk(ll) = laspk(ll) - temp*uaspk(jj) + low1 = ll + 1 + cycle updateloopb + end if + enddo + ! + else if (j == i) then + ! j=i update diagonal + dia = dia - temp*uaspk(jj) + cycle updateloopb + ! + else if (j > i) then + ! search aup(i,*) for matching index j + do ll = low2, uia2(i+1) - 1 + l = uia1(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uaspk(ll) = uaspk(ll) - temp*uaspk(jj) + low2 = ll + 1 + cycle updateloopb + end if + enddo + end if + ! + ! for milu al=1.; for ilu al=0. + ! al = 1.d0 + ! dia = dia - al*temp*aup(jj) + enddo updateloopb + enddo + ! + ! + ! Non singularity + ! + if (abs(dia) < s_epstol) then + ! + ! Pivot too small: unstable factorization + ! + int_err(1) = i + write(ch_err,'(g20.10)') dia + info = 2 + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + dia = done/dia + end if + d(i) = dia + ! Scale row i of upper triangle + do kk = uia2(i), uia2(i+1) - 1 + uaspk(kk) = uaspk(kk)*dia + enddo + enddo + + call psb_sp_free(trw,info) + if(info /= 0) then + info=4010 + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine psb_silu_fctint +end subroutine psb_silu_fct diff --git a/prec/psb_sprc_aply.f90 b/prec/psb_sprc_aply.f90 new file mode 100644 index 000000000..7b67d3ef6 --- /dev/null +++ b/prec/psb_sprc_aply.f90 @@ -0,0 +1,185 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans, work) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprc_aply + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_), optional, target :: work(:) + + ! Local variables + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_prc_aply' + info = 0 + call psb_erractionsave(err_act) + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + end if + + call psb_gprec_aply(sone,prec,x,szero,y,desc_data,trans_,work_,info) + + if (present(work)) then + else + deallocate(work_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_sprc_aply + + +!!$ +!!$ +!!$ MD2P4 +!!$ Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS +!!$ for +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ Daniela di Serafino Second University of Naples +!!$ Pasqua D'Ambra ICAR-CNR +!!$ +!!$ 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 MD2P4 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 MD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprc_aply1 + implicit none + + type(psb_desc_type),intent(in) :: desc_data + type(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + ! Local variables + character :: trans_ + integer :: ictxt,np,me, err_act + real(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_sprec_aply1' + info = 0 + call psb_erractionsave(err_act) + + + ictxt=desc_data%matrix_data(psb_ctxt_) + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + call psb_sprc_aply(prec,x,ww,desc_data,info,trans_,work=w1) + if(info /=0) goto 9999 + x(:) = ww(:) + deallocate(ww,W1) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +end subroutine psb_sprc_aply1 diff --git a/prec/psb_sprecbld.f90 b/prec/psb_sprecbld.f90 new file mode 100644 index 000000000..4dbea55b2 --- /dev/null +++ b/prec/psb_sprecbld.f90 @@ -0,0 +1,143 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sprecbld(a,desc_a,p,info,upd) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprecbld + Implicit None + + type(psb_sspmat_type), target :: a + type(psb_desc_type), intent(in), target :: desc_a + type(psb_sprec_type),intent(inout) :: p + integer, intent(out) :: info + character, intent(in), optional :: upd + + ! Local scalars + Integer :: err, n_row, n_col,ictxt,& + & me,np,mglob, err_act + integer :: int_err(5) + character :: upd_ + + integer,parameter :: iroot=psb_root_,iout=60,ilout=40 + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=0 + err=0 + call psb_erractionsave(err_act) + name = 'psb_precbld' + + info = 0 + int_err(1) = 0 + ictxt = psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_='F' + endif + if ((upd_ == 'F').or.(upd_ == 'T')) then + ! ok + else + upd_='F' + endif + n_row = psb_cd_get_local_rows(desc_a) + n_col = psb_cd_get_local_cols(desc_a) + mglob = psb_cd_get_global_rows(desc_a) + ! + ! Should add check to ensure all procs have the same... + ! + ! ALso should define symbolic names for the preconditioners. + ! + + call psb_check_def(p%iprcparm(psb_p_type_),'base_prec',& + & psb_diag_,is_legal_prec) + + call psb_nullify_desc(p%desc_data) + + select case(p%iprcparm(psb_p_type_)) + case (psb_noprec_) + ! Do nothing. + call psb_cdcpy(desc_a,p%desc_data,info) + if(info /= 0) then + info=4010 + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (psb_diag_) + + call psb_diagsc_bld(a,desc_a,p,upd_,info) + if(info /= 0) then + info=4010 + ch_err='psb_diagsc_bld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case (psb_bjac_) + + call psb_check_def(p%iprcparm(psb_f_type_),'fact',& + & psb_f_ilu_n_,is_legal_ml_fact) + + call psb_bjac_bld(a,desc_a,p,upd_,info) + + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_bjac_bld') + goto 9999 + end if + + case default + info=4010 + ch_err='Unknown psb_p_type_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_sprecbld + diff --git a/prec/psb_sprecinit.f90 b/prec/psb_sprecinit.f90 new file mode 100644 index 000000000..46d493913 --- /dev/null +++ b/prec/psb_sprecinit.f90 @@ -0,0 +1,71 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sprecinit(p,ptype,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprecinit + implicit none + type(psb_sprec_type), intent(inout) :: p + character(len=*), intent(in) :: ptype + integer, intent(out) :: info + + info = 0 + + call psb_realloc(psb_ifpsz,p%iprcparm,info) + if (info == 0) call psb_realloc(psb_rfpsz,p%rprcparm,info) + if (info /= 0) return + p%iprcparm(:) = 0 + + select case(psb_toupper(ptype(1:len_trim(ptype)))) + case ('NONE','NOPREC') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_noprec_ + p%iprcparm(psb_f_type_) = psb_f_none_ + + case ('DIAG') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_diag_ + p%iprcparm(psb_f_type_) = psb_f_none_ + + case ('BJAC') + p%iprcparm(:) = 0 + p%iprcparm(psb_p_type_) = psb_bjac_ + p%iprcparm(psb_f_type_) = psb_f_ilu_n_ + p%iprcparm(psb_ilu_fill_in_) = 0 + + case default + write(0,*) 'Unknown preconditioner type request "',ptype,'"' + info = 2 + + end select + +end subroutine psb_sprecinit diff --git a/prec/psb_sprecset.f90 b/prec/psb_sprecset.f90 new file mode 100644 index 000000000..dc1505f7b --- /dev/null +++ b/prec/psb_sprecset.f90 @@ -0,0 +1,106 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine psb_sprecseti(p,what,val,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprecseti + implicit none + type(psb_sprec_type), intent(inout) :: p + integer :: what, val + integer, intent(out) :: info + + info = 0 + + select case(what) + case (psb_f_type_) + if (p%iprcparm(psb_p_type_) /= psb_bjac_) then + write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + p%iprcparm(psb_f_type_) = val + + case (psb_ilu_fill_in_) + if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then + write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& + & 'ignoring user specification' + return + endif + p%iprcparm(psb_ilu_fill_in_) = val + + case default + write(0,*) 'WHAT is invalid, ignoring user specification' + + end select + return + +end subroutine psb_sprecseti + + +subroutine psb_sprecsets(p,what,val,info) + + use psb_base_mod + use psb_prec_mod, psb_protect_name => psb_sprecsets + implicit none + type(psb_sprec_type), intent(inout) :: p + integer :: what + real(psb_spk_) :: val + integer, intent(out) :: info + +! +! This will have to be changed if/when we put together an ILU(eps) +! factorization. +! + select case(what) +!!$ case (psb_f_type_) +!!$ if (p%iprcparm(psb_p_type_) /= psb_bjac_) then +!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& +!!$ & 'ignoring user specification' +!!$ return +!!$ endif +!!$ p%iprcparm(psb_f_type_) = val +!!$ +!!$ case (psb_ilu_fill_in_) +!!$ if ((p%iprcparm(psb_p_type_) /= psb_bjac_).or.(p%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then +!!$ write(0,*) 'WHAT is invalid for current preconditioner ',p%iprcparm(psb_p_type_),& +!!$ & 'ignoring user specification' +!!$ return +!!$ endif +!!$ p%iprcparm(psb_ilu_fill_in_) = val + + case default + write(0,*) 'WHAT is invalid, ignoring user specification' + + end select + return + +end subroutine psb_sprecsets diff --git a/test/fileread/Makefile b/test/fileread/Makefile index e247cc430..f0fb2ade3 100644 --- a/test/fileread/Makefile +++ b/test/fileread/Makefile @@ -8,26 +8,34 @@ LDLIBS=$(PSBLDLIBS) FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). +SFOBJS=getp.o sf_sample.o DFOBJS=getp.o df_sample.o +CFOBJS=getp.o cf_sample.o ZFOBJS=getp.o zf_sample.o EXEDIR=./runs -all: df_sample zf_sample +all: sf_sample df_sample cf_sample zf_sample +sf_sample: $(SFOBJS) + $(F90LINK) $(LOPT) $(SFOBJS) -o sf_sample $(PSBLAS_LIB) $(LDLIBS) + /bin/mv sf_sample $(EXEDIR) df_sample: $(DFOBJS) - $(F90LINK) $(DFOBJS) -o df_sample $(PSBLAS_LIB) $(LDLIBS) + $(F90LINK) $(LOPT) $(DFOBJS) -o df_sample $(PSBLAS_LIB) $(LDLIBS) /bin/mv df_sample $(EXEDIR) +cf_sample: $(CFOBJS) + $(F90LINK) $(LOPT) $(CFOBJS) -o cf_sample $(PSBLAS_LIB) $(LDLIBS) + /bin/mv cf_sample $(EXEDIR) zf_sample: $(ZFOBJS) - $(F90LINK) $(ZFOBJS) -o zf_sample $(PSBLAS_LIB) $(LDLIBS) + $(F90LINK) $(LOPT) $(ZFOBJS) -o zf_sample $(PSBLAS_LIB) $(LDLIBS) /bin/mv zf_sample $(EXEDIR) .f90.o: $(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $< clean: - /bin/rm -f $(DFOBJS) $(ZFOBJS) \ + /bin/rm -f $(DFOBJS) $(ZFOBJS) $(SFOBJS)\ *$(.mod) $(EXEDIR)/df_sample $(EXEDIR)/zf_sample lib: diff --git a/test/fileread/cf_sample.f90 b/test/fileread/cf_sample.f90 new file mode 100644 index 000000000..621c0a978 --- /dev/null +++ b/test/fileread/cf_sample.f90 @@ -0,0 +1,291 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +program cf_sample + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod + use psb_util_mod + use getp + implicit none + + ! input parameters + character(len=40) :: kmethd, ptype, mtrx_file, rhs_file + + ! sparse matrices + type(psb_cspmat_type) :: a, aux_a + + ! preconditioner data + type(psb_cprec_type) :: prec + + ! dense matrices + complex(psb_spk_), allocatable, target :: aux_b(:,:), d(:) + complex(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), & + & x_col_glob(:), r_col_glob(:) + complex(psb_spk_), pointer :: b_col_glob(:) + + ! communications data structure + type(psb_desc_type):: desc_a + + integer :: ictxt, iam, np + + ! solver paramters + integer :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst,amatsize,precsize,descsize + real(psb_spk_) :: err, eps + + character(len=5) :: afmt + character(len=20) :: name + integer :: iparm(20) + + ! other variables + integer :: i,info,j,m_problem + integer :: internal, m,ii,nnzero + real(psb_dpk_) :: t1, t2, tprec + real(psb_spk_) :: r_amax, b_amax, scale,resmx,resmxp + integer :: nrhs, nrow, n_row, dim, nv, ne + integer, allocatable :: ivg(:), ipv(:) + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + + + name='cf_sample' + if(psb_get_errstatus() /= 0) goto 9999 + info=0 + call psb_set_errverbosity(2) + ! + ! get parameters + ! + call get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,& + & ipart,afmt,istopc,itmax,itrace,irst,eps) + + call psb_barrier(ictxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + call read_mat(mtrx_file, aux_a, ictxt) + + m_problem = aux_a%m + call psb_bcast(ictxt,m_problem) + + if(rhs_file /= 'NONE') then + ! reading an rhs + call read_rhs(rhs_file,aux_b,ictxt) + end if + + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(0,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(*,'("Generating an rhs...")') + write(*,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = (1.d0,1.d0) + enddo + endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + else + call psb_bcast(ictxt,m_problem) + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + end if + + ! switch over different partition types + if (ipart == 0) then + call psb_barrier(ictxt) + if (iam==psb_root_) write(*,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else if (ipart == 2) then + if (iam==psb_root_) then + write(*,'("Partition type: graph")') + write(*,'(" ")') + ! write(0,'("Build type: graph")') + call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np) + endif + call psb_barrier(ictxt) + call distr_mtpart(psb_root_,ictxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else + if (iam==psb_root_) write(*,'("Partition type: block")') + call psb_matdist(aux_a, a, part_block, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + end if + + call psb_geall(x_col,desc_a,info) + x_col(:) =0.0 + call psb_geasb(x_col,desc_a,info) + call psb_geall(r_col,desc_a,info) + r_col(:) =0.0 + call psb_geasb(r_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ictxt, t2) + + if (iam==psb_root_) then + write(*,'(" ")') + write(*,'("Time to read and partition matrix : ",es10.4)')t2 + write(*,'(" ")') + end if + + ! + + call psb_precinit(prec,ptype,info) + + ! building the preconditioner + t1 = psb_wtime() + call psb_precbld(a,desc_a,prec,info) + tprec = psb_wtime()-t1 + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_precbld') + goto 9999 + end if + + + call psb_amx(ictxt,tprec) + + if(iam==psb_root_) then + write(*,'("Preconditioner time: ",es10.4)')tprec + write(*,'(" ")') + end if + + iparm = 0 + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + call psb_geaxpby(cone,b_col,czero,r_col,desc_a,info) + call psb_spmm(-cone,a,x_col,cone,r_col,desc_a,info) + resmx = psb_genrm2(r_col,desc_a,info) + resmxp = psb_geamax(r_col,desc_a,info) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = psb_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam==psb_root_) then + call psb_prec_descr(6,prec) + write(*,'("Matrix: ",a)')mtrx_file + write(*,'("Computed solution on ",i8," processors")')np + write(*,'("Iterations to convergence: ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)') err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp +!!$ write(*,*)"Condition number : ",cond + write(*,'("Total memory occupation for A: ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A: ",i10)')descsize + write(*,'("Total memory occupation for PREC: ",i10)')precsize + end if + + allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) + if (ierr /= 0) then + write(0,*) 'allocation error: no data collection' + else + call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) + call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) + if (iam==psb_root_) then + write(0,'(" ")') + write(0,'("Saving x on file")') + write(20,*) 'matrix: ',mtrx_file + write(20,*) 'computed solution on ',np,' processors.' + write(20,*) 'iterations to convergence: ',iter + write(20,*) 'error estimate (infinity norm) on exit:', & + & ' ||r||/(||a||||x||+||b||) = ',err + write(20,*) 'max residual = ',resmx, resmxp + write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' + do i=1,m_problem + write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) + enddo + end if + end if +998 format(i8,6(1x,g11.5)) +993 format(i6,4(1x,e12.6)) + + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call psb_precfree(prec,info) + call psb_cdfree(desc_a,info) + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +end program cf_sample + + + + + diff --git a/test/fileread/df_sample.f90 b/test/fileread/df_sample.f90 index 9e015a8d5..207dd9446 100644 --- a/test/fileread/df_sample.f90 +++ b/test/fileread/df_sample.f90 @@ -60,7 +60,7 @@ program df_sample ! solver paramters integer :: iter, itmax, ierr, itrace, ircode, ipart,& & methd, istopc, irst,amatsize,precsize,descsize - real(psb_dpk_) :: err, eps + real(psb_dpk_) :: err, eps,cond character(len=5) :: afmt character(len=20) :: name @@ -207,12 +207,13 @@ program df_sample write(*,'("Preconditioner time: ",es10.4)')tprec write(*,'(" ")') end if - + cond = dzero iparm = 0 call psb_barrier(ictxt) t1 = psb_wtime() call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& - & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,& + & irst=irst,cond=cond) call psb_barrier(ictxt) t2 = psb_wtime() - t1 @@ -233,13 +234,14 @@ program df_sample write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np write(*,'("Iterations to convergence: ",i6)')iter - write(*,'("Error estimate on exit: ",f7.2)')err - write(*,'("Time to buil prec. : ",es10.4)')tprec - write(*,'("Time to solve matrix : ",es10.4)')t2 - write(*,'("Time per iteration : ",es10.4)')t2/(iter) - write(*,'("Total time : ",es10.4)')t2+tprec - write(*,'("Residual norm 2 = ",es10.4)')resmx - write(*,'("Residual norm inf = ",es10.4)')resmxp + write(*,'("Error estimate on exit : ",es10.4)') err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,*)"Condition number : ",cond write(*,'("Total memory occupation for A: ",i10)')amatsize write(*,'("Total memory occupation for DESC_A: ",i10)')descsize write(*,'("Total memory occupation for PREC: ",i10)')precsize diff --git a/test/fileread/getp.f90 b/test/fileread/getp.f90 index 987a9d65d..6680f65ab 100644 --- a/test/fileread/getp.f90 +++ b/test/fileread/getp.f90 @@ -30,13 +30,15 @@ !!$ !!$ Module getp - public get_parms + interface get_parms + module procedure get_dparms, get_sparms + end interface contains ! ! Get iteration parameters from the command line ! - subroutine get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,& + subroutine get_dparms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,& & afmt,istopc,itmax,itrace,irst,eps) use psb_base_mod integer :: ictxt @@ -131,6 +133,103 @@ contains end if - end subroutine get_parms + end subroutine get_dparms + + subroutine get_sparms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,& + & afmt,istopc,itmax,itrace,irst,eps) + use psb_base_mod + integer :: ictxt + character(len=40) :: kmethd, mtrx_file, rhs_file, ptype + integer :: iret, istopc,itmax,itrace,ipart,irst + character(len=40) :: charbuf + real(psb_spk_) :: eps + character :: afmt*5 + integer :: np, iam + integer :: inparms(40), ip + + call psb_info(ictxt,iam,np) + if (iam==0) then + ! Read Input Parameters + read(*,*) ip + if (ip >= 5) then + read(*,*) mtrx_file + read(*,*) rhs_file + read(*,*) kmethd + read(*,*) ptype + read(*,*) afmt + + + call psb_bcast(ictxt,mtrx_file) + call psb_bcast(ictxt,rhs_file) + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,ptype) + call psb_bcast(ictxt,afmt) + + read(*,*) ipart + if (ip >= 7) then + read(*,*) istopc + else + istopc=1 + endif + if (ip >= 8) then + read(*,*) itmax + else + itmax=500 + endif + if (ip >= 9) then + read(*,*) itrace + else + itrace=-1 + endif + if (ip >= 10) then + read(*,*) irst + else + irst = 1 + endif + if (ip >= 11) then + read(*,*) eps + else + eps=1.d-6 + endif + inparms(1) = ipart + inparms(2) = istopc + inparms(3) = itmax + inparms(4) = itrace + inparms(5) = irst + call psb_bcast(ictxt,inparms(1:5)) + call psb_bcast(ictxt,eps) + + write(*,'("Solving matrix : ",a)') mtrx_file + write(*,'("Number of processors : ",i3)') np + write(*,'("Data distribution : ",i2)') ipart + write(*,'("Iterative method : ",a)') kmethd + write(*,'("Preconditioner : ",a)') ptype + write(*,'("Restart parameter : ",i2)') irst + write(*,'("Storage format : ",a)') afmt(1:3) + write(*,'(" ")') + else + write(0,*) 'Wrong format for input file' + call psb_abort(ictxt) + stop 1 + end if + else + ! Receive Parameters + call psb_bcast(ictxt,mtrx_file) + call psb_bcast(ictxt,rhs_file) + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,ptype) + call psb_bcast(ictxt,afmt) + + call psb_bcast(ictxt,inparms(1:5)) + ipart = inparms(1) + istopc = inparms(2) + itmax = inparms(3) + itrace = inparms(4) + irst = inparms(5) + call psb_bcast(ictxt,eps) + + end if + + end subroutine get_sparms end module getp diff --git a/test/fileread/runs/cfs.inp b/test/fileread/runs/cfs.inp new file mode 100644 index 000000000..6a9e04580 --- /dev/null +++ b/test/fileread/runs/cfs.inp @@ -0,0 +1,12 @@ +11 Number of inputs +young1c.mtx waveguide3D.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE http://www.cise.ufl.edu/research/sparse/matrices/index.html +BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL +BJAC Preconditioner NONE DIAG BJAC +CSR Storage format CSR COO JAD +0 IPART: Partition method 0: BLK 2: graph (with Metis) +2 ISTOPC +01000 ITMAX +01 ITRACE +30 IRST (restart for RGMRES and BiCGSTABL) +1.d-5 EPS diff --git a/test/fileread/runs/sfs.inp b/test/fileread/runs/sfs.inp new file mode 100644 index 000000000..2bb6cb77b --- /dev/null +++ b/test/fileread/runs/sfs.inp @@ -0,0 +1,12 @@ +11 Number of inputs +thm1000x600.mtx young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +NONE http://www.cise.ufl.edu/research/sparse/matrices/index.html +BICGSTABL Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL +BJAC Preconditioner NONE DIAG BJAC +CSR Storage format CSR COO JAD +0 IPART: Partition method 0: BLK 2: graph (with Metis) +2 ISTOPC +01000 ITMAX +01 ITRACE +04 IRST (restart for RGMRES and BiCGSTABL) +1.d-6 EPS diff --git a/test/fileread/sf_sample.f90 b/test/fileread/sf_sample.f90 new file mode 100644 index 000000000..226a5558b --- /dev/null +++ b/test/fileread/sf_sample.f90 @@ -0,0 +1,293 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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. +!!$ +!!$ +program sf_sample + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod + use psb_util_mod + use getp + implicit none + + ! input parameters + character(len=40) :: kmethd, ptype, mtrx_file, rhs_file + + ! sparse matrices + type(psb_sspmat_type) :: a, aux_a + + ! preconditioner data + type(psb_sprec_type) :: prec + + ! dense matrices + real(psb_spk_), allocatable, target :: aux_b(:,:), d(:) + real(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), & + & x_col_glob(:), r_col_glob(:) + real(psb_spk_), pointer :: b_col_glob(:) + + ! communications data structure + type(psb_desc_type):: desc_a + + integer :: ictxt, iam, np + + ! solver paramters + integer :: iter, itmax, ierr, itrace, ircode, ipart,& + & methd, istopc, irst,amatsize,precsize,descsize + real(psb_spk_) :: err, eps,cond + + character(len=5) :: afmt + character(len=20) :: name + integer :: iparm(20) + + ! other variables + integer :: i,info,j,m_problem + integer :: internal, m,ii,nnzero + real(psb_spk_) :: t1, t2, tprec, r_amax, b_amax,& + &scale,resmx,resmxp + integer :: nrhs, nrow, n_row, dim, nv, ne + integer, allocatable :: ivg(:), ipv(:) + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + + + name='df_sample' + if(psb_get_errstatus() /= 0) goto 9999 + info=0 + call psb_set_errverbosity(2) + ! + ! get parameters + ! + call get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,& + & ipart,afmt,istopc,itmax,itrace,irst,eps) + + call psb_barrier(ictxt) + t1 = psb_wtime() + ! read the input matrix to be processed and (possibly) the rhs + nrhs = 1 + + if (iam==psb_root_) then + call read_mat(mtrx_file, aux_a, ictxt) + + m_problem = aux_a%m + call psb_bcast(ictxt,m_problem) + + if(rhs_file /= 'NONE') then + ! reading an rhs + call read_rhs(rhs_file,aux_b,ictxt) + end if + + if (psb_size(aux_b,dim=1)==m_problem) then + ! if any rhs were present, broadcast the first one + write(0,'("Ok, got an rhs ")') + b_col_glob =>aux_b(:,1) + else + write(*,'("Generating an rhs...")') + write(*,'(" ")') + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + + b_col_glob => aux_b(:,1) + do i=1, m_problem + b_col_glob(i) = 1.d0 + enddo + endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + else + call psb_bcast(ictxt,m_problem) + call psb_realloc(m_problem,1,aux_b,ircode) + if (ircode /= 0) then + call psb_errpush(4000,name) + goto 9999 + endif + b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) + end if + + ! switch over different partition types + if (ipart == 0) then + call psb_barrier(ictxt) + if (iam==psb_root_) write(*,'("Partition type: block")') + allocate(ivg(m_problem),ipv(np)) + do i=1,m_problem + call part_block(i,m_problem,np,ipv,nv) + ivg(i) = ipv(1) + enddo + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else if (ipart == 2) then + if (iam==psb_root_) then + write(*,'("Partition type: graph")') + write(*,'(" ")') + ! write(0,'("Build type: graph")') + call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np) + endif + call psb_barrier(ictxt) + call distr_mtpart(psb_root_,ictxt) + call getv_mtpart(ivg) + call psb_matdist(aux_a, a, ivg, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + else + if (iam==psb_root_) write(*,'("Partition type: block")') + call psb_matdist(aux_a, a, part_block, ictxt, & + & desc_a,b_col_glob,b_col,info,fmt=afmt) + end if + + call psb_geall(x_col,desc_a,info) + x_col(:) =0.0 + call psb_geasb(x_col,desc_a,info) + call psb_geall(r_col,desc_a,info) + r_col(:) =0.0 + call psb_geasb(r_col,desc_a,info) + t2 = psb_wtime() - t1 + + + call psb_amx(ictxt, t2) + + if (iam==psb_root_) then + write(*,'(" ")') + write(*,'("Time to read and partition matrix : ",es10.4)')t2 + write(*,'(" ")') + end if + + ! + + call psb_precinit(prec,ptype,info) + + ! building the preconditioner + t1 = psb_wtime() + call psb_precbld(a,desc_a,prec,info) + tprec = psb_wtime()-t1 + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_precbld') + goto 9999 + end if + + + call psb_amx(ictxt, tprec) + + if(iam==psb_root_) then + write(*,'("Preconditioner time: ",es10.4)')tprec + write(*,'(" ")') + end if + cond = -sone + iparm = 0 + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,& + & irst=irst,cond=cond) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + + call psb_amx(ictxt,t2) + call psb_geaxpby(sone,b_col,szero,r_col,desc_a,info) + call psb_spmm(-sone,a,x_col,sone,r_col,desc_a,info) + call psb_genrm2s(resmx,r_col,desc_a,info) + call psb_geamaxs(resmxp,r_col,desc_a,info) + + amatsize = psb_sizeof(a) + descsize = psb_sizeof(desc_a) + precsize = psb_sizeof(prec) + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam==psb_root_) then + call psb_prec_descr(6,prec) + write(*,'("Matrix: ",a)')mtrx_file + write(*,'("Computed solution on ",i8," processors")')np + write(*,'("Iterations to convergence: ",i6)')iter + write(*,'("Error estimate on exit : ",es10.4)') err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp + write(*,*)"Condition number : ",cond + write(*,'("Total memory occupation for A: ",i10)')amatsize + write(*,'("Total memory occupation for DESC_A: ",i10)')descsize + write(*,'("Total memory occupation for PREC: ",i10)')precsize + end if + + allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr) + if (ierr /= 0) then + write(0,*) 'allocation error: no data collection' + else + call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) + call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) + if (iam==psb_root_) then + write(0,'(" ")') + write(0,'("Saving x on file")') + write(20,*) 'matrix: ',mtrx_file + write(20,*) 'computed solution on ',np,' processors.' + write(20,*) 'iterations to convergence: ',iter + write(20,*) 'error estimate (infinity norm) on exit:', & + & ' ||r||/(||a||||x||+||b||) = ',err + write(20,*) 'max residual = ',resmx, resmxp + write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' + do i=1,m_problem + write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) + enddo + end if + end if +998 format(i8,4(2x,g20.14)) +993 format(i6,4(1x,e12.6)) + + + call psb_gefree(b_col, desc_a,info) + call psb_gefree(x_col, desc_a,info) + call psb_spfree(a, desc_a,info) + call psb_precfree(prec,info) + call psb_cdfree(desc_a,info) + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +end program sf_sample + + + + + diff --git a/test/fileread/zf_sample.f90 b/test/fileread/zf_sample.f90 index 7eab618b3..d6a99a78f 100644 --- a/test/fileread/zf_sample.f90 +++ b/test/fileread/zf_sample.f90 @@ -234,13 +234,14 @@ program zf_sample write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np write(*,'("Iterations to convergence: ",i6)')iter - write(*,'("Error estimate on exit: ",f7.2)')err - write(*,'("Time to buil prec. : ",es10.4)')tprec - write(*,'("Time to solve matrix : ",es10.4)')t2 - write(*,'("Time per iteration : ",es10.4)')t2/(iter) - write(*,'("Total time : ",es10.4)')t2+tprec - write(*,'("Residual norm 2 = ",es10.4)')resmx - write(*,'("Residual norm inf = ",es10.4)')resmxp + write(*,'("Error estimate on exit : ",es10.4)') err + write(*,'("Time to buil prec. : ",es10.4)')tprec + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/(iter) + write(*,'("Total time : ",es10.4)')t2+tprec + write(*,'("Residual norm 2 : ",es10.4)')resmx + write(*,'("Residual norm inf : ",es10.4)')resmxp +!!$ write(*,*)"Condition number : ",cond write(*,'("Total memory occupation for A: ",i10)')amatsize write(*,'("Total memory occupation for DESC_A: ",i10)')descsize write(*,'("Total memory occupation for PREC: ",i10)')precsize diff --git a/test/pargen/Makefile b/test/pargen/Makefile index fa097f81f..d306b2377 100644 --- a/test/pargen/Makefile +++ b/test/pargen/Makefile @@ -19,16 +19,16 @@ ppde: ppde.o $(F90LINK) ppde.o -o ppde $(PSBLAS_LIB) $(LDLIBS) /bin/mv ppde $(EXEDIR) -tpde: tpde.o - $(F90LINK) tpde.o -pg -o tpde $(PSBLAS_LIB) $(LDLIBS) - /bin/mv tpde $(EXEDIR) +spde: spde.o + $(F90LINK) spde.o -o spde $(PSBLAS_LIB) $(LDLIBS) + /bin/mv spde $(EXEDIR) .f90.o: $(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $< clean: - /bin/rm -f ppde.o $(EXEDIR)/ppde + /bin/rm -f ppde.o spde.o $(EXEDIR)/ppde verycleanlib: (cd ../..; make veryclean) lib: diff --git a/test/pargen/ppde.f90 b/test/pargen/ppde.f90 index 83a86da13..7316c3146 100644 --- a/test/pargen/ppde.f90 +++ b/test/pargen/ppde.f90 @@ -361,12 +361,13 @@ contains end interface ! local variables type(psb_dspmat_type) :: a real(psb_dpk_) :: zt(nbmax),glob_x,glob_y,glob_z - integer :: m,n,nnz,glob_row,loc_row + integer :: m,n,nnz,glob_row integer :: x,y,z,ia,indx_owner integer :: np, iam integer :: element integer, allocatable :: irow(:),icol(:) real(psb_dpk_), allocatable :: val(:) + integer, allocatable :: prv(:) ! deltah dimension of each grid cell ! deltat discretization time real(psb_dpk_) :: deltah diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index cdbab3ef0..25edd2827 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -2,7 +2,7 @@ BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO JAD -60 Domain size (acutal system is this**3) +100 Domain size (acutal system is this**3) 1 Stopping criterion 80 MAXIT -1 ITRACE diff --git a/test/pargen/spde.f90 b/test/pargen/spde.f90 new file mode 100644 index 000000000..e873dd1d8 --- /dev/null +++ b/test/pargen/spde.f90 @@ -0,0 +1,670 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ 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: ppde.f90 +! +! Program: ppde +! This sample program shows how to build and solve a sparse linear +! +! The program solves a linear system based on the partial differential +! equation +! +! +! +! The equation generated is +! +! b1 d d (u) b2 d d (u) a1 d (u)) a2 d (u))) +! - ------ - ------ + ----- + ------ + a3 u = 0 +! dx dx dy dy dx dy +! +! +! with Dirichlet boundary conditions on the unit cube +! +! 0<=x,y,z<=1 +! +! The equation is discretized with finite differences and uniform stepsize; +! the resulting discrete equation is +! +! ( u(x,y,z)(2b1+2b2+a1+a2)+u(x-1,y)(-b1-a1)+u(x,y-1)(-b2-a2)+ +! -u(x+1,y)b1-u(x,y+1)b2)*(1/h**2) +! +! Example taken from: C.T.Kelley +! Iterative Methods for Linear and Nonlinear Equations +! SIAM 1995 +! +! +! In this sample program the index space of the discretized +! computational domain is first numbered sequentially in a standard way, +! then the corresponding vector is distributed according to a BLOCK +! data distribution. +! +! Boundary conditions are set in a very simple way, by adding +! equations of the form +! +! u(x,y) = rhs(x,y) +! +program ppde + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod + use psb_util_mod + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer :: idim + + ! miscellaneous + real(psb_spk_), parameter :: one = 1.d0 + real(psb_spk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_sspmat_type) :: a + type(psb_sprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense matrices + real(psb_spk_), allocatable :: b(:), x(:) + ! blacs parameters + integer :: ictxt, iam, np + + ! solver parameters + integer :: iter, itmax,itrace, istopc, irst + real(psb_spk_) :: err, eps + + ! other variables + integer :: info + character(len=20) :: name,ch_err + + info=0 + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(2) + + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + call psb_cd_set_large_threshold(128) + call psb_barrier(ictxt) + t1 = psb_wtime() + call create_matrix(idim,a,b,x,desc_a,part_block,ictxt,afmt,info) + t2 = psb_wtime() - t1 + if(info /= 0) then + info=4010 + ch_err='create_matrix' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_amx(ictxt,t2) + if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es10.4)')t2 + if (iam == psb_root_) write(*,'(" ")') + ! + ! prepare the preconditioner. + ! + if(iam == psb_root_) write(0,'("Setting preconditioner to : ",a)')ptype + call psb_precinit(prec,ptype,info) + + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_precbld(a,desc_a,prec,info) + if(info /= 0) then + info=4010 + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) write(*,'("Preconditioner time : ",es10.4)')tprec + if (iam == psb_root_) write(*,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(*,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + eps = 1.d-9 + call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= 0) then + info=4010 + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + + if (iam == psb_root_) then + write(*,'(" ")') + write(*,'("Time to solve matrix : ",es10.4)')t2 + write(*,'("Time per iteration : ",es10.4)')t2/iter + write(*,'("Number of iterations : ",i0)')iter + write(*,'("Error estimate on exit : ",es10.4)')err + write(*,'("Info on exit : ",i0)')info + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(b,desc_a,info) + call psb_gefree(x,desc_a,info) + call psb_spfree(a,desc_a,info) +!!$ call psb_precfree(prec,info) + call psb_cdfree(desc_a,info) + if(info /= 0) then + info=4010 + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + +9999 continue + if(info /= 0) then + call psb_error(ictxt) + end if + call psb_exit(ictxt) + stop + +contains + ! + ! get iteration parameters from the command line + ! + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + integer :: ictxt + character(len=*) :: kmethd, ptype, afmt + integer :: idim, istopc,itmax,itrace,irst + integer :: np, iam + integer :: intbuf(10), ip + + call psb_info(ictxt, iam, np) + + if (iam==0) then + read(*,*) ip + if (ip >= 3) then + read(*,*) kmethd + read(*,*) ptype + read(*,*) afmt + + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,ptype) + + + read(*,*) idim + if (ip >= 4) then + read(*,*) istopc + else + istopc=1 + endif + if (ip >= 5) then + read(*,*) itmax + else + itmax=500 + endif + if (ip >= 6) then + read(*,*) itrace + else + itrace=-1 + endif + if (ip >= 7) then + read(*,*) irst + else + irst=1 + endif + ! broadcast parameters to all processors + + intbuf(1) = idim + intbuf(2) = istopc + intbuf(3) = itmax + intbuf(4) = itrace + intbuf(5) = irst + call psb_bcast(ictxt,intbuf(1:5)) + + write(*,'("Solving matrix : ell1")') + write(*,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(*,'("Number of processors : ",i0)')np + write(*,'("Data distribution : BLOCK")') + write(*,'("Preconditioner : ",a)') ptype + write(*,'("Iterative method : ",a)') kmethd + write(*,'(" ")') + else + ! wrong number of parameter, print an error message and exit + call pr_usage(0) + call psb_abort(ictxt) + stop 1 + endif + else + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,ptype) + call psb_bcast(ictxt,intbuf(1:5)) + idim = intbuf(1) + istopc = intbuf(2) + itmax = intbuf(3) + itrace = intbuf(4) + irst = intbuf(5) + end if + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine create_matrix(idim,a,b,xv,desc_a,parts,ictxt,afmt,info) + ! + ! discretize the partial diferential equation + ! + ! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u) + ! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u + ! dxdx dydy dzdz dx dy dz + ! + ! = 0 + ! + ! boundary condition: dirichlet + ! 0< x,y,z<1 + ! + ! u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+ + ! + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3 + + use psb_base_mod + implicit none + integer :: idim + integer, parameter :: nbmax=10 + real(psb_spk_), allocatable :: b(:),xv(:) + type(psb_desc_type) :: desc_a + integer :: ictxt, info + character :: afmt*5 + interface + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface ! local variables + type(psb_sspmat_type) :: a + real(psb_spk_) :: zt(nbmax),glob_x,glob_y,glob_z + integer :: m,n,nnz,glob_row + integer :: x,y,z,ia,indx_owner + integer :: np, iam + integer :: element + integer :: nv, inv + integer, allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer, allocatable :: prv(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_spk_) :: deltah + real(psb_spk_),parameter :: rhs=0.d0,one=1.d0,zero=0.d0 + real(psb_spk_) :: t1, t2, t3, tins, tasb + real(psb_spk_) :: a1, a2, a3, a4, b1, b2, b3 + external :: a1, a2, a3, a4, b1, b2, b3 + integer :: err_act + ! common area + + character(len=20) :: name, ch_err + + info = 0 + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + deltah = 1.d0/(idim-1) + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + + m = idim*idim*idim + n = m + nnz = ((n*9)/(np)) + if(iam == psb_root_) write(0,'("Generating Matrix (size=",i0x,")...")')n + + call psb_cdall(ictxt,desc_a,info,mg=n,parts=parts) + if (info == 0) call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + if (info == 0) call psb_geall(b,desc_a,info) + if (info == 0) call psb_geall(xv,desc_a,info) + if (info /= 0) then + info=4010 + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nbmax),irow(20*nbmax),& + &icol(20*nbmax),prv(np),stat=info) + if (info /= 0 ) then + info=4000 + call psb_errpush(info,name) + goto 9999 + endif + + tins = 0.d0 + call psb_barrier(ictxt) + t1 = psb_wtime() + + ! loop over rows belonging to current process in a block + ! distribution. + + ! icol(1)=1 + do glob_row = 1, n + call parts(glob_row,n,np,prv,nv) + do inv = 1, nv + indx_owner = prv(inv) + if (indx_owner == iam) then + ! local matrix pointer + element=1 + ! compute gridpoint coordinates + if (mod(glob_row,(idim*idim)) == 0) then + x = glob_row/(idim*idim) + else + x = glob_row/(idim*idim)+1 + endif + if (mod((glob_row-(x-1)*idim*idim),idim) == 0) then + y = (glob_row-(x-1)*idim*idim)/idim + else + y = (glob_row-(x-1)*idim*idim)/idim+1 + endif + z = glob_row-(x-1)*idim*idim-(y-1)*idim + ! glob_x, glob_y, glob_x coordinates + glob_x=x*deltah + glob_y=y*deltah + glob_z=z*deltah + + ! check on boundary points + zt(1) = 0.d0 + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + if (x==1) then + val(element)=-b1(glob_x,glob_y,glob_z)& + & -a1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*(-val(element)) + else + val(element)=-b1(glob_x,glob_y,glob_z)& + & -a1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-2)*idim*idim+(y-1)*idim+(z) + element=element+1 + endif + ! term depending on (x,y-1,z) + if (y==1) then + val(element)=-b2(glob_x,glob_y,glob_z)& + & -a2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b2(glob_x,glob_y,glob_z)& + & -a2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-2)*idim+(z) + element=element+1 + endif + ! term depending on (x,y,z-1) + if (z==1) then + val(element)=-b3(glob_x,glob_y,glob_z)& + & -a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b3(glob_x,glob_y,glob_z)& + & -a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z-1) + element=element+1 + endif + ! term depending on (x,y,z) + val(element)=2*b1(glob_x,glob_y,glob_z)& + & +2*b2(glob_x,glob_y,glob_z)& + & +2*b3(glob_x,glob_y,glob_z)& + & +a1(glob_x,glob_y,glob_z)& + & +a2(glob_x,glob_y,glob_z)& + & +a3(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z) + element=element+1 + ! term depending on (x,y,z+1) + if (z==idim) then + val(element)=-b1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b1(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y-1)*idim+(z+1) + element=element+1 + endif + ! term depending on (x,y+1,z) + if (y==idim) then + val(element)=-b2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element)) + else + val(element)=-b2(glob_x,glob_y,glob_z) + val(element) = val(element)/(deltah*& + & deltah) + icol(element)=(x-1)*idim*idim+(y)*idim+(z) + element=element+1 + endif + ! term depending on (x+1,y,z) + if (x 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call psb_sp_all(a,nnzero,nrow+1,nnzero,ircode) + if (ircode /= 0 ) then + write(0,*) 'Memory allocation failed' + goto 993 + end if + + a%m = nrow + a%k = ncol + a%fida = 'CSR' + a%descra='G' + + + if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) + read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero) + + if (present(b) .and. (rhscrd > 0)) then + call psb_ensure_size(nrow,b,info) + if (info == 0) read (infile,fmt=rhsfmt) (b(i),i=1,nrow) + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) + read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero) + + if (present(b) .and. (rhscrd > 0)) then + call psb_ensure_size(nrow,b,info) + if (info == 0) read (infile,fmt=rhsfmt) (b(i),i=1,nrow) + endif + + call psb_spcnv(a,ircode,afmt='csr') + if (ircode /= 0) goto 993 + + call psb_sp_reall(a,2*nnzero,ircode) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = a%aspk(i) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_spcnv(a,ircode,afmt='csr') + if (ircode /= 0) goto 993 + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + if (infile/=5) close(infile) + + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'DHB_READ: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'DHB_READ: Memory allocation failure' + return + end subroutine shb_read + + + subroutine shb_write(a,iret,iunit,filename,key,rhs,mtitle) + use psb_base_mod + implicit none + type(psb_sspmat_type), intent(in) :: a + integer, intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_spk_), optional :: rhs(:) + integer :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer, parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer, parameter :: jval=4,jrhs=4 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a1,13x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype,type*3 + + integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + if (psb_toupper(a%fida) == 'CSR') then + + nrow = a%m + ncol = a%k + nnzero = a%ia2(nrow+1)-1 + + neltvl = 0 + + ptrcrd = (nrow+1)/jptr + if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + rhstype = 'F' + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) + write (iout,fmt=indfmt) (a%ia1(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (a%aspk(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + + + else + + write(0,*) 'format: ',a%fida,' not yet implemented' + + endif + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return + end subroutine shb_write + subroutine dhb_read(a, iret, iunit, filename,b,mtitle) use psb_base_mod implicit none @@ -287,6 +531,324 @@ contains return end subroutine dhb_write +!!$ subroutine chb_read(a, iret, iunit, filename,b,mtitle) +!!$ use psb_base_mod +!!$ implicit none +!!$ type(psb_cspmat_type), intent(out) :: a +!!$ integer, intent(out) :: iret +!!$ integer, optional, intent(in) :: iunit +!!$ character(len=*), optional, intent(in) :: filename +!!$ real(psb_spk_), optional, allocatable :: b(:) +!!$ character(len=72), optional, intent(out) :: mtitle +!!$ +!!$ character :: rhstype,type*3,key*8 +!!$ character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 +!!$ integer :: indcrd, ptrcrd, totcrd,& +!!$ & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix +!!$ integer :: ircode, i,nzr,infile,info +!!$ character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' +!!$ character(len=*), parameter :: fmt11='(a1,13x,2i14)' +!!$ character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' +!!$ +!!$ iret = 0 +!!$ +!!$ if (present(filename)) then +!!$ if (filename=='-') then +!!$ infile=5 +!!$ else +!!$ if (present(iunit)) then +!!$ infile=iunit +!!$ else +!!$ infile=99 +!!$ endif +!!$ open(infile,file=filename, status='OLD', err=901, action='READ') +!!$ endif +!!$ else +!!$ if (present(iunit)) then +!!$ infile=iunit +!!$ else +!!$ infile=5 +!!$ endif +!!$ endif +!!$ +!!$ read (infile,fmt=fmt10) mtitle,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& +!!$ & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt +!!$ if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix +!!$ +!!$ +!!$ if (psb_tolower(type(1:1)) == 'c') then +!!$ if (psb_tolower(type(2:2)) == 'u') then +!!$ +!!$ call psb_sp_all(a,nnzero,nrow+1,nnzero,ircode) +!!$ +!!$ if (ircode /= 0 ) then +!!$ write(0,*) 'Memory allocation failed' +!!$ goto 993 +!!$ end if +!!$ +!!$ a%m = nrow +!!$ a%k = ncol +!!$ a%fida = 'CSR' +!!$ a%descra='G' +!!$ +!!$ read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) +!!$ read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero) +!!$ if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero) +!!$ +!!$ if (present(b) .and. (rhscrd > 0)) then +!!$ call psb_ensure_size(nrow,b,info) +!!$ if (info == 0) read (infile,fmt=rhsfmt) (b(i),i=1,nrow) +!!$ endif +!!$ +!!$ else if (psb_tolower(type(2:2)) == 's') then +!!$ +!!$ ! we are generally working with non-symmetric matrices, so +!!$ ! we de-symmetrize what we are about to read +!!$ +!!$ call psb_sp_all(nrow,ncol,a,nnzero,ircode) +!!$ +!!$ if (ircode /= 0 ) then +!!$ write(0,*) 'Memory allocation failed' +!!$ goto 993 +!!$ end if +!!$ a%fida = 'CSR' +!!$ a%descra='G' +!!$ +!!$ +!!$ read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) +!!$ read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero) +!!$ if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero) +!!$ +!!$ if (present(b) .and. (rhscrd > 0)) then +!!$ call psb_ensure_size(nrow,b,info) +!!$ if (info == 0) read (infile,fmt=rhsfmt) (b(i),i=1,nrow) +!!$ endif +!!$ +!!$ +!!$ call psb_spcnv(a,ircode,afmt='coo') +!!$ if (ircode /= 0) then +!!$ write(0,*) 'ipcsr2coo ',ircode +!!$ goto 993 +!!$ end if +!!$ +!!$ call psb_sp_reall(a,2*nnzero,ircode) +!!$ +!!$ if (ircode /= 0 ) then +!!$ write(0,*) 'Memory allocation failed' +!!$ goto 993 +!!$ end if +!!$ +!!$ ! A is now in COO format +!!$ nzr = nnzero +!!$ do i=1,nnzero +!!$ if (a%ia1(i) /= a%ia2(i)) then +!!$ nzr = nzr + 1 +!!$ a%aspk(nzr) = a%aspk(i) +!!$ a%ia1(nzr) = a%ia2(i) +!!$ a%ia2(nzr) = a%ia1(i) +!!$ end if +!!$ end do +!!$ a%infoa(psb_nnz_) = nzr +!!$ call psb_spcnv(a,ircode,afmt='csr') +!!$ if (ircode /= 0) then +!!$ write(0,*) 'ipcoo2csr ',ircode +!!$ goto 993 +!!$ end if +!!$ +!!$ else if (psb_tolower(type(2:2)) == 'h') then +!!$ +!!$ ! we are generally working with non-symmetric matrices, so +!!$ ! we de-symmetrize what we are about to read +!!$ +!!$ +!!$ call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) +!!$ +!!$ if (ircode /= 0 ) then +!!$ write(0,*) 'Memory allocation failed' +!!$ goto 993 +!!$ end if +!!$ a%fida = 'CSR' +!!$ a%descra='G' +!!$ +!!$ +!!$ read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) +!!$ read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero) +!!$ if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero) +!!$ +!!$ if (present(b) .and. (rhscrd > 0)) then +!!$ call psb_ensure_size(nrow,b,info) +!!$ if (info == 0) read (infile,fmt=rhsfmt) (b(i),i=1,nrow) +!!$ endif +!!$ +!!$ call psb_spcnv(a,ircode,afmt='coo') +!!$ if (ircode /= 0) then +!!$ write(0,*) 'ipcsr2coo ',ircode +!!$ goto 993 +!!$ end if +!!$ call psb_sp_reall(a,2*nnzero,ircode) +!!$ +!!$ if (ircode /= 0 ) then +!!$ write(0,*) 'Memory allocation failed' +!!$ goto 993 +!!$ end if +!!$ +!!$ ! A is now in COO format +!!$ nzr = nnzero +!!$ do i=1,nnzero +!!$ if (a%ia1(i) /= a%ia2(i)) then +!!$ nzr = nzr + 1 +!!$ a%aspk(nzr) = conjg(a%aspk(i)) +!!$ a%ia1(nzr) = a%ia2(i) +!!$ a%ia2(nzr) = a%ia1(i) +!!$ end if +!!$ end do +!!$ a%infoa(psb_nnz_) = nzr +!!$ call psb_spcnv(a,ircode,afmt='csr') +!!$ if (ircode /= 0) then +!!$ write(0,*) 'ipcoo2csr ',ircode +!!$ goto 993 +!!$ end if +!!$ +!!$ else +!!$ write(0,*) 'read_matrix: matrix type not yet supported' +!!$ iret=904 +!!$ end if +!!$ else +!!$ write(0,*) 'read_matrix: matrix type not yet supported' +!!$ iret=904 +!!$ end if +!!$ if (infile/=5) close(infile) +!!$ +!!$ return +!!$ +!!$ ! open failed +!!$901 iret=901 +!!$ write(0,*) 'read_matrix: could not open file ',filename,' for input' +!!$ return +!!$902 iret=902 +!!$ write(0,*) 'ZHB_READ: Unexpected end of file ' +!!$ return +!!$993 iret=993 +!!$ write(0,*) 'ZHB_READ: Memory allocation failure' +!!$ return +!!$ end subroutine chb_read +!!$ +!!$ +!!$ +!!$ +!!$ subroutine chb_write(a,iret,iunit,filename,key,rhs,mtitle) +!!$ use psb_base_mod +!!$ implicit none +!!$ type(psb_cspmat_type), intent(in) :: a +!!$ integer, intent(out) :: iret +!!$ character(len=*), optional, intent(in) :: mtitle +!!$ integer, optional, intent(in) :: iunit +!!$ character(len=*), optional, intent(in) :: filename +!!$ character(len=*), optional, intent(in) :: key +!!$ complex(psb_spk_), optional :: rhs(:) +!!$ integer :: iout +!!$ +!!$ character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' +!!$ integer, parameter :: jptr=10,jind=10 +!!$ character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' +!!$ integer, parameter :: jval=4,jrhs=4 +!!$ character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' +!!$ character(len=*), parameter :: fmt11='(a1,13x,2i14)' +!!$ character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' +!!$ +!!$ character(len=72) :: mtitle_ +!!$ character(len=8) :: key_ +!!$ +!!$ character :: rhstype,type*3 +!!$ +!!$ integer :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& +!!$ & nrow,ncol,nnzero, neltvl,nrhs,nrhsix +!!$ +!!$ iret = 0 +!!$ +!!$ if (present(filename)) then +!!$ if (filename=='-') then +!!$ iout=6 +!!$ else +!!$ if (present(iunit)) then +!!$ iout = iunit +!!$ else +!!$ iout=99 +!!$ endif +!!$ open(iout,file=filename, err=901, action='WRITE') +!!$ endif +!!$ else +!!$ if (present(iunit)) then +!!$ iout = iunit +!!$ else +!!$ iout=6 +!!$ endif +!!$ endif +!!$ +!!$ if (present(mtitle)) then +!!$ mtitle_ = mtitle +!!$ else +!!$ mtitle_ = 'Temporary PSBLAS title ' +!!$ endif +!!$ if (present(key)) then +!!$ key_ = key +!!$ else +!!$ key_ = 'PSBMAT00' +!!$ endif +!!$ if (psb_toupper(a%fida) == 'CSR') then +!!$ +!!$ nrow = a%m +!!$ ncol = a%k +!!$ nnzero = a%ia2(nrow+1)-1 +!!$ neltvl = 0 +!!$ ptrcrd = (nrow+1)/jptr +!!$ if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 +!!$ indcrd = nnzero/jind +!!$ if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 +!!$ valcrd = nnzero/jval +!!$ if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 +!!$ if (present(rhs)) then +!!$ if (size(rhs) 0) rhscrd = rhscrd + 1 +!!$ endif +!!$ nrhs = 1 +!!$ else +!!$ rhscrd = 0 +!!$ nrhs = 0 +!!$ end if +!!$ totcrd = ptrcrd + indcrd + valcrd + rhscrd +!!$ nrhsix = nrhs * nrow +!!$ rhstype='F' +!!$ type='CUA' +!!$ +!!$ write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& +!!$ & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt +!!$ if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix +!!$ write (iout,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1) +!!$ write (iout,fmt=indfmt) (a%ia1(i),i=1,nnzero) +!!$ if (valcrd > 0) write (iout,fmt=valfmt) (a%aspk(i),i=1,nnzero) +!!$ if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) +!!$ +!!$ +!!$ else +!!$ +!!$ write(0,*) 'format: ',a%fida,' not yet implemented' +!!$ +!!$ endif +!!$ +!!$ if (iout /= 6) close(iout) +!!$ +!!$ +!!$ return +!!$ +!!$901 continue +!!$ iret=901 +!!$ write(0,*) 'Error while opening ',filename +!!$ return +!!$ end subroutine chb_write subroutine zhb_read(a, iret, iunit, filename,b,mtitle) diff --git a/util/psb_mat_dist_mod.f90 b/util/psb_mat_dist_mod.f90 index 278d1c437..90ccf610f 100644 --- a/util/psb_mat_dist_mod.f90 +++ b/util/psb_mat_dist_mod.f90 @@ -32,12 +32,758 @@ module psb_mat_dist_mod interface psb_matdist - module procedure dmatdistf, dmatdistv, zmatdistf, zmatdistv + module procedure smatdistf, smatdistv, cmatdistv, cmatdistf, & + & dmatdistf, dmatdistv, zmatdistf, zmatdistv end interface contains + subroutine smatdistf (a_glob, a, parts, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none + + ! parameters + type(psb_sspmat_type) :: a_glob + real(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_sspmat_type) :: a + real(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + interface + + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + + ! local variables + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (a_glob%fida /= 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = size(a_glob%aspk) + nrhs = 1 + endif + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=nnzero/np) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + call parts(i_count,nrow,np,iwork, length_row) + + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + 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 smatdistf + + + subroutine smatdistv (a_glob, a, v, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none ! parameters + type(psb_sspmat_type) :: a_glob + real(psb_spk_) :: b_glob(:) + integer :: ictxt, v(:) + type(psb_sspmat_type) :: a + real(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: np, iam + integer :: i_count, j_count,& + & root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + logical, parameter :: newt=.true. + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distv' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (psb_toupper(a_glob%fida) /= 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + + nnzero = size(a_glob%aspk) + nrhs = 1 + end if + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + + call psb_cdall(ictxt,desc_a,info,vg=v) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='dsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(val)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + i_count = j_count + + end do + + ! default storage format for sparse matrix; we do not + ! expect duplicated entries. + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geasb(b,desc_a,info) + + if (iam == root) then + write(*,'("Descriptor assembly : ",es10.4)')t1-t0 + write(*,'("Sparse matrix assembly: ",es10.4)')t3-t2 + end if + + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + + 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 smatdistv + subroutine dmatdistf (a_glob, a, parts, ictxt, desc_a,& & b_glob, b, info, inroot,fmt) ! @@ -783,6 +1529,751 @@ contains end subroutine dmatdistv + subroutine cmatdistf (a_glob, a, parts, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none + + ! parameters + type(psb_cspmat_type) :: a_glob + complex(psb_spk_) :: b_glob(:) + integer :: ictxt + type(psb_cspmat_type) :: a + complex(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + interface + + ! .....user passed subroutine..... + subroutine parts(global_indx,n,np,pv,nv) + implicit none + integer, intent(in) :: global_indx, n, np + integer, intent(out) :: nv + integer, intent(out) :: pv(*) + end subroutine parts + end interface + + ! local variables + integer :: np, iam + integer :: length_row, i_count, j_count,& + & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + complex(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distf' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (a_glob%fida /= 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = size(a_glob%aspk) + nrhs = 1 + endif + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spall(a,desc_a,info,nnz=nnzero/np) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + call parts(i_count,nrow,np,iwork, length_row) + + if (length_row == 1) then + j_count = i_count + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwork, length_row) + if (length_row /= 1 ) exit + if (iwork(1) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + + i_count = j_count + + else + ! here processors are counted 1..np + do j_count = 1, length_row + k_count = iwork(j_count) + if (iam == root) then + + ll = 0 + do i= i_count, i_count + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (k_count == iam) then + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,ll,k_count) + call psb_snd(ictxt,irow(1:ll),k_count) + call psb_snd(ictxt,icol(1:ll),k_count) + call psb_snd(ictxt,val(1:ll),k_count) + call psb_snd(ictxt,b_glob(i_count),k_count) + call psb_rcv(ictxt,ll,k_count) + endif + else if (iam /= root) then + if (k_count == iam) then + call psb_rcv(ictxt,ll,root) + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count),root) + call psb_snd(ictxt,ll,root) + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + end do + i_count = i_count + 1 + endif + end do + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(*,*) 'descriptor assembly: ',t1-t0 + write(*,*) 'sparse matrix assembly: ',t3-t2 + end if + + call psb_geasb(b,desc_a,info) + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(val,irow,icol,stat=info) + if(info/=0)then + info=4010 + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + if (iam == root) write (*, fmt = *) 'end matdist' + + 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 cmatdistf + + + subroutine cmatdistv (a_glob, a, v, ictxt, desc_a,& + & b_glob, b, info, inroot,fmt) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(d_spmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! a%fida =='csr' + ! a%aspk for coefficient values + ! a%ia1 for column indices + ! a%ia2 for row pointers + ! a%m for number of global matrix rows + ! a%k for number of global matrix columns + ! on exit : undefined, with unassociated pointers. + ! + ! type(d_spmat) :: a + ! on entry: fresh variable. + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer, intent(in) :: global_indx, n, np + ! integer, intent(out) :: nv + ! integer, intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer :: ictxt + ! on entry: blacs context. + ! on exit : unchanged. + ! + ! type (desc_type) :: desc_a + ! on entry: fresh variable. + ! on exit : the updated array descriptor + ! + ! real(psb_dpk_), optional :: b_glob(:) + ! on entry: this contains right hand side. + ! on exit : + ! + ! real(psb_dpk_), allocatable, optional :: b(:) + ! on entry: fresh variable. + ! on exit : this will contain the local right hand side. + ! + ! integer, optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + implicit none ! parameters + type(psb_cspmat_type) :: a_glob + complex(psb_spk_) :: b_glob(:) + integer :: ictxt, v(:) + type(psb_cspmat_type) :: a + complex(psb_spk_), allocatable :: b(:) + type(psb_desc_type) :: desc_a + integer, intent(out) :: info + integer, optional :: inroot + character(len=5), optional :: fmt + + integer :: np, iam + integer :: i_count, j_count,& + & root, liwork, nrow, ncol, nnzero, nrhs,& + & i,ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer, allocatable :: iwork(:) + character :: afmt*5 + integer, allocatable :: irow(:),icol(:) + complex(psb_spk_), allocatable :: val(:) + integer, parameter :: nb=30 + logical, parameter :: newt=.true. + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = 0 + err = 0 + name = 'mat_distv' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + + call psb_info(ictxt, iam, np) + if (iam == root) then + ! extract information from a_glob + if (psb_toupper(a_glob%fida) /= 'CSR') then + info=135 + ch_err='CSR' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + nrow = a_glob%m + ncol = a_glob%k + if (nrow /= ncol) then + write(0,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + + nnzero = size(a_glob%aspk) + nrhs = 1 + end if + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), stat = info) + if (info /= 0) then + write(0,*) 'matdist allocation failed' + info=4025 + int_err(1)=liwork + call psb_errpush(info,name,i_err=int_err,a_err='integer') + goto 9999 + endif + + call psb_cdall(ictxt,desc_a,info,vg=v) + if(info/=0) then + info=4010 + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) + if(info/=0) then + info=4010 + ch_err='psb_psspall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geall(b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_psdsall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + j_count = i_count + iproc = v(i_count) + + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + ll = 0 + do i= i_count, j_count-1 + call psb_sp_getrow(i,a_glob,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= 0) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(0,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + if (iproc == iam) then + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& + & b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='dsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_snd(ictxt,b_glob(i_count:j_count-1),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + else if (iam /= root) then + + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(val)) then + write(0,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info/=0) then + info=4010 + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) + call psb_snd(ictxt,ll,root) + + call psb_spins(ll,irow,icol,val,a,desc_a,info) + if(info/=0) then + info=4010 + ch_err='spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& + & b_glob(i_count:i_count+nnr-1),b,desc_a,info) + if(info/=0) then + info=4010 + ch_err='psdsins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + endif + i_count = j_count + + end do + + ! default storage format for sparse matrix; we do not + ! expect duplicated entries. + + if (present(fmt)) then + afmt=fmt + else + afmt = 'CSR' + endif + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + t3 = psb_wtime() + if(info/=0)then + info=4010 + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_geasb(b,desc_a,info) + + if (iam == root) then + write(*,'("Descriptor assembly : ",es10.4)')t1-t0 + write(*,'("Sparse matrix assembly: ",es10.4)')t3-t2 + end if + + if(info/=0)then + info=4010 + ch_err='psdsasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(iwork) + + 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 cmatdistv + subroutine zmatdistf (a_glob, a, parts, ictxt, desc_a,& & b_glob, b, info, inroot,fmt) ! diff --git a/util/psb_mmio_mod.f90 b/util/psb_mmio_mod.f90 index f6ec466e2..c36e0c78f 100644 --- a/util/psb_mmio_mod.f90 +++ b/util/psb_mmio_mod.f90 @@ -33,14 +33,160 @@ module psb_mmio_mod public mm_mat_read, mm_mat_write interface mm_mat_read - module procedure dmm_mat_read, zmm_mat_read + module procedure smm_mat_read, dmm_mat_read, cmm_mat_read, zmm_mat_read end interface interface mm_mat_write - module procedure dmm_mat_write,zmm_mat_write + module procedure smm_mat_write, dmm_mat_write, cmm_mat_write, zmm_mat_write end interface contains + subroutine smm_mat_read(a, iret, iunit, filename) + use psb_base_mod + implicit none + type(psb_sspmat_type), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + iret=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + call psb_sp_all(nrow,ncol,a,nnzero,ircode) + a%fida = 'COO' + a%descra = 'G' + if (ircode /= 0) goto 993 + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i) + end do + a%infoa(psb_nnz_) = nnzero + call psb_spcnv(a,ircode,afmt='csr') + + else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + a%fida = 'COO' + a%descra = 'G' + if (ircode /= 0) goto 993 + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = a%aspk(i) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_spcnv(a,ircode,afmt='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return + end subroutine smm_mat_read + + + subroutine smm_mat_write(a,mtitle,iret,iunit,filename) + use psb_base_mod + implicit none + type(psb_sspmat_type), intent(in) :: a + integer, intent(out) :: iret + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call psb_csprt(iout,a,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return + end subroutine smm_mat_write + subroutine dmm_mat_read(a, iret, iunit, filename) use psb_base_mod implicit none @@ -142,9 +288,6 @@ contains end subroutine dmm_mat_read - - - subroutine dmm_mat_write(a,mtitle,iret,iunit,filename) use psb_base_mod implicit none @@ -190,7 +333,180 @@ contains return end subroutine dmm_mat_write + subroutine cmm_mat_read(a, iret, iunit, filename) + use psb_base_mod + implicit none + type(psb_cspmat_type), intent(out) :: a + integer, intent(out) :: iret + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer :: nrow, ncol, nnzero + integer :: ircode, i,nzr,infile + real(psb_spk_) :: are, aim + iret = 0 + + if (present(filename)) then + if (filename=='-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + write(0,*) 'READ_MATRIX: input file type not yet supported' + iret=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + call psb_sp_all(nrow,ncol,a,nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + a%infoa(psb_nnz_) = nnzero + + call psb_spcnv(a,ircode,afmt='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = a%aspk(i) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_spcnv(a,ircode,afmt='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call psb_sp_all(nrow,ncol,a,2*nnzero,ircode) + if (ircode /= 0) goto 993 + a%fida = 'COO' + a%descra = 'G' + do i=1,nnzero + read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),are,aim + a%aspk(i) = cmplx(are,aim) + end do + + nzr = nnzero + do i=1,nnzero + if (a%ia1(i) /= a%ia2(i)) then + nzr = nzr + 1 + a%aspk(nzr) = conjg(a%aspk(i)) + a%ia1(nzr) = a%ia2(i) + a%ia2(nzr) = a%ia1(i) + end if + end do + a%infoa(psb_nnz_) = nzr + call psb_spcnv(a,ircode,afmt='csr') + + else + write(0,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + if (infile/=5) close(infile) + return + + ! open failed +901 iret=901 + write(0,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(0,*) 'READ_MATRIX: Unexpected end of file ' + return +993 iret=993 + write(0,*) 'READ_MATRIX: Memory allocation failure' + return + end subroutine cmm_mat_read + + + + subroutine cmm_mat_write(a,mtitle,iret,iunit,filename) + use psb_base_mod + implicit none + type(psb_cspmat_type), intent(in) :: a + integer, intent(out) :: iret + character(len=*), intent(in) :: mtitle + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: iout + + + iret = 0 + + if (present(filename)) then + if (filename=='-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call psb_csprt(iout,a,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(0,*) 'Error while opening ',filename + return + end subroutine cmm_mat_write subroutine zmm_mat_read(a, iret, iunit, filename) use psb_base_mod diff --git a/util/psb_read_mat_mod.f90 b/util/psb_read_mat_mod.f90 index 2b0c21ba2..7b178f6d5 100644 --- a/util/psb_read_mat_mod.f90 +++ b/util/psb_read_mat_mod.f90 @@ -60,15 +60,103 @@ ! module psb_read_mat_mod interface read_mat - module procedure dreadmat, zreadmat + module procedure sreadmat, dreadmat, creadmat, zreadmat end interface interface read_rhs - module procedure dread_rhs, zread_rhs + module procedure sread_rhs, cread_rhs, dread_rhs, zread_rhs end interface contains + subroutine sreadmat (filename, a, ictxt, inroot) + use psb_base_mod + use psb_mmio_mod + implicit none + integer :: ictxt + type(psb_sspmat_type) :: a + character(len=*) :: filename + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: info, root, np, me + + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, me, np) + if (me == root) then + write(*, '("Reading matrix...")') ! open input file + call mm_mat_read(a,info,infile,filename) + if (info /= 0) then + write(0,*) 'Error return from MM_MAT_READ ',info + call psb_abort(ictxt) ! Unexpected End of File + endif + end if + return + + end subroutine sreadmat + + + subroutine sread_rhs (filename, b, ictxt, inroot) + use psb_base_mod + implicit none + integer :: ictxt + character :: filename*(*) + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: nrow, ncol, i,root, np, me, ircode, j + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + real(psb_spk_), allocatable :: b(:,:) + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, me, np) + if (me == root) then + write(*, '("Reading rhs...")') ! open input file + open(infile,file=filename, status='old', err=901, action="read") + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym + write(0,*)'obj fmt',object, fmt + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + call psb_abort(ictxt) + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) + + else + write(0,*) 'read_rhs: rhs type not yet supported' + call psb_abort(ictxt) + end if ! read right hand sides + write(*,*) 'end read_rhs' + end if + return + ! open failed +901 write(0,*) 'read_rhs: could not open file ',& + & infile,' for input' + call psb_abort(ictxt) ! unexpected end of file +902 write(0,*) 'read_rhs: unexpected end of file ',infile,& + & ' during input' + call psb_abort(ictxt) ! allocation failed +993 write(0,*) 'read_rhs: memory allocation failure' + call psb_abort(ictxt) + end subroutine sread_rhs + + subroutine dreadmat (filename, a, ictxt, inroot) use psb_base_mod use psb_mmio_mod @@ -109,7 +197,7 @@ contains integer :: nrow, ncol, i,root, np, me, ircode, j character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 - real(kind(1.0d0)), allocatable :: b(:,:) + real(psb_dpk_), allocatable :: b(:,:) if (present(inroot)) then root = inroot else @@ -157,6 +245,99 @@ contains end subroutine dread_rhs + subroutine creadmat (filename, a, ictxt, inroot) + use psb_base_mod + use psb_mmio_mod + implicit none + integer :: ictxt + type(psb_cspmat_type) :: a + character(len=*) :: filename + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: info, root, np, me + + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, me, np) + if (me == root) then + write(*, '("Reading matrix...")') ! open input file + call mm_mat_read(a,info,infile,filename) + if (info /= 0) then + write(0,*) 'Error return from MM_MAT_READ ',info + call psb_abort(ictxt) ! Unexpected End of File + endif + end if + return + + end subroutine creadmat + + + subroutine cread_rhs (filename, b, ictxt, inroot) + use psb_base_mod + implicit none + integer :: ictxt + character :: filename*(*) + integer, optional :: inroot + integer, parameter :: infile = 2 + integer :: nrow, ncol, i,root, np, me, ircode, j + character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& + & line*1024 + real(psb_spk_) :: bre, bim + complex(psb_spk_), allocatable :: b(:,:) + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, me, np) + if (me == root) then + write(*, '("Reading rhs...")') ! open input file + open(infile,file=filename, status='old', err=901, action="read") + read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym +!!$ write(0,*)'obj fmt',object, fmt + if ( (object /= 'matrix').or.(fmt /= 'array')) then + write(0,*) 'read_rhs: input file type not yet supported' + call psb_abort(ictxt) + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + + read(line,fmt=*)nrow,ncol + + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + allocate(b(nrow,ncol),stat = ircode) + if (ircode /= 0) goto 993 + do j=1, ncol + do i=1, nrow + read(infile,fmt=*,end=902) bre,bim + b(i,j) = cmplx(bre,bim) + end do + end do + else + write(0,*) 'read_rhs: rhs type not yet supported' + call psb_abort(ictxt) + end if ! read right hand sides + write(*,*) 'end read_rhs' + end if + return + ! open failed +901 write(0,*) 'read_rhs: could not open file ',& + & infile,' for input' + call psb_abort(ictxt) ! unexpected end of file +902 write(0,*) 'read_rhs: unexpected end of file ',infile,& + & ' during input' + call psb_abort(ictxt) ! allocation failed +993 write(0,*) 'read_rhs: memory allocation failure' + call psb_abort(ictxt) + end subroutine cread_rhs + + subroutine zreadmat (filename, a, ictxt, inroot) use psb_base_mod use psb_mmio_mod @@ -198,7 +379,7 @@ contains character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 real(psb_dpk_) :: bre, bim - complex(kind(1.0d0)), allocatable :: b(:,:) + complex(psb_dpk_), allocatable :: b(:,:) if (present(inroot)) then root = inroot else @@ -250,5 +431,4 @@ contains end subroutine zread_rhs - end module psb_read_mat_mod