diff --git a/LICENSE.MD2P4 b/LICENSE.MD2P4 deleted file mode 100644 index 6df0b8a9..00000000 --- a/LICENSE.MD2P4 +++ /dev/null @@ -1,33 +0,0 @@ - MD2P4 - Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS - for - Parallel Sparse BLAS v2.0 - (C) Copyright 2006 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. - diff --git a/README b/README index 59d87de1..27d265bc 100644 --- a/README +++ b/README @@ -1,6 +1,6 @@ This directory contains the PSBLAS library, version 2.1.0 - + Version 1.0 of the library was described in: S. Filippone, M. Colajanni PSBLAS: A library for parallel linear algebra computation on sparse matrices diff --git a/base/Makefile b/base/Makefile index 3ca78814..c7168856 100644 --- a/base/Makefile +++ b/base/Makefile @@ -12,7 +12,7 @@ lib: (cd serial; make lib LIBNAME=$(BASELIBNAME)) (cd psblas; make lib LIBNAME=$(BASELIBNAME)) /bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR) - /bin/cp -p $(LIBMOD) $(LIBDIR) + /bin/cp -p $(LIBMOD) *$(.mod) $(LIBDIR) clean: (cd modules; make clean) diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 20828a4d..863172eb 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -193,7 +193,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -365,7 +365,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index e0b3a9d4..a3b23943 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -45,7 +45,7 @@ ! tran - character(optional). ???. ! mode - integer(optional). ! -subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) +subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_descriptor_type use psb_const_mod use psi_mod @@ -60,13 +60,13 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) integer, intent(out) :: info real(kind(1.d0)), intent(in), optional :: alpha real(kind(1.d0)), optional, target :: work(:) - integer, intent(in), optional :: mode,jx,ik + 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 + & err, liwork,data_ real(kind(1.d0)),pointer :: iwork(:), xp(:,:) character :: ltran character(len=20) :: name, ch_err @@ -115,6 +115,14 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) else ltran = 'N' endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(mode)) then imode = mode else @@ -177,16 +185,10 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) xp => x(iix:size(x,1),jjx:jjx+k-1) if(ltran.eq.'N') then call psi_swapdata(imode,k,0.d0,xp,& - & desc_a,iwork,info,data=psb_comm_halo_) -!!$ call PSI_dSwapData(imode,k,0.d0,x(1,jjx),& -!!$ & size(x,1),desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) + & desc_a,iwork,info,data=data_) else if((ltran.eq.'T').or.(ltran.eq.'H')) then call psi_swaptran(imode,k,1.d0,xp,& &desc_a,iwork,info) -!!$ call PSI_dSwapTran(imode,k,1.d0,x(1,jjx),& -!!$ & size(x,1),desc_a%matrix_data,& -!!$ & desc_a%halo_index,iwork,liwork,info) end if if(info.ne.0) then @@ -203,7 +205,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -257,7 +259,7 @@ end subroutine psb_dhalom ! tran - character(optional). ???. ! mode - integer(optional). ! -subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) +subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) use psb_descriptor_type use psb_const_mod use psi_mod @@ -272,13 +274,13 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) integer, intent(out) :: info real(kind(1.d0)), intent(in), optional :: alpha real(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode + 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, i,& - & err, liwork + & err, liwork,data_ real(kind(1.d0)),pointer :: iwork(:) character :: ltran character(len=20) :: name, ch_err @@ -311,6 +313,11 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) else ltran = 'N' endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif if (present(mode)) then imode = mode else @@ -368,7 +375,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) ! exchange halo elements if(ltran.eq.'N') then call psi_swapdata(imode,0.d0,x(iix:size(x)),& - & desc_a,iwork,info,data=psb_comm_halo_) + & desc_a,iwork,info,data=data_) else if((ltran.eq.'T').or.(ltran.eq.'H')) then call psi_swaptran(imode,1.d0,x(iix:size(x)),& & desc_a,iwork,info) @@ -388,7 +395,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index a225481f..f24705b7 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -208,7 +208,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -411,7 +411,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_dscatter.f90 b/base/comm/psb_dscatter.f90 index b128634a..b344f88b 100644 --- a/base/comm/psb_dscatter.f90 +++ b/base/comm/psb_dscatter.f90 @@ -253,7 +253,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -445,7 +445,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 55d51a66..520c7134 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -199,7 +199,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -387,7 +387,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 7ac60061..238496d4 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -195,7 +195,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -368,7 +368,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 5d4ba301..937cba8c 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -198,7 +198,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -384,7 +384,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 3249e1ff..8faa0cb3 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -208,7 +208,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -412,7 +412,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zscatter.f90 b/base/comm/psb_zscatter.f90 index 8adbe953..3c677834 100644 --- a/base/comm/psb_zscatter.f90 +++ b/base/comm/psb_zscatter.f90 @@ -253,7 +253,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -445,7 +445,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_compute_size.f90 b/base/internals/psi_compute_size.f90 index 8c27ce06..ee43cf46 100644 --- a/base/internals/psi_compute_size.f90 +++ b/base/internals/psi_compute_size.f90 @@ -31,6 +31,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) use psb_const_mod + use psb_descriptor_type use psb_error_mod use psb_penv_mod implicit none @@ -117,7 +118,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_crea_bnd_elem.f90 b/base/internals/psi_crea_bnd_elem.f90 index 6203ab91..2a79ab8a 100644 --- a/base/internals/psi_crea_bnd_elem.f90 +++ b/base/internals/psi_crea_bnd_elem.f90 @@ -111,7 +111,7 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 388492d0..dc08c337 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -150,7 +150,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_crea_ovr_elem.f90 b/base/internals/psi_crea_ovr_elem.f90 index 54244a3c..28930043 100644 --- a/base/internals/psi_crea_ovr_elem.f90 +++ b/base/internals/psi_crea_ovr_elem.f90 @@ -190,7 +190,7 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/internals/psi_desc_index.f90 b/base/internals/psi_desc_index.f90 index 3c146581..d26d937a 100644 --- a/base/internals/psi_desc_index.f90 +++ b/base/internals/psi_desc_index.f90 @@ -257,7 +257,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_dl_check.f90 b/base/internals/psi_dl_check.f90 index 4ea4a133..9c374970 100644 --- a/base/internals/psi_dl_check.f90 +++ b/base/internals/psi_dl_check.f90 @@ -31,6 +31,7 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) use psb_const_mod + use psb_descriptor_type implicit none integer :: np,dl_lda,length_dl(0:np) diff --git a/base/internals/psi_dswapdata.f90 b/base/internals/psi_dswapdata.f90 index bd9096eb..fd0ade4d 100644 --- a/base/internals/psi_dswapdata.f90 +++ b/base/internals/psi_dswapdata.f90 @@ -48,7 +48,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, pnti + & snd_pt, rcv_pt, pnti, data_ integer :: krecvid, ksendid integer, allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd @@ -90,29 +90,33 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then - if(data == psb_comm_halo_) then - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - else if(data == psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - else - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - end if + data_ = data else + data_ = psb_comm_halo_ + end if + + select case(data_) + case(psb_comm_halo_) d_idx => desc_a%halo_index totxch = desc_a%matrix_data(psb_thal_xch_) idxr = desc_a%matrix_data(psb_thal_rcv_) idxs = desc_a%matrix_data(psb_thal_snd_) - end if + + case(psb_comm_ovr_) + d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) + + case(psb_comm_ext_) + d_idx => desc_a%ext_index + totxch = desc_a%matrix_data(psb_text_xch_) + idxr = desc_a%matrix_data(psb_text_rcv_) + idxs = desc_a%matrix_data(psb_text_snd_) + case default + call psb_errpush(4010,name,a_err='wrong Data selector') + goto 9999 + end select idxr = idxr * n idxs = idxs * n @@ -146,7 +150,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) 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 @@ -218,7 +222,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) proc_to_comm = d_idx(pnti+psb_proc_id_) nerv = d_idx(pnti+psb_n_elem_recv_) nesd = d_idx(pnti+nerv+psb_n_elem_send_) - + if (proc_to_comm < me) then call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) @@ -226,7 +230,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) end if - + rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -237,7 +241,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - + pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -251,7 +255,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_double_precision,prcid(i),& & p2ptag, icomm,rvhd(i),iret) - + rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -288,7 +292,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_errpush(info,name,i_err=int_err) goto 9999 end if - + rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd pnti = pnti + nerv + nesd + 3 @@ -304,7 +308,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) nesd = d_idx(pnti+nerv+psb_n_elem_send_) p2ptag = krecvid(ictxt,proc_to_comm,me) - + if (proc_to_comm /= me) then call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then @@ -316,7 +320,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) end if pnti = pnti + nerv + nesd + 3 end do - + else if (swap_send) then @@ -329,7 +333,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) nerv = d_idx(pnti+psb_n_elem_recv_) nesd = d_idx(pnti+nerv+psb_n_elem_send_) 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 @@ -398,7 +402,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -456,7 +460,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, & - & idx_pt, snd_pt, rcv_pt, n, pnti + & idx_pt, snd_pt, rcv_pt, n, pnti, data_ integer, allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd @@ -500,30 +504,34 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then - if(data == psb_comm_halo_) then - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - else if(data == psb_comm_ovr_) then - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - else - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - end if + data_ = data else + data_ = psb_comm_halo_ + end if + + + select case(data_) + case(psb_comm_halo_) d_idx => desc_a%halo_index totxch = desc_a%matrix_data(psb_thal_xch_) idxr = desc_a%matrix_data(psb_thal_rcv_) idxs = desc_a%matrix_data(psb_thal_snd_) - end if + case(psb_comm_ovr_) + d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) + + case(psb_comm_ext_) + d_idx => desc_a%ext_index + totxch = desc_a%matrix_data(psb_text_xch_) + idxr = desc_a%matrix_data(psb_text_rcv_) + idxs = desc_a%matrix_data(psb_text_snd_) + case default + call psb_errpush(4010,name,a_err='wrong Data selector') + goto 9999 + end select idxr = idxr * n idxs = idxs * n @@ -793,7 +801,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_dswaptran.f90 b/base/internals/psi_dswaptran.f90 index 2f47d310..ceeaf4e9 100644 --- a/base/internals/psi_dswaptran.f90 +++ b/base/internals/psi_dswaptran.f90 @@ -387,7 +387,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -791,7 +791,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_extrct_dl.f b/base/internals/psi_extrct_dl.f index 2a08d724..8a77acfe 100644 --- a/base/internals/psi_extrct_dl.f +++ b/base/internals/psi_extrct_dl.f @@ -120,6 +120,7 @@ c length_dl integer array(0:np) c length_dl(i) is the length of dep_list(*,i) list use psb_penv_mod use psb_const_mod + use psb_error_mod use psb_descriptor_type implicit none include 'mpif.h' @@ -141,7 +142,8 @@ c .....local scalars... parameter (debug=.false.) character name*20 name='psi_extrct_dl' - call fcpsb_get_erraction(err_act) + + call psb_erractionsave(err_act) info = 0 ictxt = desc_data(psb_ctxt_) @@ -168,7 +170,9 @@ c ..if number of element to be exchanged !=0 proc=desc_str(i) if ((proc.lt.0).or.(proc.ge.nprow)) then if (debug) write(0,*) 'extract error ',i,desc_str(i) - info = 3999 + info = 9999 + int_err(1) = i + int_err(2) = desc_str(i) goto 998 endif ! if((me.eq.1).and.(proc.eq.3))write(0,*)'found 3' @@ -260,12 +264,18 @@ c ... check for errors... + dep_list,dl_lda,mpi_integer,icomm,info) deallocate(itmp) + call psb_erractionrestore(err_act) return + 9999 continue - call fcpsb_errpush(info,name,int_err) - if(err_act.eq.act_abort) then - call fcpsb_perror(ictxt) + + call psb_errpush(info,name,i_err=int_err) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_ret_) then + return + else + call psb_error() endif return diff --git a/base/internals/psi_fnd_owner.f90 b/base/internals/psi_fnd_owner.f90 index 8d70433e..cc556fcd 100644 --- a/base/internals/psi_fnd_owner.f90 +++ b/base/internals/psi_fnd_owner.f90 @@ -133,7 +133,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_idx_cnv.f90 b/base/internals/psi_idx_cnv.f90 index a12b2528..b5de5f3b 100644 --- a/base/internals/psi_idx_cnv.f90 +++ b/base/internals/psi_idx_cnv.f90 @@ -139,7 +139,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) @@ -326,7 +326,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_idx_ins_cnv.f90 b/base/internals/psi_idx_ins_cnv.f90 index 9b716d01..05c2bf52 100644 --- a/base/internals/psi_idx_ins_cnv.f90 +++ b/base/internals/psi_idx_ins_cnv.f90 @@ -130,7 +130,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) @@ -368,7 +368,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_iswapdata.f90 b/base/internals/psi_iswapdata.f90 index 6336c51c..6927c013 100644 --- a/base/internals/psi_iswapdata.f90 +++ b/base/internals/psi_iswapdata.f90 @@ -398,7 +398,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -793,7 +793,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_iswaptran.f90 b/base/internals/psi_iswaptran.f90 index ce1b1b52..afa039ed 100644 --- a/base/internals/psi_iswaptran.f90 +++ b/base/internals/psi_iswaptran.f90 @@ -388,7 +388,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -791,7 +791,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_ldsc_pre_halo.f90 b/base/internals/psi_ldsc_pre_halo.f90 index 4dda9c78..9432855d 100644 --- a/base/internals/psi_ldsc_pre_halo.f90 +++ b/base/internals/psi_ldsc_pre_halo.f90 @@ -28,7 +28,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_ldsc_pre_halo(desc,info) +subroutine psi_ldsc_pre_halo(desc,ext_hv,info) use psb_descriptor_type use psb_serial_mod use psb_const_mod @@ -38,6 +38,7 @@ subroutine psi_ldsc_pre_halo(desc,info) use psi_mod, only : psi_fnd_owner implicit none type(psb_desc_type), intent(inout) :: desc + logical, intent(in) :: ext_hv integer, intent(out) :: info integer,allocatable :: helem(:),hproc(:) @@ -68,8 +69,9 @@ subroutine psi_ldsc_pre_halo(desc,info) if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then - write(0,*) 'Invalid input descriptor in ldsc_pre_halo' - + info = 1122 + call psb_errpush(info,name) + goto 9999 end if @@ -115,56 +117,55 @@ subroutine psi_ldsc_pre_halo(desc,info) end if end do - nh = (n_col-n_row) - if (nh > 0) then - Allocate(helem(nh),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - do i=1, nh - helem(i) = desc%loc_to_glob(n_row+i) - end do - - call psi_fnd_owner(nh,helem,hproc,desc,info) - allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - j = 1 - do i=1,nh - tmphl(j+0) = hproc(i) - if (tmphl(j+0)<0) then - write(0,*) 'Unrecoverable error: missing proc from asb' + if (.not.ext_hv) then + nh = (n_col-n_row) + if (nh > 0) then + Allocate(helem(nh),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 end if - tmphl(j+1) = 1 - tmphl(j+2) = n_row+i - j = j + 3 - end do - tmphl(j) = -1 - lhalo = j - nhalo = (lhalo-1)/3 - else - allocate(tmphl(1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - tmphl=-1 - endif - - call psb_transfer(tmphl,desc%halo_index,info) + do i=1, nh + helem(i) = desc%loc_to_glob(n_row+i) + end do + call psi_fnd_owner(nh,helem,hproc,desc,info) + allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + j = 1 + do i=1,nh + tmphl(j+0) = hproc(i) + if (tmphl(j+0)<0) then + write(0,*) 'Unrecoverable error: missing proc from asb' + end if + tmphl(j+1) = 1 + tmphl(j+2) = n_row+i + j = j + 3 + end do + tmphl(j) = -1 + lhalo = j + nhalo = (lhalo-1)/3 + else + allocate(tmphl(1),stat=info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + tmphl=-1 + endif + call psb_transfer(tmphl,desc%halo_index,info) + end if call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index dc01a833..9116ff86 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -81,7 +81,7 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/internals/psi_zswapdata.f90 b/base/internals/psi_zswapdata.f90 index ca2271e1..70f69d9f 100644 --- a/base/internals/psi_zswapdata.f90 +++ b/base/internals/psi_zswapdata.f90 @@ -398,7 +398,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -793,7 +793,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/internals/psi_zswaptran.f90 b/base/internals/psi_zswaptran.f90 index 084294a4..3a3d9c03 100644 --- a/base/internals/psi_zswaptran.f90 +++ b/base/internals/psi_zswaptran.f90 @@ -382,7 +382,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -782,7 +782,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/modules/Makefile b/base/modules/Makefile index 663cf28a..40f8934d 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -18,7 +18,7 @@ INCDIRS = -I . psb_realloc_mod.o : psb_error_mod.o -psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_string_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 psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o @@ -34,6 +34,7 @@ lib: mpfobjs $(MODULES) $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) /bin/cp -p $(LIBMOD) ./parts.fh $(LIBDIR) + /bin/cp -p *$(.mod) $(LIBDIR) mpfobjs: diff --git a/base/modules/psb_check_mod.f90 b/base/modules/psb_check_mod.f90 index dd532232..f63128d5 100644 --- a/base/modules/psb_check_mod.f90 +++ b/base/modules/psb_check_mod.f90 @@ -164,7 +164,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -284,7 +284,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if @@ -425,7 +425,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/modules/psb_comm_mod.f90 b/base/modules/psb_comm_mod.f90 index a7d97344..eb54841f 100644 --- a/base/modules/psb_comm_mod.f90 +++ b/base/modules/psb_comm_mod.f90 @@ -66,24 +66,24 @@ module psb_comm_mod end interface interface psb_halo - subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) + subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_descriptor_type real(kind(1.d0)), intent(inout) :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info real(kind(1.d0)), intent(in), optional :: alpha real(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode,jx,ik + 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) + subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) use psb_descriptor_type real(kind(1.d0)), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info real(kind(1.d0)), intent(in), optional :: alpha real(kind(1.d0)), target, optional :: work(:) - integer, intent(in), optional :: mode + 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) diff --git a/base/modules/psb_const_mod.f90 b/base/modules/psb_const_mod.f90 index 63cecdc7..de584e7e 100644 --- a/base/modules/psb_const_mod.f90 +++ b/base/modules/psb_const_mod.f90 @@ -30,106 +30,6 @@ !!$ module psb_const_mod - - ! - ! Communication, prolongation & restriction - ! - integer, parameter :: psb_nohalo_=0, psb_halo_=4 - integer, parameter :: psb_none_=0, psb_sum_=1 - integer, parameter :: psb_avg_=2, psb_square_root_=3 - integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 - integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 - - ! - ! Data checks - ! - integer, parameter :: psb_deadlock_check_=0 - integer, parameter :: psb_local_mtrx_check_=1 - integer, parameter :: psb_local_comm_check_=2 - integer, parameter :: psb_consistency_check_=3 - integer, parameter :: psb_global_check_=4 - integer, parameter :: psb_order_communication_=5 - integer, parameter :: psb_change_represent_=6 - integer, parameter :: psb_loc_to_glob_check_=7 - integer, parameter :: psb_convert_halo_=1, psb_convert_ovrlap_=2 - integer, parameter :: psb_act_ret_=0, psb_act_abort_=1, no_err_=0 - ! - ! Entries and values in desc%matrix_data - ! - integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 - integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 - integer, parameter :: psb_desc_size_=7 - integer, parameter :: psb_ovl_state_=8 - integer, parameter :: psb_mpi_c_=9 - integer, parameter :: psb_thal_xch_=11 - integer, parameter :: psb_thal_snd_=12 - integer, parameter :: psb_thal_rcv_=13 - integer, parameter :: psb_tovr_xch_=14 - integer, parameter :: psb_tovr_snd_=15 - integer, parameter :: psb_tovr_rcv_=16 - integer, parameter :: psb_mdata_size_=20 - integer, parameter :: psb_desc_asb_=3099 - integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 - integer, parameter :: psb_desc_repl_=3199 - integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 - integer, parameter :: psb_desc_normal_=3299 - integer, parameter :: psb_desc_large_=psb_desc_normal_+1 - integer, parameter :: psb_cd_ovl_bld_=3399 - integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1 - integer, parameter :: nbits=14 - integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1 - integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed - integer, parameter :: psb_hpnt_nentries_=7 - - ! - ! Constants for desc_a handling - ! - - integer, parameter :: psb_upd_glbnum_=998 - integer, parameter :: psb_upd_locnum_=997 - integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 - integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 - integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 - integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 - integer, parameter :: psb_n_dom_ovr_=1 - integer, parameter :: psb_no_comm_=-1 - integer, parameter :: psb_comm_halo_=0, psb_comm_ovr_=1 - - ! - ! Queries into spmat%info - ! - integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2 - integer, parameter :: psb_nzsizereq_=3 - ! - ! Entries and values for spmat%info - ! - - integer, parameter :: psb_nnz_=1 - integer, parameter :: psb_del_bnd_=7, psb_srtd_=8 - integer, parameter :: psb_state_=9 - integer, parameter :: psb_upd_pnt_=10 - integer, parameter :: psb_dupl_=11, psb_upd_=12 - integer, parameter :: psb_ifasize_=16 - integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 - integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 - integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 - integer, parameter :: psb_iflag_=2, psb_ichk_=3 - integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 - integer, parameter :: psb_dupl_ovwrt_ = 0 - integer, parameter :: psb_dupl_add_ = 1 - integer, parameter :: psb_dupl_err_ = 2 - integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_ - integer, parameter :: psb_upd_dflt_ = 0 - integer, parameter :: psb_upd_srch_ = 98764 - integer, parameter :: psb_upd_perm_ = 98765 - integer, parameter :: psb_isrtdcoo_ = 98761 - integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 - integer, parameter :: psb_dbleint_=2 - ! - ! Error handling - ! - integer, parameter :: act_ret=0, act_abort=1, no_err=0 - ! ! Handy & miscellaneous constants ! @@ -142,6 +42,5 @@ module psb_const_mod real(kind(1.d0)), parameter :: epstol=1.d-32 character, parameter :: psb_all_='A', psb_topdef_=' ' - character(len=5) :: psb_fidef_='CSR' end module psb_const_mod diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index b0e13796..d7e00616 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -38,14 +38,71 @@ module psb_descriptor_type use psb_const_mod + implicit none + ! + ! Communication, prolongation & restriction + ! + integer, parameter :: psb_nohalo_=0, psb_halo_=4 + integer, parameter :: psb_none_=0, psb_sum_=1 + integer, parameter :: psb_avg_=2, psb_square_root_=3 + integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 + integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 + + integer, parameter :: psb_no_comm_=-1 + integer, parameter :: psb_comm_halo_=0, psb_comm_ovr_=1, psb_comm_ext_=2 + integer, parameter :: psb_ovt_xhal_ = 123, psb_ovt_asov_=psb_ovt_xhal_+1 + + ! + ! Entries and values in desc%matrix_data + ! + integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 + integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 + integer, parameter :: psb_desc_size_=7 + integer, parameter :: psb_mpi_c_=9 + integer, parameter :: psb_thal_xch_=11 + integer, parameter :: psb_thal_snd_=12 + integer, parameter :: psb_thal_rcv_=13 + integer, parameter :: psb_tovr_xch_=14 + integer, parameter :: psb_tovr_snd_=15 + integer, parameter :: psb_tovr_rcv_=16 + integer, parameter :: psb_text_xch_=17 + integer, parameter :: psb_text_snd_=18 + integer, parameter :: psb_text_rcv_=19 + integer, parameter :: psb_mdata_size_=20 + integer, parameter :: psb_desc_asb_=3099 + integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 + integer, parameter :: psb_desc_repl_=3199 + integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 + integer, parameter :: psb_desc_normal_=3299 + integer, parameter :: psb_desc_large_=psb_desc_normal_+1 + integer, parameter :: psb_cd_ovl_bld_=3399 + integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1 + integer, parameter :: nbits=14 + integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1 + integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed + integer, parameter :: psb_hpnt_nentries_=7 + + ! + ! Constants for desc_a handling + ! + + integer, parameter :: psb_upd_glbnum_=998 + integer, parameter :: psb_upd_locnum_=997 + integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 + integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 + integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 + integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 + integer, parameter :: psb_n_dom_ovr_=1 + + ! desc_type contains data for communications. type psb_desc_type ! contain decomposition informations integer, allocatable :: matrix_data(:) ! contain index of halo elements to send/receive - integer, allocatable :: halo_index(:) + integer, allocatable :: halo_index(:), ext_index(:) ! contain indices of boundary elements integer, allocatable :: bnd_elem(:) ! contain index of overlap elements to send/receive @@ -265,7 +322,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/modules/psb_error_mod.f90 b/base/modules/psb_error_mod.f90 index 1db5522e..d893bd5b 100644 --- a/base/modules/psb_error_mod.f90 +++ b/base/modules/psb_error_mod.f90 @@ -30,7 +30,10 @@ !!$ module psb_error_mod - use psb_const_mod + integer, parameter, public :: psb_act_ret_=0, psb_act_abort_=1, psb_no_err_=0 + ! + ! Error handling + ! public psb_errpush, psb_error, psb_get_errstatus,& & psb_get_errverbosity, psb_set_errverbosity,psb_errcomm, & & psb_erractionsave, psb_erractionrestore, & @@ -41,7 +44,6 @@ module psb_error_mod module procedure psb_perror end interface -!!$ integer, parameter :: act_ret=0, act_abort=1, no_err=0 private diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 46ea9d48..a5962162 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -75,7 +75,8 @@ Contains use psb_error_mod ! ...Subroutine Arguments - Integer,allocatable :: vin(:),vout(:) + Integer,allocatable,intent(in) :: vin(:) + Integer,allocatable,intent(out) :: vout(:) integer :: info ! ...Local Variables @@ -107,7 +108,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -153,7 +154,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -198,7 +199,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -244,7 +245,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -289,7 +290,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -335,7 +336,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -464,7 +465,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -514,7 +515,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -564,7 +565,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -586,26 +587,31 @@ Contains integer, optional, intent(in) :: lb ! ...Local Variables Integer,allocatable :: tmp(:) - Integer :: dim, err_act, err,i,lb_ + Integer :: dim, err_act, err,i,lb_ character(len=20) :: name logical, parameter :: debug=.false. - name='psb_dreallocate1i' + name='psb_dreallocate1i' call psb_erractionsave(err_act) - if(psb_get_errstatus().ne.0) return - info=0 if (debug) write(0,*) 'reallocate I',len + if (psb_get_errstatus().ne.0) return + info=0 if (present(lb)) then lb_ = lb else lb_ = 1 endif + if ((len<0).or.(len>25*1024*1024)) then + err=2025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/)) + goto 9999 + end if if (allocated(rrax)) then dim=size(rrax) If (dim /= len) Then - Allocate(tmp(lb_:len),stat=info) + Allocate(tmp(len),stat=info) if (info /= 0) then err=4000 call psb_errpush(err,name) @@ -618,7 +624,7 @@ Contains end if else dim = 0 - allocate(rrax(lb_:len),stat=info) + allocate(rrax(len),stat=info) if (info /= 0) then err=4000 call psb_errpush(err,name) @@ -635,7 +641,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -672,6 +678,12 @@ Contains else lb_ = 1 endif + if ((len<0).or.(len>25*1024*1024)) then + err=2025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/)) + goto 9999 + end if + if (allocated(rrax)) then dim=size(rrax) @@ -707,7 +719,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -736,6 +748,12 @@ Contains call psb_erractionsave(err_act) info = 0 if (debug) write(0,*) 'reallocate Z',len + if ((len<0).or.(len>25*1024*1024)) then + err=2025 + call psb_errpush(err,name,i_err=(/len,0,0,0,0/)) + goto 9999 + end if + if (allocated(rrax)) then dim=size(rrax) @@ -771,7 +789,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -837,7 +855,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -902,7 +920,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -966,7 +984,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -1009,7 +1027,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -1060,7 +1078,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() @@ -1109,7 +1127,7 @@ Contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error() diff --git a/base/modules/psb_spmat_type.f90 b/base/modules/psb_spmat_type.f90 index d1927f26..f89bcdd5 100644 --- a/base/modules/psb_spmat_type.f90 +++ b/base/modules/psb_spmat_type.f90 @@ -32,13 +32,48 @@ !! Module to define D_SPMAT, structure !! !! for sparse matrix. !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - module psb_spmat_type use psb_error_mod use psb_realloc_mod use psb_const_mod + implicit none ! Typedef: psb_dspmat_type ! Contains a sparse matrix + + ! + ! Queries into spmat%info + ! + integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2 + integer, parameter :: psb_nzsizereq_=3 + ! + ! Entries and values for spmat%info + ! + + integer, parameter :: psb_nnz_=1 + integer, parameter :: psb_del_bnd_=7, psb_srtd_=8 + integer, parameter :: psb_state_=9 + integer, parameter :: psb_upd_pnt_=10 + integer, parameter :: psb_dupl_=11, psb_upd_=12 + integer, parameter :: psb_ifasize_=16 + integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 + integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 + integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 + integer, parameter :: psb_iflag_=2, psb_ichk_=3 + integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 + integer, parameter :: psb_dupl_ovwrt_ = 0 + integer, parameter :: psb_dupl_add_ = 1 + integer, parameter :: psb_dupl_err_ = 2 + integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_ + integer, parameter :: psb_upd_dflt_ = 0 + integer, parameter :: psb_upd_srch_ = 98764 + integer, parameter :: psb_upd_perm_ = 98765 + integer, parameter :: psb_isrtdcoo_ = 98761 + integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 + integer, parameter :: psb_dbleint_=2 + character(len=5) :: psb_fidef_='CSR' + + + type psb_dspmat_type ! Rows & columns integer :: m, k @@ -499,16 +534,25 @@ contains logical, parameter :: debug=.false. info = 0 - if (debug) write(0,*) 'Before realloc',nd,size(a%aspk) + 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 +!!$ call flush(0) if (info /= 0) return + if (debug) write(0,*) 'Before realloc2',ni2,allocated(a%ia2),size(a%ia2) +!!$ call flush(0) 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 flush(0) 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 flush(0) 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 flush(0) call psb_realloc(max(1,a%k),a%pr,info) if (info /= 0) return @@ -1398,7 +1442,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -1553,7 +1597,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index ce136fd2..a3c13fab 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -31,302 +31,303 @@ Module psb_tools_mod use psb_const_mod use psb_gps_mod - + interface psb_geall - ! 2-D double precision version - subroutine psb_dalloc(x, desc_a, info, n) - use psb_descriptor_type - implicit none - real(kind(1.d0)), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer,intent(out) :: info - integer, optional, intent(in) :: n - end subroutine psb_dalloc - ! 1-D double precision version - subroutine psb_dallocv(x, desc_a,info,n) - use psb_descriptor_type - real(kind(1.d0)), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - 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) - use psb_descriptor_type - integer, allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer, optional, intent(in) :: n - end subroutine psb_ialloc - subroutine psb_iallocv(x, desc_a,info,n) - use psb_descriptor_type - integer, allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer :: info - integer, optional, intent(in) :: n - end subroutine psb_iallocv - ! 2-D double precision version - subroutine psb_zalloc(x, desc_a, info, n) - use psb_descriptor_type - implicit none - complex(kind(1.d0)), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer :: info - integer, optional, intent(in) :: n - end subroutine psb_zalloc - ! 1-D double precision version - subroutine psb_zallocv(x, desc_a,info,n) - use psb_descriptor_type - complex(kind(1.d0)), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer :: info - integer, optional, intent(in) :: n - end subroutine psb_zallocv + ! 2-D double precision version + subroutine psb_dalloc(x, desc_a, info, n) + use psb_descriptor_type + implicit none + real(kind(1.d0)), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer,intent(out) :: info + integer, optional, intent(in) :: n + end subroutine psb_dalloc + ! 1-D double precision version + subroutine psb_dallocv(x, desc_a,info,n) + use psb_descriptor_type + real(kind(1.d0)), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + 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) + use psb_descriptor_type + integer, allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer, optional, intent(in) :: n + end subroutine psb_ialloc + subroutine psb_iallocv(x, desc_a,info,n) + use psb_descriptor_type + integer, allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + integer, optional, intent(in) :: n + end subroutine psb_iallocv + ! 2-D double precision version + subroutine psb_zalloc(x, desc_a, info, n) + use psb_descriptor_type + implicit none + complex(kind(1.d0)), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + integer, optional, intent(in) :: n + end subroutine psb_zalloc + ! 1-D double precision version + subroutine psb_zallocv(x, desc_a,info,n) + use psb_descriptor_type + complex(kind(1.d0)), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + integer, optional, intent(in) :: n + end subroutine psb_zallocv end interface interface psb_geasb - ! 2-D double precision version - subroutine psb_dasb(x, desc_a, info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - real(kind(1.d0)), 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(kind(1.d0)), 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_zasb(x, desc_a, info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - complex(kind(1.d0)), 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 - complex(kind(1.d0)), allocatable, intent(inout) :: x(:) - integer, intent(out) :: info - end subroutine psb_zasbv - end interface + ! 2-D double precision version + subroutine psb_dasb(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + real(kind(1.d0)), 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(kind(1.d0)), 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_zasb(x, desc_a, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + complex(kind(1.d0)), 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 + complex(kind(1.d0)), allocatable, intent(inout) :: x(:) + integer, intent(out) :: info + end subroutine psb_zasbv + end interface interface psb_sphalo - Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) - use psb_descriptor_type - use psb_spmat_type - Type(psb_dspmat_type),Intent(in) :: a - Type(psb_dspmat_type),Intent(inout) :: blk - Type(psb_desc_type),Intent(in) :: desc_a - integer, intent(out) :: info - logical, optional, intent(in) :: rwcnv,clcnv - character(len=5), optional :: outfmt - end Subroutine psb_dsphalo - Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) - use psb_descriptor_type - use psb_spmat_type - Type(psb_zspmat_type),Intent(in) :: a - Type(psb_zspmat_type),Intent(inout) :: blk - Type(psb_desc_type),Intent(in) :: desc_a - integer, intent(out) :: info - logical, optional, intent(in) :: rwcnv,clcnv - character(len=5), optional :: outfmt - end Subroutine psb_zsphalo + Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,cliprow,outfmt,data) + use psb_descriptor_type + use psb_spmat_type + Type(psb_dspmat_type),Intent(in) :: a + Type(psb_dspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in),target :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rwcnv,clcnv,cliprow + character(len=5), optional :: outfmt + integer, intent(in), optional :: data + end Subroutine psb_dsphalo + Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) + use psb_descriptor_type + use psb_spmat_type + Type(psb_zspmat_type),Intent(in) :: a + Type(psb_zspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in) :: desc_a + integer, intent(out) :: info + logical, optional, intent(in) :: rwcnv,clcnv + character(len=5), optional :: outfmt + end Subroutine psb_zsphalo end interface interface psb_csrp - subroutine psb_dcsrp(trans,iperm,a, desc_a, info) - use psb_descriptor_type - use psb_spmat_type - type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: iperm(:), info - character, intent(in) :: trans - end subroutine psb_dcsrp + subroutine psb_dcsrp(trans,iperm,a, desc_a, info) + use psb_descriptor_type + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: iperm(:), info + character, intent(in) :: trans + end subroutine psb_dcsrp end interface interface psb_cdprt - subroutine psb_cdprt(iout,desc_p,glob,short) - use psb_const_mod - use psb_descriptor_type - implicit none - type(psb_desc_type), intent(in) :: desc_p - integer, intent(in) :: iout - logical, intent(in), optional :: glob,short - end subroutine psb_cdprt + subroutine psb_cdprt(iout,desc_p,glob,short) + use psb_const_mod + use psb_descriptor_type + implicit none + type(psb_desc_type), intent(in) :: desc_p + integer, intent(in) :: iout + logical, intent(in), optional :: glob,short + end subroutine psb_cdprt end interface interface psb_gefree - ! 2-D double precision version - subroutine psb_dfree(x, desc_a, info) - use psb_descriptor_type - real(kind(1.d0)),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(kind(1.d0)),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_zfree(x, desc_a, info) - use psb_descriptor_type - complex(kind(1.d0)),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(kind(1.d0)),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer :: info - end subroutine psb_zfreev + ! 2-D double precision version + subroutine psb_dfree(x, desc_a, info) + use psb_descriptor_type + real(kind(1.d0)),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(kind(1.d0)),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_zfree(x, desc_a, info) + use psb_descriptor_type + complex(kind(1.d0)),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(kind(1.d0)),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer :: info + end subroutine psb_zfreev end interface interface psb_gelp - ! 2-D version - subroutine psb_dgelp(trans,iperm,x,desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - real(kind(1.d0)), intent(inout) :: x(:,:) - integer, intent(inout) :: iperm(:),info - character, intent(in) :: trans - end subroutine psb_dgelp - ! 1-D version - subroutine psb_dgelpv(trans,iperm,x,desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - real(kind(1.d0)), intent(inout) :: x(:) - integer, intent(inout) :: iperm(:), info - character, intent(in) :: trans - end subroutine psb_dgelpv - ! 2-D version - subroutine psb_zgelp(trans,iperm,x,desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - complex(kind(1.d0)), intent(inout) :: x(:,:) - integer, intent(inout) :: iperm(:),info - character, intent(in) :: trans - end subroutine psb_zgelp - ! 1-D version - subroutine psb_zgelpv(trans,iperm,x,desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - complex(kind(1.d0)), intent(inout) :: x(:) - integer, intent(inout) :: iperm(:), info - character, intent(in) :: trans - end subroutine psb_zgelpv + ! 2-D version + subroutine psb_dgelp(trans,iperm,x,desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + real(kind(1.d0)), intent(inout) :: x(:,:) + integer, intent(inout) :: iperm(:),info + character, intent(in) :: trans + end subroutine psb_dgelp + ! 1-D version + subroutine psb_dgelpv(trans,iperm,x,desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + real(kind(1.d0)), intent(inout) :: x(:) + integer, intent(inout) :: iperm(:), info + character, intent(in) :: trans + end subroutine psb_dgelpv + ! 2-D version + subroutine psb_zgelp(trans,iperm,x,desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + complex(kind(1.d0)), intent(inout) :: x(:,:) + integer, intent(inout) :: iperm(:),info + character, intent(in) :: trans + end subroutine psb_zgelp + ! 1-D version + subroutine psb_zgelpv(trans,iperm,x,desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + complex(kind(1.d0)), intent(inout) :: x(:) + integer, intent(inout) :: iperm(:), info + character, intent(in) :: trans + end subroutine psb_zgelpv end interface interface psb_geins - ! 2-D double precision version - subroutine psb_dinsi(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(kind(1.d0)),intent(inout) :: x(:,:) - integer, intent(in) :: irw(:) - real(kind(1.d0)), intent(in) :: val(:,:) - 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 - type(psb_desc_type), intent(in) :: desc_a - real(kind(1.d0)),intent(inout) :: x(:) - integer, intent(in) :: irw(:) - real(kind(1.d0)), intent(in) :: val(:) - 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 - type(psb_desc_type), intent(in) :: desc_a - integer,intent(inout) :: x(:,:) - integer, intent(in) :: irw(:) - integer, intent(in) :: val(:,:) - 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 - type(psb_desc_type), intent(in) :: desc_a - integer,intent(inout) :: x(:) - integer, intent(in) :: irw(:) - integer, intent(in) :: val(:) - integer, intent(out) :: info - integer, optional, intent(in) :: dupl - end subroutine psb_iinsvi - ! 2-D double precision version - subroutine psb_zinsi(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(kind(1.d0)),intent(inout) :: x(:,:) - integer, intent(in) :: irw(:) - complex(kind(1.d0)), intent(in) :: val(:,:) - 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 - type(psb_desc_type), intent(in) :: desc_a - complex(kind(1.d0)),intent(inout) :: x(:) - integer, intent(in) :: irw(:) - complex(kind(1.d0)), intent(in) :: val(:) - integer, intent(out) :: info - integer, optional, intent(in) :: dupl - end subroutine psb_zinsvi + ! 2-D double precision version + subroutine psb_dinsi(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(kind(1.d0)),intent(inout) :: x(:,:) + integer, intent(in) :: irw(:) + real(kind(1.d0)), intent(in) :: val(:,:) + 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 + type(psb_desc_type), intent(in) :: desc_a + real(kind(1.d0)),intent(inout) :: x(:) + integer, intent(in) :: irw(:) + real(kind(1.d0)), intent(in) :: val(:) + 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 + type(psb_desc_type), intent(in) :: desc_a + integer,intent(inout) :: x(:,:) + integer, intent(in) :: irw(:) + integer, intent(in) :: val(:,:) + 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 + type(psb_desc_type), intent(in) :: desc_a + integer,intent(inout) :: x(:) + integer, intent(in) :: irw(:) + integer, intent(in) :: val(:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_iinsvi + ! 2-D double precision version + subroutine psb_zinsi(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(kind(1.d0)),intent(inout) :: x(:,:) + integer, intent(in) :: irw(:) + complex(kind(1.d0)), intent(in) :: val(:,:) + 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 + type(psb_desc_type), intent(in) :: desc_a + complex(kind(1.d0)),intent(inout) :: x(:) + integer, intent(in) :: irw(:) + complex(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + integer, optional, intent(in) :: dupl + end subroutine psb_zinsvi end interface @@ -335,257 +336,255 @@ Module psb_tools_mod end interface interface psb_cdrep - subroutine psb_cdrep(m, ictxt, desc_a,info) - use psb_descriptor_type - Integer, intent(in) :: m,ictxt - Type(psb_desc_type), intent(out) :: desc_a - integer, intent(out) :: info - end subroutine psb_cdrep + subroutine psb_cdrep(m, ictxt, desc_a,info) + use psb_descriptor_type + Integer, intent(in) :: m,ictxt + Type(psb_desc_type), intent(out) :: desc_a + integer, intent(out) :: info + end subroutine psb_cdrep end interface interface psb_cdasb - subroutine psb_cdasb(desc_a,info) - use psb_descriptor_type - Type(psb_desc_type), intent(inout) :: desc_a - integer, intent(out) :: info - end subroutine psb_cdasb + module procedure psb_cdasb end interface - - interface psb_cdcpy - subroutine psb_cdcpy(desc_in, desc_out, info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out - integer, intent(out) :: info - end subroutine psb_cdcpy + subroutine psb_cdcpy(desc_in, desc_out, info) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_in + type(psb_desc_type), intent(out) :: desc_out + integer, intent(out) :: info + end subroutine psb_cdcpy end interface interface psb_cdtransfer - subroutine psb_cdtransfer(desc_in, desc_out, info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_in - type(psb_desc_type), intent(inout) :: desc_out - integer, intent(out) :: info - end subroutine psb_cdtransfer + subroutine psb_cdtransfer(desc_in, desc_out, info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc_in + type(psb_desc_type), intent(inout) :: desc_out + integer, intent(out) :: info + end subroutine psb_cdtransfer end interface - - + + interface psb_cdfree - subroutine psb_cdfree(desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(out) :: info - end subroutine psb_cdfree + subroutine psb_cdfree(desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + end subroutine psb_cdfree end interface - + interface psb_cdins - subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(in) :: nz,ia(:),ja(:) - integer, intent(out) :: info - integer, optional, intent(out) :: ila(:), jla(:) - end subroutine psb_cdins + subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(in) :: nz,ia(:),ja(:) + integer, intent(out) :: info + integer, optional, intent(out) :: ila(:), jla(:) + end subroutine psb_cdins end interface - interface psb_cdbldovr - Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) - use psb_descriptor_type - Use psb_spmat_type - integer, intent(in) :: novr - Type(psb_dspmat_type), Intent(in) :: a - Type(psb_desc_type), Intent(in) :: desc_a - Type(psb_desc_type), Intent(inout) :: desc_ov - integer, intent(out) :: info - end Subroutine psb_dcdovr - Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) - use psb_descriptor_type - Use psb_spmat_type - integer, intent(in) :: novr - Type(psb_zspmat_type), Intent(in) :: a - Type(psb_desc_type), Intent(in) :: desc_a - Type(psb_desc_type), Intent(inout) :: desc_ov - integer, intent(out) :: info - end Subroutine psb_zcdovr + interface psb_cdbldext + Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info,extype) + use psb_descriptor_type + Use psb_spmat_type + integer, intent(in) :: novr + Type(psb_dspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + end Subroutine psb_dcdovr + Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info,extype) + use psb_descriptor_type + Use psb_spmat_type + integer, intent(in) :: novr + Type(psb_zspmat_type), Intent(in) :: a + Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_ov + integer, intent(out) :: info + integer, intent(in),optional :: extype + end Subroutine psb_zcdovr end interface interface psb_cdren - subroutine psb_cdren(trans,iperm,desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(inout) :: iperm(:) - character, intent(in) :: trans - integer, intent(out) :: info - end subroutine psb_cdren + subroutine psb_cdren(trans,iperm,desc_a,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(inout) :: iperm(:) + character, intent(in) :: trans + integer, intent(out) :: info + end subroutine psb_cdren end interface - + interface psb_spall - subroutine psb_dspalloc(a, desc_a, info, nnz) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(inout) :: desc_a - type(psb_dspmat_type), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: nnz - end subroutine psb_dspalloc - subroutine psb_zspalloc(a, desc_a, info, nnz) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(inout) :: desc_a - type(psb_zspmat_type), intent(out) :: a - integer, intent(out) :: info - integer, optional, intent(in) :: nnz - end subroutine psb_zspalloc + subroutine psb_dspalloc(a, desc_a, info, nnz) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_dspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + end subroutine psb_dspalloc + subroutine psb_zspalloc(a, desc_a, info, nnz) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(inout) :: desc_a + type(psb_zspmat_type), intent(out) :: a + integer, intent(out) :: info + integer, optional, intent(in) :: nnz + end subroutine psb_zspalloc end interface interface psb_spasb - subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) - use psb_descriptor_type - use psb_spmat_type - type(psb_dspmat_type), intent (inout) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 - end subroutine psb_dspasb - subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) - use psb_descriptor_type - use psb_spmat_type - type(psb_zspmat_type), intent (inout) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 - end subroutine psb_zspasb + subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) + use psb_descriptor_type + use psb_spmat_type + type(psb_dspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character, optional, intent(in) :: afmt*5 + end subroutine psb_dspasb + subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) + use psb_descriptor_type + use psb_spmat_type + type(psb_zspmat_type), intent (inout) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character, optional, intent(in) :: afmt*5 + end subroutine psb_zspasb end interface interface psb_spcnv - subroutine psb_dspcnv(a,b,desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - end subroutine psb_dspcnv - subroutine psb_zspcnv(a,b,desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zspcnv + subroutine psb_dspcnv(a,b,desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(out) :: b + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_dspcnv + subroutine psb_zspcnv(a,b,desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(out) :: b + type(psb_desc_type), intent(in) :: desc_a + integer, intent(out) :: info + end subroutine psb_zspcnv end interface interface psb_spfree - subroutine psb_dspfree(a, desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(in) :: desc_a - type(psb_dspmat_type), intent(inout) ::a - integer, intent(out) :: info - end subroutine psb_dspfree - subroutine psb_zspfree(a, desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(in) :: desc_a - type(psb_zspmat_type), intent(inout) ::a - integer, intent(out) :: info - end subroutine psb_zspfree + subroutine psb_dspfree(a, desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(inout) ::a + integer, intent(out) :: info + end subroutine psb_dspfree + subroutine psb_zspfree(a, desc_a,info) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_zspmat_type), intent(inout) ::a + integer, intent(out) :: info + end subroutine psb_zspfree end interface interface psb_spins - subroutine psb_dspins(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_dspmat_type), intent(inout) :: a - integer, intent(in) :: nz,ia(:),ja(:) - real(kind(1.d0)), intent(in) :: val(:) - integer, intent(out) :: info - logical, intent(in), optional :: rebuild - end subroutine psb_dspins - subroutine psb_zspins(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_zspmat_type), intent(inout) :: a - integer, intent(in) :: nz,ia(:),ja(:) - complex(kind(1.d0)), intent(in) :: val(:) - integer, intent(out) :: info - logical, intent(in), optional :: rebuild - end subroutine psb_zspins + subroutine psb_dspins(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_dspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + real(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + end subroutine psb_dspins + subroutine psb_zspins(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_zspmat_type), intent(inout) :: a + integer, intent(in) :: nz,ia(:),ja(:) + complex(kind(1.d0)), intent(in) :: val(:) + integer, intent(out) :: info + logical, intent(in), optional :: rebuild + end subroutine psb_zspins end interface interface psb_sprn - subroutine psb_dsprn(a, desc_a,info,clear) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(in) :: desc_a - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, intent(in), optional :: clear - end subroutine psb_dsprn - subroutine psb_zsprn(a, desc_a,info,clear) - use psb_descriptor_type - use psb_spmat_type - type(psb_desc_type), intent(in) :: desc_a - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - logical, intent(in), optional :: clear - end subroutine psb_zsprn + subroutine psb_dsprn(a, desc_a,info,clear) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + end subroutine psb_dsprn + subroutine psb_zsprn(a, desc_a,info,clear) + use psb_descriptor_type + use psb_spmat_type + type(psb_desc_type), intent(in) :: desc_a + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + logical, intent(in), optional :: clear + end subroutine psb_zsprn end interface interface psb_glob_to_loc - subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(in) :: x(:) - integer,intent(out) :: y(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_glob_to_loc2 - subroutine psb_glob_to_loc(x,desc_a,info,iact) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(inout) :: x(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_glob_to_loc + subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + integer,intent(in) :: x(:) + integer,intent(out) :: y(:) + integer, intent(out) :: info + logical, intent(in), optional :: owned + character, intent(in), optional :: iact + end subroutine psb_glob_to_loc2 + subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + integer,intent(inout) :: x(:) + integer, intent(out) :: info + logical, intent(in), optional :: owned + character, intent(in), optional :: iact + end subroutine psb_glob_to_loc end interface interface psb_loc_to_glob - subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(in) :: x(:) - integer,intent(out) :: y(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob2 - subroutine psb_loc_to_glob(x,desc_a,info,iact) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_a - integer,intent(inout) :: x(:) - integer, intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob + subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + integer,intent(in) :: x(:) + integer,intent(out) :: y(:) + integer, intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob2 + subroutine psb_loc_to_glob(x,desc_a,info,iact) + use psb_descriptor_type + type(psb_desc_type), intent(in) :: desc_a + integer,intent(inout) :: x(:) + integer, intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob end interface interface psb_get_boundary module procedure psb_get_boundary end interface - + interface psb_get_overlap subroutine psb_get_ovrlap(ovrel,desc,info) use psb_descriptor_type @@ -595,7 +594,7 @@ Module psb_tools_mod integer, intent(out) :: info end subroutine psb_get_ovrlap end interface - + contains @@ -607,11 +606,11 @@ contains integer, allocatable :: bndel(:) type(psb_desc_type), intent(in) :: desc integer, intent(out) :: info - + call psi_crea_bnd_elem(bndel,desc,info) end subroutine psb_get_boundary - + subroutine psb_cdall(ictxt, desc_a, info,mg,ng,parts,vg,vl,flag,nl) use psb_descriptor_type use psb_serial_mod @@ -660,7 +659,7 @@ contains info=0 name = 'psb_cdall' call psb_erractionsave(err_act) - + call psb_info(ictxt, me, np) if (count((/ present(vg),present(vl),present(parts),present(nl) /)) /= 1) then @@ -668,7 +667,7 @@ contains call psb_errpush(info,name,a_err=" vg, vl, parts, nl") goto 999 endif - + if (present(parts)) then if (.not.present(mg)) then info=581 @@ -692,7 +691,7 @@ contains else if (present(vl)) then call psb_cd_inloc(vl,ictxt,desc_a,info) - + else if (present(nl)) then allocate(itmpsz(0:np-1),stat=info) if (info /= 0) then @@ -709,24 +708,39 @@ contains nlp = nlp + itmpsz(i) end do call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc_a,info) - + endif call psb_erractionrestore(err_act) return - + 999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if return - + end subroutine psb_cdall + subroutine psb_cdasb(desc_a,info) + use psb_descriptor_type + interface psb_icdasb + 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 + + Type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + call psb_icdasb(desc_a,info,ext_hv=.false.) + end subroutine psb_cdasb end module psb_tools_mod diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index fd500f0a..98fb5442 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -278,9 +278,10 @@ module psi_mod end interface interface psi_ldsc_pre_halo - subroutine psi_ldsc_pre_halo(desc,info) + subroutine psi_ldsc_pre_halo(desc,ext_hv,info) use psb_descriptor_type type(psb_desc_type), intent(inout) :: desc + logical, intent(in) :: ext_hv integer, intent(out) :: info end subroutine psi_ldsc_pre_halo end interface @@ -344,7 +345,7 @@ module psi_mod contains - subroutine psi_cnv_dsc(halo_in,ovrlap_in,cdesc, info) + subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) use psb_const_mod use psb_error_mod @@ -354,7 +355,7 @@ contains implicit none ! ....scalars parameters.... - integer, intent(in) :: halo_in(:), ovrlap_in(:) + integer, intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) type(psb_desc_type), intent(inout) :: cdesc integer, intent(out) :: info @@ -396,6 +397,22 @@ contains cdesc%matrix_data(psb_thal_rcv_) = nrcv if (debug) write(0,*) me,'Done crea_index on halo' + if (debug) write(0,*) me,'Calling crea_index on ext' + + + ! then ext index + if (debug) write(0,*) me,'Calling crea_index on ext' + call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + call psb_transfer(idx_out,cdesc%ext_index,info) + cdesc%matrix_data(psb_text_xch_) = nxch + cdesc%matrix_data(psb_text_snd_) = nsnd + cdesc%matrix_data(psb_text_rcv_) = nrcv + + if (debug) write(0,*) me,'Done crea_index on ext' if (debug) write(0,*) me,'Calling crea_index on ovrlap' ! then the overlap index @@ -439,7 +456,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 19d1fcf9..9ac90cae 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -119,7 +119,7 @@ function psb_damax (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -240,7 +240,7 @@ function psb_damaxv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -363,7 +363,7 @@ subroutine psb_damaxvs (res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -490,7 +490,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 6268fb69..0a23c1bb 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -139,7 +139,7 @@ function psb_dasum (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -276,7 +276,7 @@ function psb_dasumv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -415,7 +415,7 @@ subroutine psb_dasumvs (res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 84a39c5b..c1aa149c 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -148,7 +148,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -275,7 +275,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index a2f33c3b..a75c565f 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -151,7 +151,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -289,7 +289,7 @@ function psb_ddotv(x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -425,7 +425,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -577,7 +577,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -676,7 +676,7 @@ subroutine psb_ddot2v(res, x, y,w,z,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 1aa21037..1d6985aa 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -132,7 +132,7 @@ function psb_dnrm2(x, desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -265,7 +265,7 @@ function psb_dnrm2v(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -399,7 +399,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 66754f98..4fc3776f 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -120,7 +120,7 @@ function psb_dnrmi(a,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 8b35fb15..1a20de94 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -352,7 +352,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -667,7 +667,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index c2a0866e..aae113c0 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -309,7 +309,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -602,7 +602,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index bbd7c57f..cd76a8d7 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -122,7 +122,7 @@ function psb_zamax (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -248,7 +248,7 @@ function psb_zamaxv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -375,7 +375,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -507,7 +507,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 3cf4c60d..4f9dd1bf 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -144,7 +144,7 @@ function psb_zasum (x,desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -287,7 +287,7 @@ function psb_zasumv (x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -431,7 +431,7 @@ subroutine psb_zasumvs (res,x,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index d33d5e8d..3f3b6686 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -146,7 +146,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -273,7 +273,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index f58dd131..b9594eac 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -150,7 +150,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -288,7 +288,7 @@ function psb_zdotv(x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -423,7 +423,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -576,7 +576,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 504ed4dc..766c957b 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -131,7 +131,7 @@ function psb_znrm2(x, desc_a, info, jx) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -264,7 +264,7 @@ function psb_znrm2v(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -396,7 +396,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 8477a415..84a67131 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -120,7 +120,7 @@ function psb_znrmi(a,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index 85916bf2..ac7c6414 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -346,7 +346,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -644,7 +644,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index e242c42d..6b0bd811 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -312,7 +312,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -600,7 +600,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/serial/dp/dcoco.f b/base/serial/dp/dcoco.f index 506d76da..05b9802e 100644 --- a/base/serial/dp/dcoco.f +++ b/base/serial/dp/dcoco.f @@ -35,6 +35,7 @@ c * lia2n,aux,laux,ierror) use psb_const_mod + use psb_spmat_type implicit none c .. scalar arguments .. diff --git a/base/serial/dp/dcocr.f b/base/serial/dp/dcocr.f index 912befea..01e5d044 100644 --- a/base/serial/dp/dcocr.f +++ b/base/serial/dp/dcocr.f @@ -36,6 +36,7 @@ C * LIAN2,AUX,LAUX,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/dcrco.f b/base/serial/dp/dcrco.f index dcc5019d..a5566e68 100644 --- a/base/serial/dp/dcrco.f +++ b/base/serial/dp/dcrco.f @@ -33,6 +33,7 @@ C * LIAN2,AUX,LAUX,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/dcrjd.f b/base/serial/dp/dcrjd.f index 0b11e31e..aedeadfa 100644 --- a/base/serial/dp/dcrjd.f +++ b/base/serial/dp/dcrjd.f @@ -60,6 +60,7 @@ C ARN,IAN1 C IAN2,INFON, IP1, IP2 C use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/dcsrp1.f b/base/serial/dp/dcsrp1.f index 99b49d4a..3bb9f58a 100644 --- a/base/serial/dp/dcsrp1.f +++ b/base/serial/dp/dcsrp1.f @@ -117,6 +117,7 @@ C SUBROUTINE DCSRP1(TRANS,M,N,DESCRA,JA,IA, + P,WORK,IWORK,LWORK,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK,M, N, IERROR diff --git a/base/serial/dp/dgindex.f b/base/serial/dp/dgindex.f index d1212dbb..0d1f1b48 100644 --- a/base/serial/dp/dgindex.f +++ b/base/serial/dp/dgindex.f @@ -32,6 +32,7 @@ C + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C ... Scalar arguments ... diff --git a/base/serial/dp/gen_block.f b/base/serial/dp/gen_block.f index 7fa5f79b..199a45d2 100644 --- a/base/serial/dp/gen_block.f +++ b/base/serial/dp/gen_block.f @@ -30,6 +30,7 @@ C C SUBROUTINE GEN_BLOCK(M,NG,IA,AUX) use psb_const_mod + use psb_spmat_type IMPLICIT NONE INTEGER M, NG diff --git a/base/serial/dp/partition.f b/base/serial/dp/partition.f index 85e6ff61..b05e246e 100644 --- a/base/serial/dp/partition.f +++ b/base/serial/dp/partition.f @@ -30,6 +30,7 @@ C C SUBROUTINE PARTITION(M, WORK, IA, N_BLOCK) use psb_const_mod + use psb_spmat_type IMPLICIT NONE diff --git a/base/serial/dp/zcoco.f b/base/serial/dp/zcoco.f index a47bc7b2..f79cced9 100644 --- a/base/serial/dp/zcoco.f +++ b/base/serial/dp/zcoco.f @@ -35,6 +35,7 @@ c * lia2n,aux,laux,ierror) use psb_const_mod + use psb_spmat_type implicit none c .. scalar arguments .. diff --git a/base/serial/dp/zcocr.f b/base/serial/dp/zcocr.f index a5d4aa76..6475315e 100644 --- a/base/serial/dp/zcocr.f +++ b/base/serial/dp/zcocr.f @@ -36,6 +36,7 @@ C * LIAN2,AUX,LAUX,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/zcrco.f b/base/serial/dp/zcrco.f index 0ac2317c..b1d49a3d 100644 --- a/base/serial/dp/zcrco.f +++ b/base/serial/dp/zcrco.f @@ -33,6 +33,7 @@ C * LIAN2,AUX,LAUX,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/zcrjd.f b/base/serial/dp/zcrjd.f index 360fde79..735eb7f7 100644 --- a/base/serial/dp/zcrjd.f +++ b/base/serial/dp/zcrjd.f @@ -60,6 +60,7 @@ C ARN,IAN1 C IAN2,INFON, IP1, IP2 C use psb_const_mod + use psb_spmat_type IMPLICIT NONE C diff --git a/base/serial/dp/zgindex.f b/base/serial/dp/zgindex.f index 256faa52..9f49d5e8 100644 --- a/base/serial/dp/zgindex.f +++ b/base/serial/dp/zgindex.f @@ -32,6 +32,7 @@ C + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C ... Scalar arguments ... diff --git a/base/serial/jad/djadnr.f b/base/serial/jad/djadnr.f index 1c1927e0..410e695b 100644 --- a/base/serial/jad/djadnr.f +++ b/base/serial/jad/djadnr.f @@ -32,6 +32,7 @@ C ... Compute infinity norma for sparse matrix in CSR Format ... DOUBLE PRECISION FUNCTION DJADNR(TRANS,M,N,NG,A,KA,JA,IA, + INFOA,IERROR) use psb_const_mod + use psb_spmat_type IMPLICIT NONE C .. Scalar Arguments .. INTEGER M,N, IERROR, NG diff --git a/base/serial/psb_cest.f90 b/base/serial/psb_cest.f90 index ed01deae..efce9e15 100644 --- a/base/serial/psb_cest.f90 +++ b/base/serial/psb_cest.f90 @@ -33,6 +33,7 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) use psb_error_mod use psb_const_mod use psb_string_mod + use psb_spmat_type implicit none ! .. scalar arguments .. diff --git a/base/serial/psb_dcoins.f90 b/base/serial/psb_dcoins.f90 index 8c176489..38f4df3c 100644 --- a/base/serial/psb_dcoins.f90 +++ b/base/serial/psb_dcoins.f90 @@ -436,7 +436,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsdp.f90 b/base/serial/psb_dcsdp.f90 index 89d1cf76..9e5c0fcd 100644 --- a/base/serial/psb_dcsdp.f90 +++ b/base/serial/psb_dcsdp.f90 @@ -179,7 +179,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) call psb_cest(b%fida, n_row,n_col,size_req,& & ia1_size, ia2_size, aspk_size, upd_,info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_cest' call psb_errpush(info,name,a_err=ch_err) @@ -199,7 +199,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) endif - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) @@ -516,7 +516,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsmm.f90 b/base/serial/psb_dcsmm.f90 index 5e255f69..f0d3be70 100644 --- a/base/serial/psb_dcsmm.f90 +++ b/base/serial/psb_dcsmm.f90 @@ -104,7 +104,7 @@ subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsmv.f90 b/base/serial/psb_dcsmv.f90 index 41535111..fecdeca2 100644 --- a/base/serial/psb_dcsmv.f90 +++ b/base/serial/psb_dcsmv.f90 @@ -77,7 +77,7 @@ subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsnmi.f90 b/base/serial/psb_dcsnmi.f90 index 74829242..d27fddfa 100644 --- a/base/serial/psb_dcsnmi.f90 +++ b/base/serial/psb_dcsnmi.f90 @@ -81,7 +81,7 @@ real(kind(1.d0)) function psb_dcsnmi(a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcsrws.f90 b/base/serial/psb_dcsrws.f90 index 47de8858..6b2ea0a0 100644 --- a/base/serial/psb_dcsrws.f90 +++ b/base/serial/psb_dcsrws.f90 @@ -94,7 +94,7 @@ subroutine psb_dcsrws(rw,a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcssm.f90 b/base/serial/psb_dcssm.f90 index a016e804..2022b46a 100644 --- a/base/serial/psb_dcssm.f90 +++ b/base/serial/psb_dcssm.f90 @@ -88,7 +88,7 @@ subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dcssv.f90 b/base/serial/psb_dcssv.f90 index 66a9c1f3..5a3fb1d2 100644 --- a/base/serial/psb_dcssv.f90 +++ b/base/serial/psb_dcssv.f90 @@ -88,7 +88,7 @@ subroutine psb_dcssv(alpha,t,b,beta,c,info,trans,unitd,d) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcoo2csc.f90 b/base/serial/psb_dipcoo2csc.f90 index 6c7f12f1..674471ad 100644 --- a/base/serial/psb_dipcoo2csc.f90 +++ b/base/serial/psb_dipcoo2csc.f90 @@ -186,7 +186,7 @@ subroutine psb_dipcoo2csc(a,info,clshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcoo2csr.f90 b/base/serial/psb_dipcoo2csr.f90 index 2cf38e22..2bd533c6 100644 --- a/base/serial/psb_dipcoo2csr.f90 +++ b/base/serial/psb_dipcoo2csr.f90 @@ -189,7 +189,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dipcsr2coo.f90 b/base/serial/psb_dipcsr2coo.f90 index 356b3529..0bb8b6dd 100644 --- a/base/serial/psb_dipcsr2coo.f90 +++ b/base/serial/psb_dipcsr2coo.f90 @@ -91,7 +91,7 @@ Subroutine psb_dipcsr2coo(a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dneigh.f90 b/base/serial/psb_dneigh.f90 index d5b633cb..ebd23c53 100644 --- a/base/serial/psb_dneigh.f90 +++ b/base/serial/psb_dneigh.f90 @@ -91,7 +91,7 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index a39793f6..ce420245 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -105,7 +105,7 @@ subroutine psb_drwextd(nr,a,info,b) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 index ad692bec..31edd440 100644 --- a/base/serial/psb_dspgetrow.f90 +++ b/base/serial/psb_dspgetrow.f90 @@ -151,7 +151,7 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspgtblk.f90 b/base/serial/psb_dspgtblk.f90 index 6f5c46b7..933b441c 100644 --- a/base/serial/psb_dspgtblk.f90 +++ b/base/serial/psb_dspgtblk.f90 @@ -116,7 +116,7 @@ subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspgtdiag.f90 b/base/serial/psb_dspgtdiag.f90 index 3e0e354d..e9065280 100644 --- a/base/serial/psb_dspgtdiag.f90 +++ b/base/serial/psb_dspgtdiag.f90 @@ -127,7 +127,7 @@ subroutine psb_dspgtdiag(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dspscal.f90 b/base/serial/psb_dspscal.f90 index 5dce156b..96b02083 100644 --- a/base/serial/psb_dspscal.f90 +++ b/base/serial/psb_dspscal.f90 @@ -88,7 +88,7 @@ subroutine psb_dspscal(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 81e93c06..0f88545e 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -125,7 +125,7 @@ subroutine psb_dsymbmm(a,b,c,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcoins.f90 b/base/serial/psb_zcoins.f90 index ae756aaa..035b953f 100644 --- a/base/serial/psb_zcoins.f90 +++ b/base/serial/psb_zcoins.f90 @@ -436,7 +436,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsdp.f90 b/base/serial/psb_zcsdp.f90 index b558945b..4a196cb7 100644 --- a/base/serial/psb_zcsdp.f90 +++ b/base/serial/psb_zcsdp.f90 @@ -179,7 +179,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) call psb_cest(b%fida, n_row,n_col,size_req,& & ia1_size, ia2_size, aspk_size, upd_,info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_cest' call psb_errpush(info,name,a_err=ch_err) @@ -199,7 +199,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) endif - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) @@ -516,7 +516,7 @@ subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsmm.f90 b/base/serial/psb_zcsmm.f90 index 6f1265c8..d5dc1439 100644 --- a/base/serial/psb_zcsmm.f90 +++ b/base/serial/psb_zcsmm.f90 @@ -77,7 +77,7 @@ subroutine psb_zcsmm(alpha,a,b,beta,c,info,trans) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsmv.f90 b/base/serial/psb_zcsmv.f90 index a593bcd9..9587a436 100644 --- a/base/serial/psb_zcsmv.f90 +++ b/base/serial/psb_zcsmv.f90 @@ -77,7 +77,7 @@ subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsnmi.f90 b/base/serial/psb_zcsnmi.f90 index 514626b8..93426fba 100644 --- a/base/serial/psb_zcsnmi.f90 +++ b/base/serial/psb_zcsnmi.f90 @@ -81,7 +81,7 @@ real(kind(1.d0)) function psb_zcsnmi(a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcsrws.f90 b/base/serial/psb_zcsrws.f90 index 028521ae..ee480fbc 100644 --- a/base/serial/psb_zcsrws.f90 +++ b/base/serial/psb_zcsrws.f90 @@ -94,7 +94,7 @@ subroutine psb_zcsrws(rw,a,info,trans) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcssm.f90 b/base/serial/psb_zcssm.f90 index fa894ee4..9d64f213 100644 --- a/base/serial/psb_zcssm.f90 +++ b/base/serial/psb_zcssm.f90 @@ -88,7 +88,7 @@ subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zcssv.f90 b/base/serial/psb_zcssv.f90 index 56380c03..f21315f2 100644 --- a/base/serial/psb_zcssv.f90 +++ b/base/serial/psb_zcssv.f90 @@ -88,7 +88,7 @@ subroutine psb_zcssv(alpha,t,b,beta,c,info,trans,unitd,d) call psb_erractionrestore(err_act) if(info.ne.0) then - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zipcoo2csc.f90 b/base/serial/psb_zipcoo2csc.f90 index f0646fee..bdac4847 100644 --- a/base/serial/psb_zipcoo2csc.f90 +++ b/base/serial/psb_zipcoo2csc.f90 @@ -187,7 +187,7 @@ subroutine psb_zipcoo2csc(a,info,clshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zipcoo2csr.f90 b/base/serial/psb_zipcoo2csr.f90 index c8266d26..f325911f 100644 --- a/base/serial/psb_zipcoo2csr.f90 +++ b/base/serial/psb_zipcoo2csr.f90 @@ -189,7 +189,7 @@ subroutine psb_zipcoo2csr(a,info,rwshr) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zipcsr2coo.f90 b/base/serial/psb_zipcsr2coo.f90 index ca4c5aa2..a0fe0e3d 100644 --- a/base/serial/psb_zipcsr2coo.f90 +++ b/base/serial/psb_zipcsr2coo.f90 @@ -91,7 +91,7 @@ Subroutine psb_zipcsr2coo(a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zneigh.f90 b/base/serial/psb_zneigh.f90 index 2afedfef..7a22723c 100644 --- a/base/serial/psb_zneigh.f90 +++ b/base/serial/psb_zneigh.f90 @@ -91,7 +91,7 @@ subroutine psb_zneigh(a,idx,neigh,n,info,lev) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zrwextd.f90 b/base/serial/psb_zrwextd.f90 index daf8f144..e0c61c56 100644 --- a/base/serial/psb_zrwextd.f90 +++ b/base/serial/psb_zrwextd.f90 @@ -105,7 +105,7 @@ subroutine psb_zrwextd(nr,a,info,b) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspgetrow.f90 b/base/serial/psb_zspgetrow.f90 index 18e1e2b8..073b56ed 100644 --- a/base/serial/psb_zspgetrow.f90 +++ b/base/serial/psb_zspgetrow.f90 @@ -151,7 +151,7 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspgtblk.f90 b/base/serial/psb_zspgtblk.f90 index 14b8b9b0..02f2cd0a 100644 --- a/base/serial/psb_zspgtblk.f90 +++ b/base/serial/psb_zspgtblk.f90 @@ -116,7 +116,7 @@ subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspgtdiag.f90 b/base/serial/psb_zspgtdiag.f90 index faead301..27225733 100644 --- a/base/serial/psb_zspgtdiag.f90 +++ b/base/serial/psb_zspgtdiag.f90 @@ -127,7 +127,7 @@ subroutine psb_zspgtdiag(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zspscal.f90 b/base/serial/psb_zspscal.f90 index d197f73a..f8fdd3e1 100644 --- a/base/serial/psb_zspscal.f90 +++ b/base/serial/psb_zspscal.f90 @@ -88,7 +88,7 @@ subroutine psb_zspscal(a,d,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 8c0fe2f9..cea786ae 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -125,7 +125,7 @@ subroutine psb_zsymbmm(a,b,c,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/tools/Makefile b/base/tools/Makefile index ae4cde47..3ebe6ada 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -13,7 +13,7 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \ psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\ psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o -MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_cdasb.o psb_dcdovr.o psb_zcdovr.o +MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_icdasb.o psb_dcdovr.o psb_zcdovr.o LIBDIR = .. MODDIR = ../modules diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index ffc13766..af0795c2 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -361,13 +361,19 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) call psb_cd_set_bld(desc_a,info) call psb_realloc(1,desc_a%halo_index, info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=2025 call psb_errpush(err,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 + call psb_realloc(1,desc_a%ext_index, info) + if (info /= psb_no_err_) then + info=2025 + call psb_errpush(err,name,a_err='psb_realloc') + Goto 9999 + end if + desc_a%ext_index(:) = -1 desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_n_) = n @@ -380,7 +386,7 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index dc6a3e81..2914361e 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -345,7 +345,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) if (debug) write(*,*) 'PSB_CDALL: Ov len',l_ov_ix,l_ov_el allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 err=info call psb_errpush(err,name,a_err='psb_realloc') @@ -380,14 +380,12 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) call psb_transfer(ov_idx,desc_a%ovrlap_index,info) if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 err=info call psb_errpush(err,name) Goto 9999 endif - ! At this point overlap_elem is OK. - desc_a%matrix_data(psb_ovl_state_) = psb_cd_ovl_asb_ ! set fields in desc_a%MATRIX_DATA.... desc_a%matrix_data(psb_n_row_) = loc_row @@ -395,14 +393,21 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) call psb_cd_set_bld(desc_a,info) call psb_realloc(1,desc_a%halo_index, info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=2025 call psb_errpush(err,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 + call psb_realloc(1,desc_a%ext_index, info) + if (info /= psb_no_err_) then + info=2025 + call psb_errpush(err,name,a_err='psb_realloc') + Goto 9999 + end if + desc_a%ext_index(:) = -1 + desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_ctxt_) = ictxt @@ -413,7 +418,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index 0e9f3d5a..a56575fb 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -337,14 +337,21 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) call psb_cd_set_bld(desc_a,info) call psb_realloc(1,desc_a%halo_index, info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=2025 call psb_errpush(err,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 + call psb_realloc(1,desc_a%ext_index, info) + if (info /= psb_no_err_) then + info=2025 + call psb_errpush(err,name,a_err='psb_realloc') + Goto 9999 + end if + desc_a%ext_index(:) = -1 + desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_ctxt_) = ictxt @@ -356,7 +363,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.f90 index ae27c94d..ad0b57ae 100644 --- a/base/tools/psb_cdcpy.f90 +++ b/base/tools/psb_cdcpy.f90 @@ -79,6 +79,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) call psb_safe_cpy(desc_in%matrix_data,desc_out%matrix_data,info) if (info == 0) call psb_safe_cpy(desc_in%halo_index,desc_out%halo_index,info) + if (info == 0) call psb_safe_cpy(desc_in%ext_index,desc_out%ext_index,info) if (info == 0) call psb_safe_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) if (info == 0) call psb_safe_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) if (info == 0) call psb_safe_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) @@ -123,7 +124,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_cdfree.f90 b/base/tools/psb_cdfree.f90 index dbb13bbd..7ed4fb00 100644 --- a/base/tools/psb_cdfree.f90 +++ b/base/tools/psb_cdfree.f90 @@ -211,7 +211,7 @@ subroutine psb_cdfree(desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index 398087e9..78730044 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -140,7 +140,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index 8422f2cb..0c58a33b 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -89,6 +89,24 @@ subroutine psb_cdprt(iout,desc_p,glob,short) counter = counter+n_elem_recv+n_elem_send+3 enddo + write(iout,*) 'Ext_index' + counter = 1 + Do + proc=desc_p%ext_index(counter+psb_proc_id_) + if (proc == -1) exit + n_elem_recv=desc_p%ext_index(counter+psb_n_elem_recv_) + n_elem_send=desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_) + write(iout,*) 'Ext_index Receive',proc,n_elem_recv + if (.not.lshort) write(iout,*) & + & desc_p%ext_index(counter+psb_n_elem_recv_+1:counter+psb_n_elem_recv_+n_elem_recv) + write(iout,*) 'Ext_index Send',proc,n_elem_send + if (.not.lshort) write(iout,*) & + & desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_+1: & + & counter+n_elem_recv+psb_n_elem_send_+n_elem_send) + + counter = counter+n_elem_recv+n_elem_send+3 + enddo + write(iout,*) 'Ovrlap_index' counter = 1 @@ -135,10 +153,10 @@ subroutine psb_cdprt(iout,desc_p,glob,short) write(iout,*) i, desc_p%loc_to_glob(i) enddo - write(iout,*) 'glob_to_loc ' - do i=1,m - write(iout,*) i,desc_p%glob_to_loc(i) - enddo +!!$ write(iout,*) 'glob_to_loc ' +!!$ do i=1,m +!!$ write(iout,*) i,desc_p%glob_to_loc(i) +!!$ enddo endif write(iout,*) 'Halo_index' counter = 1 @@ -165,6 +183,31 @@ subroutine psb_cdprt(iout,desc_p,glob,short) counter = counter+n_elem_recv+n_elem_send+3 enddo + write(iout,*) 'Ext_index' + counter = 1 + Do + proc=desc_p%ext_index(counter+psb_proc_id_) + if (proc == -1) exit + n_elem_recv=desc_p%ext_index(counter+psb_n_elem_recv_) + n_elem_send=desc_p%ext_index(counter+n_elem_recv+psb_n_elem_send_) + write(iout,*) 'Ext_index Receive',proc,n_elem_recv + if (.not.lshort) then + do i=counter+psb_n_elem_recv_+1,counter+psb_n_elem_recv_+n_elem_recv + write(iout,*) & + & desc_p%loc_to_glob(desc_p%ext_index(i)),desc_p%ext_index(i) + enddo + endif + write(iout,*) 'Ext_index Send',proc,n_elem_send + if (.not.lshort) then + do i=counter+n_elem_recv+psb_n_elem_send_+1, & + & counter+n_elem_recv+psb_n_elem_send_+n_elem_send + write(iout,*) & + & desc_p%loc_to_glob(desc_p%ext_index(i)), desc_p%ext_index(i) + enddo + endif + counter = counter+n_elem_recv+n_elem_send+3 + enddo + write(iout,*) 'Ovrlap_index' counter = 1 diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index cfb0f7a7..bede3702 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -221,7 +221,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index 7af1d15e..60606ef4 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -117,7 +117,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) !locals Integer :: i,np,me,err,n,err_act - integer :: int_err(5),exch(2), thalo(1), tovr(1) + integer :: int_err(5),exch(2), thalo(1), tovr(1), text(1) logical, parameter :: debug=.false. character(len=20) :: name @@ -204,9 +204,10 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) tovr = -1 thalo = -1 + text = -1 desc_a%lprm(:) = 0 - call psi_cnv_dsc(thalo,tovr,desc_a,info) + call psi_cnv_dsc(thalo,tovr,text,desc_a,info) if (info /= 0) then call psb_errpush(4010,name,a_err='psi_cvn_dsc') goto 9999 @@ -219,7 +220,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_cdtransfer.f90 b/base/tools/psb_cdtransfer.f90 index 1a4e8d0e..056f6b82 100644 --- a/base/tools/psb_cdtransfer.f90 +++ b/base/tools/psb_cdtransfer.f90 @@ -79,6 +79,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) if (info == 0) call psb_transfer( desc_in%bnd_elem , desc_out%bnd_elem , info) if (info == 0) call psb_transfer( desc_in%ovrlap_elem , desc_out%ovrlap_elem , info) if (info == 0) call psb_transfer( desc_in%ovrlap_index, desc_out%ovrlap_index , info) + if (info == 0) call psb_transfer( desc_in%ext_index , desc_out%ext_index , info) if (info == 0) call psb_transfer( desc_in%loc_to_glob , desc_out%loc_to_glob , info) if (info == 0) call psb_transfer( desc_in%glob_to_loc , desc_out%glob_to_loc , info) if (info == 0) call psb_transfer( desc_in%lprm , desc_out%lprm , info) @@ -112,7 +113,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 7a929ad8..82a9f1a1 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -139,7 +139,7 @@ subroutine psb_dalloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -266,7 +266,7 @@ subroutine psb_dallocv(x, desc_a,info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index b1c54bd8..9faecac5 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -121,7 +121,7 @@ subroutine psb_dasb(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -236,7 +236,7 @@ subroutine psb_dasbv(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dcdovr.f90 b/base/tools/psb_dcdovr.f90 index bc1ae7be..92c36839 100644 --- a/base/tools/psb_dcdovr.f90 +++ b/base/tools/psb_dcdovr.f90 @@ -44,7 +44,7 @@ ! descriptor. ! info - integer. Eventually returns an error code. ! -Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) +Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype) use psb_serial_mod use psb_descriptor_type @@ -62,6 +62,17 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Type(psb_desc_type), Intent(in) :: desc_a Type(psb_desc_type), Intent(inout) :: desc_ov integer, intent(out) :: info + integer, intent(in),optional :: extype + + interface psb_icdasb + 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 @@ -70,12 +81,12 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) & 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,& + & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, mglob, glx, & - & idxr, idxs, lx, iszr, iszs, nxch, nsnd, nrcv,lidx + & idxr, idxs, lx, iszr, iszs, nxch, nsnd, nrcv,lidx,irsv, extype_ type(psb_dspmat_type) :: blk - Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:) + 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(:) @@ -93,6 +104,11 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) If(debug) Write(0,*)'in psb_cdovr',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) @@ -151,17 +167,12 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) 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)) - if (psb_is_large_desc(desc_a)) then - desc_ov%matrix_data(psb_desc_size_) = psb_desc_large_ - else - desc_ov%matrix_data(psb_desc_size_) = psb_desc_normal_ - end if +!!$ write(0,*) 'Size of desc_ov ', desc_ov%matrix_data(psb_desc_size_), & +!!$ & psb_desc_normal_,psb_desc_large_ call psb_cd_set_bld(desc_ov,info) -!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ If(debug) then Write(0,*)'Start cdovrbld',me,lworks,lworkr @@ -193,8 +204,8 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) blk%fida='COO' - Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& - & halo(size(desc_a%halo_index)),stat=info) + 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 @@ -202,12 +213,13 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) halo(:) = desc_a%halo_index(:) desc_ov%ovrlap_elem(:) = -1 tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 tmp_halo(:) = -1 counter_e = 1 tot_recv = 0 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) @@ -226,18 +238,18 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) gidx = desc_ov%loc_to_glob(idx) - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_check_size((cntov_o+3),orig_ovr,info,pad=-1) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_check_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 + 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+2 end Do @@ -262,7 +274,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ! 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, we may ignore HcN. + ! reached the desired level HrN. ! ! Do i_ovr = 1, novr @@ -285,6 +297,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) 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 @@ -306,7 +319,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ! 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 ! @@ -338,21 +350,19 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) tmp_ovr_idx(counter_o+2)=gidx tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 - if (.not.psb_is_large_desc(desc_ov)) then - call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if + call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_check_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 + 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 - end if + counter_h=counter_h+3 Enddo if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) @@ -385,7 +395,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ! ! Prepare to exchange the halo rows with the other proc. ! - If (i_ovr < (novr)) Then + If (i_ovr <= (novr)) Then n_elem = psb_sp_get_nnz_row(idx,a) call psb_check_size((idxs+tot_elem+n_elem),works,info) @@ -424,7 +434,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Enddo - if (i_ovr < novr) then + if (i_ovr <= novr) then if (tot_elem > 1) then call imsr(tot_elem,works(idxs+1)) lx = works(idxs+1) @@ -450,7 +460,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Enddo if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv - if (i_ovr < novr) then + 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 @@ -503,7 +513,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) if (debug) write(0,*) 'ISZR :',iszr - if (psb_is_large_desc(desc_a)) then + if (psb_is_large_desc(desc_ov)) then call psb_check_size(iszr,maskr,info) if (info /= 0) then info=4010 @@ -549,11 +559,13 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=lidx + t_halo_in(counter_t+3)=-1 counter_t=counter_t+3 if (.false.) write(0,*) me,' CDOVRBLD: Added t_halo_in ',& &proc_id,lidx,idx endif end Do + n_col = psb_cd_get_local_cols(desc_ov) else @@ -589,6 +601,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=n_col + t_halo_in(counter_t+3)=-1 counter_t=counter_t+3 if (debug) write(0,*) me,' CDOVRBLD: Added into t_halo_in from recv',& &proc_id,n_col,idx @@ -602,7 +615,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) end if end if -!!$ desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) ! ! 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 @@ -610,10 +622,10 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) ! 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 - t_halo_in(counter_t)=-1 if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) if (debug) write(0,*) me,'Calling Crea_Halo' @@ -636,16 +648,72 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) End Do - desc_ov%matrix_data(psb_m_)=psb_cd_get_global_rows(desc_a) - desc_ov%matrix_data(psb_n_)=psb_cd_get_global_cols(desc_a) - tmp_halo(counter_h:)=-1 - tmp_ovr_idx(counter_o:)=-1 + 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_check_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_check_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_check_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_check_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 cnv_dsc. This is + ! N levels of overlap. Just call icdasb forcing to use + ! the halo_index provided. This is ! the same routine as gets called inside CDASB. ! @@ -653,14 +721,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) write(0,*) 'psb_cdovrbld: converting indexes' call psb_barrier(ictxt) end if - !.... convert comunication stuctures.... - ! Note that we have to keep local_rows until the very end, - ! because otherwise the halo build mechanism of cdasb - ! will not work. - call psb_transfer(tmp_ovr_idx,desc_ov%ovrlap_index,info) - call psb_transfer(tmp_halo,desc_ov%halo_index,info) - call psb_cdasb(desc_ov,info) - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + call psb_icdasb(desc_ov,info,ext_hv=.true.) if (debug) then write(0,*) me,'Done CDASB' @@ -679,7 +740,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dcsrp.f90 b/base/tools/psb_dcsrp.f90 index b0422af4..748766f3 100644 --- a/base/tools/psb_dcsrp.f90 +++ b/base/tools/psb_dcsrp.f90 @@ -135,7 +135,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) call psb_realloc(l_dcsdp,work_dcsdp,info) call psb_realloc(n_col,ipt,info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -161,7 +161,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) if (debug) write(0,*) 'spasb: calling dcsrp',size(work_dcsdp) call dcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& & ipt,work_dcsdp,size(work_dcsdp),info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 char_err='dcsrp' call psb_errpush(info,name,a_err=char_err) @@ -182,7 +182,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 6d5c2681..f1c4d605 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -83,7 +83,7 @@ subroutine psb_dfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 call psb_errpush(info,name) goto 9999 @@ -95,7 +95,7 @@ subroutine psb_dfree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -156,7 +156,7 @@ subroutine psb_dfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 call psb_errpush(info,name) endif @@ -166,7 +166,7 @@ subroutine psb_dfreev(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dgelp.f90 b/base/tools/psb_dgelp.f90 index 1dd8d561..5301e660 100644 --- a/base/tools/psb_dgelp.f90 +++ b/base/tools/psb_dgelp.f90 @@ -133,7 +133,7 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -275,7 +275,7 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 25c603e0..b9068c82 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -41,8 +41,9 @@ ! info - integer. Eventually returns an error code subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) !....insert dense submatrix to dense matrix ..... - use psb_descriptor_type use psb_const_mod + use psb_descriptor_type + use psb_spmat_type use psb_error_mod use psb_penv_mod use psi_mod @@ -172,7 +173,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -225,6 +226,7 @@ end subroutine psb_dinsvi subroutine psb_dinsi(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 @@ -364,7 +366,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 741972c8..ec9105a1 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -138,7 +138,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index 826d246f..d9233ab1 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -133,7 +133,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) a%k = n_col call psb_sp_clone(a,atemp,info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 ch_err='psb_sp_clone' call psb_errpush(info,name,a_err=ch_err) @@ -159,7 +159,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_csdp' call psb_errpush(info,name,a_err=ch_err) @@ -189,7 +189,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) atemp%m=a%m atemp%k=a%k ! check on allocation - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) @@ -198,7 +198,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) call psb_csdp(atemp,a,info,check='R') ! check on error retuned by dcsdp - if (info /= no_err) then + if (info /= psb_no_err_) then info = 4010 ch_err='psb_csdp90' call psb_errpush(info,name,a_err=ch_err) @@ -206,7 +206,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) end if call psb_sp_free(atemp,info) - if (info /= no_err) then + if (info /= psb_no_err_) then info = 4010 ch_err='sp_free' call psb_errpush(info,name,a_err=ch_err) @@ -227,7 +227,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dspcnv.f90 b/base/tools/psb_dspcnv.f90 index a8056f88..71476130 100644 --- a/base/tools/psb_dspcnv.f90 +++ b/base/tools/psb_dspcnv.f90 @@ -186,7 +186,7 @@ subroutine psb_dspcnv(a,b,desc_a,info) & size(b%aspk),size(b%ia1),size(b%ia2),& & work_dcsdp,size(work_dcsdp),info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 ch_err='dcsdp' call psb_errpush(info, name, a_err=ch_err) @@ -236,7 +236,7 @@ subroutine psb_dspcnv(a,b,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index 62751831..1a25bfbc 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -83,7 +83,7 @@ subroutine psb_dspfree(a, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dsphalo.f90 b/base/tools/psb_dsphalo.f90 index ae0a4368..acab1816 100644 --- a/base/tools/psb_dsphalo.f90 +++ b/base/tools/psb_dsphalo.f90 @@ -45,8 +45,9 @@ !* * !* * !***************************************************************************** -Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) +Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,cliprow,outfmt,data) + use psb_const_mod use psb_serial_mod use psb_descriptor_type use psb_realloc_mod @@ -58,19 +59,22 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) Type(psb_dspmat_type),Intent(in) :: a Type(psb_dspmat_type),Intent(inout) :: blk - Type(psb_desc_type),Intent(in) :: desc_a + Type(psb_desc_type),Intent(in), target :: desc_a integer, intent(out) :: info - logical, optional, intent(in) :: rwcnv,clcnv + logical, optional, intent(in) :: rwcnv,clcnv,cliprow 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 + & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,nrmin,& + & data_ Type(psb_dspmat_type) :: tmp Integer :: l1, icomm, err_act Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), & & rvsz(:), bsdindx(:),sdsz(:) - logical :: rwcnv_,clcnv_ + integer, pointer :: idxv(:) + logical :: rwcnv_,clcnv_,cliprow_ character(len=5) :: outfmt_ Logical,Parameter :: debug=.false., debugprt=.false. real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7,t8,t9 @@ -92,9 +96,19 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) else clcnv_ = .true. endif + if (present(cliprow)) then + cliprow_ = cliprow + else + cliprow_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif if (present(outfmt)) then - call touppers(outfmt,outfmt_) + outfmt_ = toupper(outfmt) else outfmt_ = 'CSR' endif @@ -115,6 +129,21 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) If (debug) Write(0,*)'dsphalo',me + select case(data_) + case(psb_comm_halo_) + idxv => desc_a%halo_index + + case(psb_comm_ovr_) + idxv => desc_a%ovrlap_index + + case(psb_comm_ext_) + idxv => desc_a%ext_index + + case default + call psb_errpush(4010,name,a_err='wrong Data selector') + goto 9999 + end select + l1 = 0 @@ -131,14 +160,14 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) blk%m = 0 ! For all rows in the halo descriptor, extract and send/receive. Do - proc=desc_a%halo_index(counter) + proc=idxv(counter) if (proc == -1) exit - n_el_recv = desc_a%halo_index(counter+psb_n_elem_recv_) + n_el_recv = idxv(counter+psb_n_elem_recv_) counter = counter+n_el_recv - n_el_send = desc_a%halo_index(counter+psb_n_elem_send_) + n_el_send = idxv(counter+psb_n_elem_send_) tot_elem = 0 Do j=0,n_el_send-1 - idx = desc_a%halo_index(counter+psb_elem_send_+j) + idx = idxv(counter+psb_elem_send_+j) n_elem = psb_sp_get_nnz_row(idx,a) tot_elem = tot_elem+n_elem Enddo @@ -162,11 +191,11 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idxr = 0 counter = 1 Do - proc=desc_a%halo_index(counter) + proc=idxv(counter) if (proc == -1) exit - n_el_recv = desc_a%halo_index(counter+psb_n_elem_recv_) + n_el_recv = idxv(counter+psb_n_elem_recv_) counter = counter+n_el_recv - n_el_send = desc_a%halo_index(counter+psb_n_elem_send_) + n_el_send = idxv(counter+psb_n_elem_send_) bsdindx(proc+1) = idxs idxs = idxs + sdsz(proc+1) @@ -199,15 +228,15 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) idx = 0 Do - proc=desc_a%halo_index(counter) + proc=idxv(counter) if (proc == -1) exit - n_el_recv=desc_a%halo_index(counter+psb_n_elem_recv_) + n_el_recv=idxv(counter+psb_n_elem_recv_) counter=counter+n_el_recv - n_el_send=desc_a%halo_index(counter+psb_n_elem_send_) + n_el_send=idxv(counter+psb_n_elem_send_) tot_elem=0 Do j=0,n_el_send-1 - idx = desc_a%halo_index(counter+psb_elem_send_+j) + idx = idxv(counter+psb_elem_send_+j) n_elem = psb_sp_get_nnz_row(idx,a) call psb_sp_getblk(idx,a,tmp,info,append=.true.) @@ -261,7 +290,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) ! ! Convert into local numbering ! - if (rwcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I') + if (rwcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I',owned=cliprow_) if (clcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I') if (info /= 0) then @@ -280,21 +309,24 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) close(40+me) end if l1 = 0 + blk%m=0 + nrmin=max(0,a%m) Do i=1,iszr !!$ write(0,*) work5(i),work6(i) r=(blk%ia1(i)) k=(blk%ia2(i)) - If (k.Gt.0) Then + If ((r>nrmin).and.(k>0)) Then l1=l1+1 blk%aspk(l1) = blk%aspk(i) blk%ia1(l1) = r blk%ia2(l1) = k blk%k = max(blk%k,k) + blk%m = max(blk%m,r) End If Enddo blk%fida='COO' blk%infoa(psb_nnz_)=l1 - + blk%m = blk%m - a%m if (debugprt) then open(50+me) call psb_csprt(50+me,blk,head='% SPHALO border .') @@ -324,6 +356,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) ! Do nothing! case default write(0,*) 'Error in DSPHALO : invalid outfmt "',outfmt_,'"' + info=4010 + ch_err='Bad outfmt' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end select t5 = mpi_wtime() @@ -348,7 +384,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index 418e1262..991eab0d 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -250,7 +250,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index e905b157..a6901689 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -99,7 +99,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_get_overlap.f90 b/base/tools/psb_get_overlap.f90 index ca4d1427..1f55ad14 100644 --- a/base/tools/psb_get_overlap.f90 +++ b/base/tools/psb_get_overlap.f90 @@ -14,6 +14,12 @@ subroutine psb_get_ovrlap(ovrel,desc,info) name='psi_get_overlap' call psb_erractionsave(err_act) + if (.not.psb_is_asb_desc(desc)) then + info = 1122 + call psb_errorpush(info,name) + goto 9999 + end if + i=0 j=1 do while(desc%ovrlap_elem(j) /= -1) @@ -55,7 +61,7 @@ subroutine psb_get_ovrlap(ovrel,desc,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index b35d5015..502dcd5c 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -40,7 +40,7 @@ ! info - integer. Eventually returns an error code. ! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process ! -subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) +subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) use psb_descriptor_type use psb_const_mod @@ -55,12 +55,14 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) integer, intent(in) :: x(:) integer, intent(out) :: y(:), info character, intent(in), optional :: iact + logical, intent(in), optional :: owned !....locals.... integer :: n, i, tmp character :: act integer :: int_err(5), err_act real(kind(1.d0)) :: real_val + logical :: owned_ integer, parameter :: zero=0 character(len=20) :: name @@ -75,12 +77,17 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) act='A' endif act = toupper(act) - + if (present(owned)) then + owned_=owned + else + owned_=.false. + end if + int_err=0 real_val = 0.d0 n = size(x) - call psi_idx_cnv(n,x,y,desc_a,info) + call psi_idx_cnv(n,x,y,desc_a,info,owned=owned_) select case(act) case('E','I') @@ -103,7 +110,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -153,7 +160,7 @@ end subroutine psb_glob_to_loc2 ! info - integer. Eventually returns an error code. ! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process ! -subroutine psb_glob_to_loc(x,desc_a,info,iact) +subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) use psb_penv_mod use psb_descriptor_type @@ -167,6 +174,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: x(:) integer, intent(out) :: info + logical, intent(in), optional :: owned character, intent(in), optional :: iact !....locals.... @@ -174,6 +182,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) character :: act integer :: int_err(5), err_act, dectype real(kind(1.d0)) :: real_val, t0, t1,t2 + logical :: owned_ integer, parameter :: zero=0 character(len=20) :: name integer :: ictxt, iam, np @@ -191,11 +200,16 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) else act='A' endif + if (present(owned)) then + owned_=owned + else + owned_=.false. + end if act = toupper(act) n = size(x) - call psi_idx_cnv(n,x,desc_a,info) + call psi_idx_cnv(n,x,desc_a,info,owned=owned_) select case(act) case('E','I') @@ -219,7 +233,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error() diff --git a/base/tools/psb_ialloc.f90 b/base/tools/psb_ialloc.f90 index def8b647..fdbfd4c8 100644 --- a/base/tools/psb_ialloc.f90 +++ b/base/tools/psb_ialloc.f90 @@ -136,7 +136,7 @@ subroutine psb_ialloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -259,7 +259,7 @@ subroutine psb_iallocv(x, desc_a, info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 2ab47475..3ddd773b 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -113,7 +113,7 @@ subroutine psb_iasb(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -225,7 +225,7 @@ subroutine psb_iasbv(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_cdasb.f90 b/base/tools/psb_icdasb.f90 similarity index 88% rename from base/tools/psb_cdasb.f90 rename to base/tools/psb_icdasb.f90 index ff543436..3da71b82 100644 --- a/base/tools/psb_cdasb.f90 +++ b/base/tools/psb_icdasb.f90 @@ -36,7 +36,7 @@ ! Parameters: ! desc_a - type(). The communication descriptor. ! info - integer. Eventually returns an error code. -subroutine psb_cdasb(desc_a,info) +subroutine psb_icdasb(desc_a,info,ext_hv) use psb_descriptor_type use psb_serial_mod use psb_const_mod @@ -49,16 +49,17 @@ subroutine psb_cdasb(desc_a,info) !...Parameters.... type(psb_desc_type), intent(inout) :: desc_a integer, intent(out) :: info - + logical, intent(in), optional :: ext_hv !....Locals.... integer :: int_err(5), itemp(2) - integer,allocatable :: ovrlap_index(:),halo_index(:) + integer,allocatable :: ovrlap_index(:),halo_index(:), ext_index(:) integer :: i,j,err,np,me,lovrlap,lhalo,nhalo,novrlap,max_size,& & max_halo,n_col,ldesc_halo, ldesc_ovrlap, dectype, err_act, & & key, ih, nh, idx, nk,icomm,hsize integer :: ictxt,n_row + logical :: ext_hv_ logical, parameter :: debug=.false., debugwrt=.false. character(len=20) :: name,ch_err @@ -88,7 +89,12 @@ subroutine psb_cdasb(desc_a,info) call psb_errpush(info,name) goto 9999 endif - + + if (present(ext_hv)) then + ext_hv_ = ext_hv + else + ext_hv_ = .false. + end if if (debug) write (0, *) ' Begin matrix assembly...' if (psb_is_bld_desc(desc_a)) then @@ -101,7 +107,7 @@ subroutine psb_cdasb(desc_a,info) endif enddo - if (info /= no_err) then + if (info /= psb_no_err_) then call psb_errpush(info,name,i_err=int_err) goto 9999 endif @@ -109,20 +115,21 @@ subroutine psb_cdasb(desc_a,info) call psb_realloc(psb_cd_get_local_cols(desc_a),desc_a%loc_to_glob,info) if (psb_is_large_desc(desc_a)) then - call psi_ldsc_pre_halo(desc_a,info) + call psi_ldsc_pre_halo(desc_a,ext_hv_,info) end if call psb_transfer(desc_a%ovrlap_index,ovrlap_index,info) call psb_transfer(desc_a%halo_index,halo_index,info) + call psb_transfer(desc_a%ext_index,ext_index,info) - call psi_cnv_dsc(halo_index,ovrlap_index,desc_a,info) + call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc_a,info) if (info /= 0) then call psb_errpush(4010,name,a_err='psi_cnv_dsc') goto 9999 end if - deallocate(ovrlap_index, halo_index, stat=info) + deallocate(ovrlap_index, halo_index, ext_index, stat=info) if (info /= 0) then info =4000 call psb_errpush(info,name) @@ -144,11 +151,11 @@ subroutine psb_cdasb(desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_ret) then + if (err_act.eq.psb_act_ret_) then return else call psb_error(ictxt) end if return -end subroutine psb_cdasb +end subroutine psb_icdasb diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index ffa0ec55..607f553b 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -95,7 +95,7 @@ subroutine psb_ifree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -188,7 +188,7 @@ subroutine psb_ifreev(x, desc_a,info) !deallocate x deallocate(x,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 call psb_errpush(info,name) endif @@ -198,7 +198,7 @@ subroutine psb_ifreev(x, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index fb6e3a9c..d276c10a 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -42,6 +42,7 @@ subroutine psb_iinsvi(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 @@ -171,7 +172,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -224,6 +225,7 @@ end subroutine psb_iinsvi subroutine psb_iinsi(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 @@ -363,7 +365,7 @@ subroutine psb_iinsi(m,irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 5da2598d..8a4cfa00 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -117,7 +117,7 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error() @@ -240,7 +240,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error() diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index 36ac2911..5518836b 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -138,7 +138,7 @@ subroutine psb_zalloc(x, desc_a, info, n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -264,7 +264,7 @@ subroutine psb_zallocv(x, desc_a,info,n) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 4c73369e..e91f1066 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -118,7 +118,7 @@ subroutine psb_zasb(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -234,7 +234,7 @@ subroutine psb_zasbv(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zcdovr.f90 b/base/tools/psb_zcdovr.f90 index 85e91bfe..9f6c5fa6 100644 --- a/base/tools/psb_zcdovr.f90 +++ b/base/tools/psb_zcdovr.f90 @@ -43,7 +43,7 @@ ! desc_ov - type(). The auxiliary output communication descriptor. ! info - integer. Eventually returns an error code. ! -Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) +Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info, extype) use psb_serial_mod use psb_descriptor_type @@ -61,6 +61,17 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) Type(psb_desc_type), Intent(in) :: desc_a Type(psb_desc_type), Intent(inout) :: desc_ov integer, intent(out) :: info + integer, intent(in),optional :: extype + + interface psb_icdasb + 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 @@ -69,12 +80,12 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) & 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,& + & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, mglob, glx, & - & idxr, idxs, lx, iszr, iszs, nxch, nsnd, nrcv,lidx + & idxr, idxs, lx, iszr, iszs, nxch, nsnd, nrcv,lidx,irsv, extype_ type(psb_zspmat_type) :: blk - Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:) + 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(:) @@ -92,6 +103,11 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) If(debug) Write(0,*)'in psb_cdovr',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) @@ -154,13 +170,9 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1) l_tmp_halo = novr*(3*Size(desc_a%halo_index)) - if (psb_is_large_desc(desc_a)) then - desc_ov%matrix_data(psb_desc_size_) = psb_desc_large_ - else - desc_ov%matrix_data(psb_desc_size_) = psb_desc_normal_ - end if +!!$ write(0,*) 'Size of desc_ov ', desc_ov%matrix_data(psb_desc_size_), & +!!$ & psb_desc_normal_,psb_desc_large_ call psb_cd_set_bld(desc_ov,info) -!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ If(debug) then Write(0,*)'Start cdovrbld',me,lworks,lworkr @@ -192,8 +204,8 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) blk%fida='COO' - Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),& - & halo(size(desc_a%halo_index)),stat=info) + 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 @@ -201,12 +213,13 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) halo(:) = desc_a%halo_index(:) desc_ov%ovrlap_elem(:) = -1 tmp_ovr_idx(:) = -1 + orig_ovr(:) = -1 tmp_halo(:) = -1 counter_e = 1 tot_recv = 0 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) @@ -225,18 +238,18 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) gidx = desc_ov%loc_to_glob(idx) - call psb_check_size((counter_o+3),tmp_ovr_idx,info,pad=-1) + call psb_check_size((cntov_o+3),orig_ovr,info,pad=-1) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_check_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 + 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+2 end Do @@ -261,7 +274,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! 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, we may ignore HcN. + ! reached the desired level HrN. ! ! Do i_ovr = 1, novr @@ -284,6 +297,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) 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 @@ -305,7 +319,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! 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 ! @@ -337,21 +350,19 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) tmp_ovr_idx(counter_o+2)=gidx tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 - if (.not.psb_is_large_desc(desc_ov)) then - call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_check_size') - goto 9999 - end if + call psb_check_size((counter_h+3),tmp_halo,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_check_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 + 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 - end if + counter_h=counter_h+3 Enddo if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) @@ -384,7 +395,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! ! Prepare to exchange the halo rows with the other proc. ! - If (i_ovr < (novr)) Then + If (i_ovr <= (novr)) Then n_elem = psb_sp_get_nnz_row(idx,a) call psb_check_size((idxs+tot_elem+n_elem),works,info) @@ -423,7 +434,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) Enddo - if (i_ovr < novr) then + if (i_ovr <= novr) then if (tot_elem > 1) then call imsr(tot_elem,works(idxs+1)) lx = works(idxs+1) @@ -449,7 +460,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) Enddo if (debug) write(0,*)me,'End phase 1 CDOVRBLD', m, n_col, tot_recv - if (i_ovr < novr) then + 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 @@ -502,7 +513,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) if (debug) write(0,*) 'ISZR :',iszr - if (psb_is_large_desc(desc_a)) then + if (psb_is_large_desc(desc_ov)) then call psb_check_size(iszr,maskr,info) if (info /= 0) then info=4010 @@ -548,11 +559,13 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=lidx + t_halo_in(counter_t+3)=-1 counter_t=counter_t+3 if (.false.) write(0,*) me,' CDOVRBLD: Added t_halo_in ',& &proc_id,lidx,idx endif end Do + n_col = psb_cd_get_local_cols(desc_ov) else @@ -588,6 +601,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=n_col + t_halo_in(counter_t+3)=-1 counter_t=counter_t+3 if (debug) write(0,*) me,' CDOVRBLD: Added into t_halo_in from recv',& &proc_id,n_col,idx @@ -601,7 +615,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) end if end if -!!$ desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) ! ! 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 @@ -609,10 +622,10 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! 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 - t_halo_in(counter_t)=-1 if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) if (debug) write(0,*) me,'Calling Crea_Halo' @@ -635,16 +648,72 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) End Do - desc_ov%matrix_data(psb_m_)=psb_cd_get_global_rows(desc_a) - desc_ov%matrix_data(psb_n_)=psb_cd_get_global_cols(desc_a) - tmp_halo(counter_h:)=-1 - tmp_ovr_idx(counter_o:)=-1 + 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_check_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_check_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_check_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_check_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 cnv_dsc. This is + ! N levels of overlap. Just call icdasb forcing to use + ! the halo_index provided. This is ! the same routine as gets called inside CDASB. ! @@ -652,14 +721,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) write(0,*) 'psb_cdovrbld: converting indexes' call psb_barrier(ictxt) end if - !.... convert comunication stuctures.... - ! Note that we have to keep local_rows until the very end, - ! because otherwise the halo build mechanism of cdasb - ! will not work. - call psb_transfer(tmp_ovr_idx,desc_ov%ovrlap_index,info) - call psb_transfer(tmp_halo,desc_ov%halo_index,info) - call psb_cdasb(desc_ov,info) - desc_ov%matrix_data(psb_n_row_)=desc_ov%matrix_data(psb_n_col_) + call psb_icdasb(desc_ov,info,ext_hv=.true.) if (debug) then write(0,*) me,'Done CDASB' @@ -678,7 +740,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zcsrp.f90 b/base/tools/psb_zcsrp.f90 index 4c5fab0d..54941c6a 100644 --- a/base/tools/psb_zcsrp.f90 +++ b/base/tools/psb_zcsrp.f90 @@ -134,7 +134,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) call psb_realloc(l_dcsdp,work_dcsdp,info) call psb_realloc(n_col,ipt,info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 char_err='psrealloc' call psb_errpush(info,name,a_err=char_err) @@ -160,7 +160,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) if (debug) write(0,*) 'spasb: calling dcsrp',size(work_dcsdp) call zcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& & ipt,work_dcsdp,size(work_dcsdp),info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 char_err='dcsrp' call psb_errpush(info,name,a_err=char_err) @@ -182,7 +182,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error() return end if diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index 9d4cc817..cda58bb6 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -83,7 +83,7 @@ subroutine psb_zfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 call psb_errpush(info,name) goto 9999 @@ -95,7 +95,7 @@ subroutine psb_zfree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -159,7 +159,7 @@ subroutine psb_zfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) - if (info /= no_err) then + if (info /= psb_no_err_) then info=4000 call psb_errpush(info,name) endif @@ -170,7 +170,7 @@ subroutine psb_zfreev(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_zgelp.f90 b/base/tools/psb_zgelp.f90 index 3613583a..528eed74 100644 --- a/base/tools/psb_zgelp.f90 +++ b/base/tools/psb_zgelp.f90 @@ -133,7 +133,7 @@ subroutine psb_zgelp(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -274,7 +274,7 @@ subroutine psb_zgelpv(trans,iperm,x,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 6f7773f7..0d49ca6b 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -42,6 +42,7 @@ subroutine psb_zinsvi(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 @@ -172,7 +173,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) @@ -225,6 +226,7 @@ end subroutine psb_zinsvi subroutine psb_zinsi(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 @@ -364,7 +366,7 @@ subroutine psb_zinsi(m,irw, val, x, desc_a, info, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index cfcce5a6..a61e0cb3 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -136,7 +136,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_ret) then + if (err_act == psb_act_ret_) then return else call psb_error(ictxt) diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index c4d00a5a..c6f0378b 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -132,7 +132,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) a%k = n_col call psb_sp_clone(a,atemp,info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 ch_err='psb_sp_clone' call psb_errpush(info,name,a_err=ch_err) @@ -158,7 +158,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) IF (debug) WRITE (*, *) me,' ASB: From ZCSDP',info,' ',A%FIDA - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_csdp' call psb_errpush(info,name,a_err=ch_err) @@ -188,7 +188,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) atemp%m=a%m atemp%k=a%k ! check on allocation - if (info /= no_err) then + if (info /= psb_no_err_) then info=4010 ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) @@ -197,7 +197,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) call psb_csdp(atemp,a,info,check='R') ! check on error retuned by zcsdp - if (info /= no_err) then + if (info /= psb_no_err_) then info = 4010 ch_err='psb_csdp90' call psb_errpush(info,name,a_err=ch_err) @@ -205,7 +205,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) end if call psb_sp_free(atemp,info) - if (info /= no_err) then + if (info /= psb_no_err_) then info = 4010 ch_err='sp_free' call psb_errpush(info,name,a_err=ch_err) @@ -226,7 +226,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zspcnv.f90 b/base/tools/psb_zspcnv.f90 index c3d24568..73790c48 100644 --- a/base/tools/psb_zspcnv.f90 +++ b/base/tools/psb_zspcnv.f90 @@ -187,7 +187,7 @@ subroutine psb_zspcnv(a,b,desc_a,info) & size(b%aspk),size(b%ia1),size(b%ia2),& & work_dcsdp,size(work_dcsdp),info) - if(info /= no_err) then + if(info /= psb_no_err_) then info=4010 ch_err='zcsdp' call psb_errpush(info, name, a_err=ch_err) @@ -237,7 +237,7 @@ subroutine psb_zspcnv(a,b,desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index eb7a0f9b..1cea4fcc 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -83,7 +83,7 @@ subroutine psb_zspfree(a, desc_a,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zsphalo.f90 b/base/tools/psb_zsphalo.f90 index 7ad58b42..fbdabccc 100644 --- a/base/tools/psb_zsphalo.f90 +++ b/base/tools/psb_zsphalo.f90 @@ -332,7 +332,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zspins.f90 b/base/tools/psb_zspins.f90 index 712bb241..cf4600b0 100644 --- a/base/tools/psb_zspins.f90 +++ b/base/tools/psb_zspins.f90 @@ -249,7 +249,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index 8b04971b..f86e59b2 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -97,7 +97,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/baseprec/psb_dbaseprc_aply.f90 b/baseprec/psb_dbaseprc_aply.f90 index 475dea0b..fde394f0 100644 --- a/baseprec/psb_dbaseprc_aply.f90 +++ b/baseprec/psb_dbaseprc_aply.f90 @@ -140,7 +140,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) 9999 continue call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dbaseprc_bld.f90 b/baseprec/psb_dbaseprc_bld.f90 index 6bb162ca..994369b9 100644 --- a/baseprec/psb_dbaseprc_bld.f90 +++ b/baseprec/psb_dbaseprc_bld.f90 @@ -195,7 +195,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dbjac_aply.f90 b/baseprec/psb_dbjac_aply.f90 index 67d74288..d2983392 100644 --- a/baseprec/psb_dbjac_aply.f90 +++ b/baseprec/psb_dbjac_aply.f90 @@ -201,7 +201,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) 9999 continue call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_ddiagsc_bld.f90 b/baseprec/psb_ddiagsc_bld.f90 index 1029cdbe..4fea5237 100644 --- a/baseprec/psb_ddiagsc_bld.f90 +++ b/baseprec/psb_ddiagsc_bld.f90 @@ -153,7 +153,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dilu_bld.f90 b/baseprec/psb_dilu_bld.f90 index c17f4e51..609667b8 100644 --- a/baseprec/psb_dilu_bld.f90 +++ b/baseprec/psb_dilu_bld.f90 @@ -272,7 +272,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dilu_fct.f90 b/baseprec/psb_dilu_fct.f90 index e9eeb106..975304bf 100644 --- a/baseprec/psb_dilu_fct.f90 +++ b/baseprec/psb_dilu_fct.f90 @@ -116,7 +116,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -460,7 +460,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dprc_aply.f90 b/baseprec/psb_dprc_aply.f90 index cba287d3..b5a527e7 100644 --- a/baseprec/psb_dprc_aply.f90 +++ b/baseprec/psb_dprc_aply.f90 @@ -106,7 +106,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -215,7 +215,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) 9999 continue call psb_errpush(info,name) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dprecbld.f90 b/baseprec/psb_dprecbld.f90 index ce65964e..a7cba74d 100644 --- a/baseprec/psb_dprecbld.f90 +++ b/baseprec/psb_dprecbld.f90 @@ -109,7 +109,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dprecfree.f90 b/baseprec/psb_dprecfree.f90 index 33901dc8..a8a871f7 100644 --- a/baseprec/psb_dprecfree.f90 +++ b/baseprec/psb_dprecfree.f90 @@ -60,7 +60,7 @@ subroutine psb_dprecfree(p,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_dsp_renum.f90 b/baseprec/psb_dsp_renum.f90 index 4404d21c..066b641a 100644 --- a/baseprec/psb_dsp_renum.f90 +++ b/baseprec/psb_dsp_renum.f90 @@ -284,7 +284,7 @@ subroutine psb_dsp_renum(a,desc_a,p,atmp,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -380,7 +380,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zbaseprc_aply.f90 b/baseprec/psb_zbaseprc_aply.f90 index 8c1196f2..bca2494d 100644 --- a/baseprec/psb_zbaseprc_aply.f90 +++ b/baseprec/psb_zbaseprc_aply.f90 @@ -140,7 +140,7 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) 9999 continue call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zbaseprc_bld.f90 b/baseprec/psb_zbaseprc_bld.f90 index 13d74e24..bd49c619 100644 --- a/baseprec/psb_zbaseprc_bld.f90 +++ b/baseprec/psb_zbaseprc_bld.f90 @@ -194,7 +194,7 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zbjac_aply.f90 b/baseprec/psb_zbjac_aply.f90 index 54bbb083..9418aa5b 100644 --- a/baseprec/psb_zbjac_aply.f90 +++ b/baseprec/psb_zbjac_aply.f90 @@ -201,7 +201,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) 9999 continue call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zdiagsc_bld.f90 b/baseprec/psb_zdiagsc_bld.f90 index 66162ca9..166edd37 100644 --- a/baseprec/psb_zdiagsc_bld.f90 +++ b/baseprec/psb_zdiagsc_bld.f90 @@ -148,7 +148,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zilu_bld.f90 b/baseprec/psb_zilu_bld.f90 index a1f95a38..279431a2 100644 --- a/baseprec/psb_zilu_bld.f90 +++ b/baseprec/psb_zilu_bld.f90 @@ -272,7 +272,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zilu_fct.f90 b/baseprec/psb_zilu_fct.f90 index df1773b9..ecd93fbd 100644 --- a/baseprec/psb_zilu_fct.f90 +++ b/baseprec/psb_zilu_fct.f90 @@ -112,7 +112,7 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -456,7 +456,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zprc_aply.f90 b/baseprec/psb_zprc_aply.f90 index 1b75b10c..e83ae236 100644 --- a/baseprec/psb_zprc_aply.f90 +++ b/baseprec/psb_zprc_aply.f90 @@ -106,7 +106,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -215,7 +215,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) 9999 continue call psb_errpush(info,name) call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zprecbld.f90 b/baseprec/psb_zprecbld.f90 index 995b3730..5221d0e6 100644 --- a/baseprec/psb_zprecbld.f90 +++ b/baseprec/psb_zprecbld.f90 @@ -110,7 +110,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zprecfree.f90 b/baseprec/psb_zprecfree.f90 index bcf61c95..42abde35 100644 --- a/baseprec/psb_zprecfree.f90 +++ b/baseprec/psb_zprecfree.f90 @@ -60,7 +60,7 @@ subroutine psb_zprecfree(p,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/baseprec/psb_zsp_renum.f90 b/baseprec/psb_zsp_renum.f90 index f2f32b11..84d3a7ad 100644 --- a/baseprec/psb_zsp_renum.f90 +++ b/baseprec/psb_zsp_renum.f90 @@ -282,7 +282,7 @@ subroutine psb_zsp_renum(a,desc_a,p,atmp,info) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if @@ -378,7 +378,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/docs/pdf/datastruct.tex b/docs/pdf/datastruct.tex index 0d38078a..d0221597 100644 --- a/docs/pdf/datastruct.tex +++ b/docs/pdf/datastruct.tex @@ -99,7 +99,7 @@ as follows: \begin{minipage}[tl]{0.9\textwidth} \begin{verbatim} type psb_desc_type - integer, allocatable :: matrix_data(:), halo_index(:) + integer, allocatable :: matrix_data(:), halo_index(:), ext_index(:) integer, allocatable :: overlap_elem(:), overlap_index(:) integer, allocatable :: loc_to_glob(:), glob_to_loc(:) integer, allocatable :: hashv(:), glb_lc(:,:) diff --git a/docs/pdf/toolsrout.tex b/docs/pdf/toolsrout.tex index e0617d16..42a8f0dc 100644 --- a/docs/pdf/toolsrout.tex +++ b/docs/pdf/toolsrout.tex @@ -65,12 +65,33 @@ An integer value; 0 means no error has been detected. \verb|vl| must be specified, thereby choosing the initialization strategy as follows: \begin{description} -\item[parts] In this case we have a subroutine that takes as input a - index and the total number of indices in the space, and produces in - output a vector containing the set of processes (usually with just - one entry) to which the index should be assigned. If this argument - is specified, then it is mandatory to also specify the argument - \verb|mg|. +\item[parts] In this case we have a subroutine specifying the mapping + between global indices and process/local index pairs. If this + optional argument is specified, then it is mandatory to + specify the argument \verb|mg| as well. + The subroutine must conform to the following interface: +\begin{verbatim} + interface + subroutine psb_parts(glob_index,nrow,np,pv,nv) + integer, intent (in) :: glob_index,np,nrow + integer, intent (out) :: nv, pv(*) + end subroutine psb_parts + end interface +\end{verbatim} + The input arguments are: + \begin{description} + \item[glob\_index] The global index to be mapped; + \item[np] The number of processes in the mapping; + \item[nrow] The total number of global rows in the mapping; + \end{description} + The output arguments are: + \begin{description} + \item[nv] The number of entries in \verb|pv|; + \item[pv] A vector containint the indices of the processes to + which the global index should be assigend; each entry must satisfy + $0\le pv(i) < np$; if $nv>1$ we have an index assigned to multiple + processes, i.e. we have an overlap among the subdomains. + \end{description} \item[vg] In this case the association between an index and a process is specified via an integer vector; the size of the index space is equal to the size of \verb|vg|, and each index $i$ is assigned to @@ -81,7 +102,7 @@ An integer value; 0 means no error has been detected. to the current process; thus, the global problem size $mg$ is given by the sum of the sizes of the individual vectors \verb|vl| specified on the calling processes. The subroutine will check that each entry - in the global index space $(1\dots mg)$ is specified exactly once. + in the global index space $(1\dots mg)$ is specified exactly once. \end{description} \item On exit from this routine the descriptor is in the build state \end{enumerate} @@ -221,6 +242,52 @@ An integer value; 0 means no error has been detected. \end{description} + +% +%% psb_cdcpy %% +% +\subroutine{psb\_cdbldext}{Build an extended communication descriptor} + +\syntax{call psb\_cdbldext}{a,desc\_a,nl,desc\_out, info, extype} + +This subroutine builds an extended communication descriptor, based on +the input descriptor \verb|desc_a| and on the stencil specified +through the input sparse matrix \verb|a|. +\begin{description} +\item[\bf On Entry] +\item[a] A sparse matrix +Scope:{\bf local}.\\ +Type:{\bf required}.\\ +Specified as: a structured data type. +\item[desc\_a] the communication descriptor.\\ +Scope:{\bf local}.\\ +Type:{\bf required}.\\ +Specified as: a structured data of type \spdata. +\item[nl] the number of layers desired.\\ +Scope:{\bf global}.\\ +Type:{\bf required}.\\ +Specified as: an integer value $nl\ge 0$. +\item[extype] the kiond of estension required.\\ +Scope:{\bf global}.\\ +Type:{\bf optional }.\\ +Specified as: an integer value +\verb|psb_ovt_xhal_|, \verb|psb_ovt_asov_|, default: \verb|psb_ovt_xhal_| + +\end{description} + +\begin{description} +\item[\bf On Return] +\item[desc\_out] the extended communication descriptor.\\ +Scope:{\bf local}.\\ +Type:{\bf required}.\\ +Specified as: a structured data of type \descdata. +\item[info] Error code.\\ +Scope: {\bf local} \\ +Type: {\bf required} \\ +An integer value; 0 means no error has been detected. +\end{description} + + %% % %% %% psb_cdren %% %% % @@ -892,6 +959,8 @@ An integer value; 0 means no error has been detected. \end{description} + + % %% psb_ins %% % diff --git a/krylov/Makefile b/krylov/Makefile index c77ae8c3..64b2f7af 100644 --- a/krylov/Makefile +++ b/krylov/Makefile @@ -21,6 +21,7 @@ lib: $(OBJS) /bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR) /bin/cp -p $(LIBMOD) $(LIBDIR) +$(OBJS): $(LIBDIR)/psb_prec_mod$(.mod) veryclean: clean /bin/rm -f $(HERE)/$(LIBNAME) diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index 083ef11b..bf7daca7 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -350,7 +350,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_dcg.f90 b/krylov/psb_dcg.f90 index 6e0f86b2..e1804687 100644 --- a/krylov/psb_dcg.f90 +++ b/krylov/psb_dcg.f90 @@ -280,7 +280,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index 9416e54f..3449408e 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -339,7 +339,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_dcgstab.f90 b/krylov/psb_dcgstab.f90 index ab08eb3b..d8fe24ae 100644 --- a/krylov/psb_dcgstab.f90 +++ b/krylov/psb_dcgstab.f90 @@ -391,7 +391,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index 4045cb7f..c29c2dc1 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -397,7 +397,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_dgmresr.f90 b/krylov/psb_dgmresr.f90 index e0b59273..3cd4b7e1 100644 --- a/krylov/psb_dgmresr.f90 +++ b/krylov/psb_dgmresr.f90 @@ -341,7 +341,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index 8d35c80a..590dadb1 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -338,7 +338,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error() return end if diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index dc1c4b95..8fbc4c3e 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -379,7 +379,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,& 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/test/pargen/ppde90.f90 b/test/pargen/ppde90.f90 index 54919c8a..3f3cca33 100644 --- a/test/pargen/ppde90.f90 +++ b/test/pargen/ppde90.f90 @@ -651,7 +651,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act == act_abort) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/util/Makefile b/util/Makefile index 2bf8d520..7991a50b 100644 --- a/util/Makefile +++ b/util/Makefile @@ -19,7 +19,7 @@ lib: $(OBJS) $(AR) $(HERE)/$(LIBNAME) $(OBJS) $(RANLIB) $(HERE)/$(LIBNAME) /bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR) - /bin/cp -p $(LIBMOD) $(LIBDIR) + /bin/cp -p $(LIBMOD) $(LOCAL_MODS) $(LIBDIR) psb_util_mod.o: $(BASEOBJ) diff --git a/util/psb_mat_dist_mod.f90 b/util/psb_mat_dist_mod.f90 index 0186cdc2..ce47c421 100644 --- a/util/psb_mat_dist_mod.f90 +++ b/util/psb_mat_dist_mod.f90 @@ -453,7 +453,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -779,7 +779,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -1200,7 +1200,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if @@ -1526,7 +1526,7 @@ contains 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.act_abort) then + if (err_act.eq.psb_act_abort_) then call psb_error(ictxt) return end if