diff --git a/base/comm/internals/psi_cswapdata_a.F90 b/base/comm/internals/psi_cswapdata_a.F90 index 2a113b17..37d019d6 100644 --- a/base/comm/internals/psi_cswapdata_a.F90 +++ b/base/comm/internals/psi_cswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_cswaptran_a.F90 b/base/comm/internals/psi_cswaptran_a.F90 index ed061be6..f43e3be3 100644 --- a/base/comm/internals/psi_cswaptran_a.F90 +++ b/base/comm/internals/psi_cswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_dswapdata_a.F90 b/base/comm/internals/psi_dswapdata_a.F90 index b9d0aaae..7400548a 100644 --- a/base/comm/internals/psi_dswapdata_a.F90 +++ b/base/comm/internals/psi_dswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_dswaptran_a.F90 b/base/comm/internals/psi_dswaptran_a.F90 index aad6348e..cce55b4d 100644 --- a/base/comm/internals/psi_dswaptran_a.F90 +++ b/base/comm/internals/psi_dswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_eswapdata_a.F90 b/base/comm/internals/psi_eswapdata_a.F90 index f7c67ac3..aa0cda65 100644 --- a/base/comm/internals/psi_eswapdata_a.F90 +++ b/base/comm/internals/psi_eswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_eswaptran_a.F90 b/base/comm/internals/psi_eswaptran_a.F90 index 42954369..0df27a5d 100644 --- a/base/comm/internals/psi_eswaptran_a.F90 +++ b/base/comm/internals/psi_eswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_i2swapdata_a.F90 b/base/comm/internals/psi_i2swapdata_a.F90 index 479042c4..0140504d 100644 --- a/base/comm/internals/psi_i2swapdata_a.F90 +++ b/base/comm/internals/psi_i2swapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_i2swaptran_a.F90 b/base/comm/internals/psi_i2swaptran_a.F90 index f69b8aec..10531927 100644 --- a/base/comm/internals/psi_i2swaptran_a.F90 +++ b/base/comm/internals/psi_i2swaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_mswapdata_a.F90 b/base/comm/internals/psi_mswapdata_a.F90 index b71e61ef..32b8a64e 100644 --- a/base/comm/internals/psi_mswapdata_a.F90 +++ b/base/comm/internals/psi_mswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_mswaptran_a.F90 b/base/comm/internals/psi_mswaptran_a.F90 index add5a608..7b94d480 100644 --- a/base/comm/internals/psi_mswaptran_a.F90 +++ b/base/comm/internals/psi_mswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_sswapdata_a.F90 b/base/comm/internals/psi_sswapdata_a.F90 index de8587c1..5b591bf3 100644 --- a/base/comm/internals/psi_sswapdata_a.F90 +++ b/base/comm/internals/psi_sswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_sswaptran_a.F90 b/base/comm/internals/psi_sswaptran_a.F90 index f0f82965..890a7a58 100644 --- a/base/comm/internals/psi_sswaptran_a.F90 +++ b/base/comm/internals/psi_sswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_zswapdata_a.F90 b/base/comm/internals/psi_zswapdata_a.F90 index 6e821f4f..19026b97 100644 --- a/base/comm/internals/psi_zswapdata_a.F90 +++ b/base/comm/internals/psi_zswapdata_a.F90 @@ -186,9 +186,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & logical, parameter :: usersend=.false. complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -672,9 +670,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & logical, parameter :: usersend=.false. complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/internals/psi_zswaptran_a.F90 b/base/comm/internals/psi_zswaptran_a.F90 index aaf305ac..46e4a898 100644 --- a/base/comm/internals/psi_zswaptran_a.F90 +++ b/base/comm/internals/psi_zswaptran_a.F90 @@ -191,9 +191,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& logical, parameter :: usersend=.false. complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ @@ -685,9 +683,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& logical, parameter :: usersend=.false. complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE volatile :: sndbuf, rcvbuf -#endif character(len=20) :: name info=psb_success_ diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 23ab271f..72bfa774 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_csp_allgather subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lcsp_allgather subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 11eedaf4..a29ac002 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_dsp_allgather subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_ldsp_allgather subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 index 622641cb..ed723289 100644 --- a/base/comm/psb_ispgather.F90 +++ b/base/comm/psb_ispgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_isp_allgather subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k end subroutine psb_@LX@sp_allgather subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 index bfba8a97..5d2d33e9 100644 --- a/base/comm/psb_lspgather.F90 +++ b/base/comm/psb_lspgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_lsp_allgather subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k end subroutine psb_@LX@sp_allgather subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index e25c1145..83db9c08 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_ssp_allgather subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lssp_allgather subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index 62a4c186..98b7d215 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -42,9 +42,7 @@ ! ! subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -136,12 +134,10 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if (nrg > HUGE(1_psb_mpk_)) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) @@ -228,9 +224,7 @@ end subroutine psb_zsp_allgather subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -321,13 +315,11 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else @@ -403,9 +395,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lzsp_allgather subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -#if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env -#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -496,13 +486,11 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#if defined(HAVE_ISO_FORTRAN_ENV) if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then info = psb_err_mpi_int_ovflw_ call psb_errpush(info,name); goto 9999 end if -#endif if ((root_ == -1).or.(root_ == me)) then if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) else diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index e8f169d8..1141d968 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_c_s' @@ -133,7 +133,7 @@ Contains complex(psb_spk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_c_rk1' @@ -205,7 +205,7 @@ Contains complex(psb_spk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_c_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables complex(psb_spk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_c_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables complex(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_c_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables complex(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_c_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='complex(psb_spk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables complex(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_c_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_spk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info complex(psb_spk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_c_rk1' @@ -689,7 +673,7 @@ Contains complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info complex(psb_spk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_c_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_c_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_c_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_c_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_c_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz complex(psb_spk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz complex(psb_spk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index f8326f41..67810e66 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_d_s' @@ -133,7 +133,7 @@ Contains real(psb_dpk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_d_rk1' @@ -205,7 +205,7 @@ Contains real(psb_dpk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_d_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables real(psb_dpk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_d_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables real(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_d_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables real(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_d_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='real(psb_dpk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables real(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_d_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_dpk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info real(psb_dpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_d_rk1' @@ -689,7 +673,7 @@ Contains real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info real(psb_dpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_d_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_d_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_d_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_d_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_d_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz real(psb_dpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz real(psb_dpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 4ad49a2c..763a917c 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_e_s' @@ -133,7 +133,7 @@ Contains integer(psb_epk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_e_rk1' @@ -205,7 +205,7 @@ Contains integer(psb_epk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_e_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables integer(psb_epk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_e_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables integer(psb_epk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_e_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables integer(psb_epk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_e_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='integer(psb_epk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables integer(psb_epk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_e_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_epk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_epk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_e_rk1' @@ -689,7 +673,7 @@ Contains integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_epk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_e_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_e_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_e_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_e_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_e_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz integer(psb_epk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz integer(psb_epk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 6528372f..5c80f396 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_i2_s' @@ -133,7 +133,7 @@ Contains integer(psb_i2pk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_i2_rk1' @@ -205,7 +205,7 @@ Contains integer(psb_i2pk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_i2_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables integer(psb_i2pk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_i2_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables integer(psb_i2pk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_i2_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_i2pk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables integer(psb_i2pk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_i2_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_i2pk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables integer(psb_i2pk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_i2_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_i2pk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_i2pk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_i2pk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_i2_rk1' @@ -689,7 +673,7 @@ Contains integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_i2pk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_i2_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_i2_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_i2_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_i2_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_i2_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz integer(psb_i2pk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz integer(psb_i2pk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index b60e7ae2..ec7e5671 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_s' @@ -133,7 +133,7 @@ Contains integer(psb_mpk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_m_rk1' @@ -205,7 +205,7 @@ Contains integer(psb_mpk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_m_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables integer(psb_mpk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_m_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables integer(psb_mpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_m_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables integer(psb_mpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_m_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='integer(psb_mpk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables integer(psb_mpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_m_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='integer(psb_mpk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_mpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_m_rk1' @@ -689,7 +673,7 @@ Contains integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info integer(psb_mpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_m_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_m_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_m_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_m_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_m_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz integer(psb_mpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz integer(psb_mpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index f7cfdbfe..8751b524 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_s_s' @@ -133,7 +133,7 @@ Contains real(psb_spk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_s_rk1' @@ -205,7 +205,7 @@ Contains real(psb_spk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_s_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables real(psb_spk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_s_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables real(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_s_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables real(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_s_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='real(psb_spk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables real(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_s_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='real(psb_spk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info real(psb_spk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_s_rk1' @@ -689,7 +673,7 @@ Contains real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info real(psb_spk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_s_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_s_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_s_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_s_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_s_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz real(psb_spk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz real(psb_spk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index 230d4f8e..c6bd7218 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -92,7 +92,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_z_s' @@ -133,7 +133,7 @@ Contains complex(psb_dpk_),allocatable :: tmp(:) integer(psb_mpk_) :: dim, lb_, lbi,ub_ integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_z_rk1' @@ -205,7 +205,7 @@ Contains complex(psb_dpk_),allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act,err integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_m_z_rk2' call psb_erractionsave(err_act) @@ -294,9 +294,8 @@ Contains ! ...Local Variables complex(psb_dpk_),allocatable :: tmp(:) integer(psb_epk_) :: dim, lb_, lbi,ub_ - integer(psb_ipk_) :: iplen integer(psb_ipk_) :: err_act,err - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. name='psb_r_m_z_rk1' @@ -311,8 +310,7 @@ Contains endif if ((len<0)) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -325,8 +323,7 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -338,8 +335,7 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -369,9 +365,9 @@ Contains ! ...Local Variables complex(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen + integer(psb_ipk_) :: err_act,err integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 - character(len=20) :: name + character(len=30) :: name name='psb_r_e_z_rk2' call psb_erractionsave(err_act) @@ -391,15 +387,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -415,8 +409,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -430,8 +423,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/(len1*len2)/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -463,10 +455,10 @@ Contains ! ...Local Variables complex(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim2 - character(len=20) :: name + character(len=30) :: name name='psb_r_me_z_rk2' call psb_erractionsave(err_act) @@ -486,15 +478,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len1/), & & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -510,8 +500,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -525,8 +514,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name,i_err=(/iplen/),& + call psb_errpush(err,name,e_err=(/len1*len2/),& & a_err='complex(psb_dpk_)') goto 9999 end if @@ -558,10 +546,10 @@ Contains ! ...Local Variables complex(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: err_act,err, iplen - integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_ipk_) :: err_act,err + integer(psb_epk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 integer(psb_epk_) :: dim - character(len=20) :: name + character(len=30) :: name name='psb_r_me_z_rk2' call psb_erractionsave(err_act) @@ -581,15 +569,13 @@ Contains if (len1 < 0) then err=4025 - iplen = len1 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - iplen = len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, m_err=(/len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -605,8 +591,7 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -620,8 +605,7 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - iplen = len1*len2 - call psb_errpush(err,name, i_err=(/iplen/), & + call psb_errpush(err,name, e_err=(/len1*len2/), & & a_err='complex(psb_dpk_)') goto 9999 end if @@ -648,7 +632,7 @@ Contains complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info complex(psb_dpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_z_rk1' @@ -689,7 +673,7 @@ Contains complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_ipk_) :: info complex(psb_dpk_), optional, intent(in) :: pad - character(len=20) :: name + character(len=30) :: name integer(psb_ipk_) :: err_act, err name='psb_r_m_2_z_rk1' @@ -733,8 +717,8 @@ Contains integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + integer(psb_ipk_) :: err_act + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_z_s' @@ -776,7 +760,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_z_rk1' @@ -820,7 +804,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_z_rk2' @@ -867,7 +851,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_cpy_z_rk1' @@ -908,7 +892,7 @@ Contains ! ...Local Variables integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' @@ -984,7 +968,7 @@ Contains integer(psb_mpk_), optional, intent(in) :: addsz,newsz complex(psb_dpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_mpk_) :: isz @@ -1037,7 +1021,7 @@ Contains integer(psb_epk_), optional, intent(in) :: addsz,newsz complex(psb_dpk_), optional, intent(in) :: pad ! ...Local Variables - character(len=20) :: name + character(len=30) :: name logical, parameter :: debug=.false. integer(psb_ipk_) :: err_act integer(psb_epk_) :: isz diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index 05e42d35..df76dd20 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -387,8 +387,6 @@ contains integer(psb_mpk_), optional :: m_err(:) integer(psb_epk_), optional :: e_err(:) - type(psb_errstack_node), pointer :: new_node - call psb_set_errstatus(psb_err_fatal_) call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) @@ -405,9 +403,6 @@ contains integer(psb_mpk_), optional :: m_err(:) integer(psb_epk_), optional :: e_err(:) - type(psb_errstack_node), pointer :: new_node - - if (.not.psb_errstatus_fatal())& & call psb_set_errstatus( psb_err_warning_) call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index 116b2a8d..f59e238f 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -128,6 +128,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: set_scal => c_base_set_scal procedure, pass(x) :: set_vect => c_base_set_vect generic, public :: set => set_vect, set_scal + procedure, pass(x) :: get_entry=> c_base_get_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -445,7 +446,7 @@ contains class(psb_c_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -811,7 +812,7 @@ contains complex(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -837,7 +838,7 @@ contains complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -855,6 +856,26 @@ contains end subroutine c_base_set_vect + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_c_base_vect_type + !! \brief Get one entry from the vector + !! + ! + function c_base_get_entry(x, index) result(res) + implicit none + class(psb_c_base_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + + res = 0 + if (allocated(x%v)) res = x%v(index) + + end function c_base_get_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index b4dc43ba..144c28ea 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -80,6 +80,8 @@ module psb_c_vect_mod procedure, pass(x) :: set_dev => c_vect_set_dev procedure, pass(x) :: set_sync => c_vect_set_sync + procedure, pass(x) :: get_entry => c_vect_get_entry + procedure, pass(x) :: dot_v => c_vect_dot_v procedure, pass(x) :: dot_a => c_vect_dot_a generic, public :: dot => dot_v, dot_a @@ -186,10 +188,10 @@ contains end function psb_c_get_vect_default - subroutine psb_c_clear_vect_default() - implicit none + subroutine psb_c_clear_vect_default() + implicit none - if (allocated(psb_c_base_vect_default)) then + if (allocated(psb_c_base_vect_default)) then deallocate(psb_c_base_vect_default) end if @@ -603,6 +605,15 @@ contains end function c_vect_is_dev + function c_vect_get_entry(x,index) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_entry(index) + end function c_vect_get_entry + function c_vect_dot_v(n,x,y) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x, y diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 0311e994..daf12cbf 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -128,6 +128,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: set_scal => d_base_set_scal procedure, pass(x) :: set_vect => d_base_set_vect generic, public :: set => set_vect, set_scal + procedure, pass(x) :: get_entry=> d_base_get_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -452,7 +453,7 @@ contains class(psb_d_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -818,7 +819,7 @@ contains real(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -844,7 +845,7 @@ contains real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -862,6 +863,26 @@ contains end subroutine d_base_set_vect + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_d_base_vect_type + !! \brief Get one entry from the vector + !! + ! + function d_base_get_entry(x, index) result(res) + implicit none + class(psb_d_base_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + + res = 0 + if (allocated(x%v)) res = x%v(index) + + end function d_base_get_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 0ce96499..daff8c75 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -80,6 +80,8 @@ module psb_d_vect_mod procedure, pass(x) :: set_dev => d_vect_set_dev procedure, pass(x) :: set_sync => d_vect_set_sync + procedure, pass(x) :: get_entry => d_vect_get_entry + procedure, pass(x) :: dot_v => d_vect_dot_v procedure, pass(x) :: dot_a => d_vect_dot_a generic, public :: dot => dot_v, dot_a @@ -193,10 +195,10 @@ contains end function psb_d_get_vect_default - subroutine psb_d_clear_vect_default() - implicit none + subroutine psb_d_clear_vect_default() + implicit none - if (allocated(psb_d_base_vect_default)) then + if (allocated(psb_d_base_vect_default)) then deallocate(psb_d_base_vect_default) end if @@ -610,6 +612,15 @@ contains end function d_vect_is_dev + function d_vect_get_entry(x,index) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_entry(index) + end function d_vect_get_entry + function d_vect_dot_v(n,x,y) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x, y diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index 851d7896..55d7b47e 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -382,7 +382,7 @@ contains class(psb_i_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -748,7 +748,7 @@ contains integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -774,7 +774,7 @@ contains integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -793,7 +793,6 @@ contains - ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 6fe13325..75064b81 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -135,10 +135,10 @@ contains end function psb_i_get_vect_default - subroutine psb_i_clear_vect_default() - implicit none + subroutine psb_i_clear_vect_default() + implicit none - if (allocated(psb_i_base_vect_default)) then + if (allocated(psb_i_base_vect_default)) then deallocate(psb_i_base_vect_default) end if diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 index 58eda630..53b45f2a 100644 --- a/base/modules/serial/psb_l_base_vect_mod.f90 +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -383,7 +383,7 @@ contains class(psb_l_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -749,7 +749,7 @@ contains integer(psb_lpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -775,7 +775,7 @@ contains integer(psb_lpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -794,7 +794,6 @@ contains - ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index c8fe90e6..3c86f8a2 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -136,10 +136,10 @@ contains end function psb_l_get_vect_default - subroutine psb_l_clear_vect_default() - implicit none + subroutine psb_l_clear_vect_default() + implicit none - if (allocated(psb_l_base_vect_default)) then + if (allocated(psb_l_base_vect_default)) then deallocate(psb_l_base_vect_default) end if diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 01851abf..c185e341 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -128,6 +128,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: set_scal => s_base_set_scal procedure, pass(x) :: set_vect => s_base_set_vect generic, public :: set => set_vect, set_scal + procedure, pass(x) :: get_entry=> s_base_get_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -452,7 +453,7 @@ contains class(psb_s_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -818,7 +819,7 @@ contains real(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -844,7 +845,7 @@ contains real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -862,6 +863,26 @@ contains end subroutine s_base_set_vect + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_s_base_vect_type + !! \brief Get one entry from the vector + !! + ! + function s_base_get_entry(x, index) result(res) + implicit none + class(psb_s_base_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + + res = 0 + if (allocated(x%v)) res = x%v(index) + + end function s_base_get_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 1b9d212d..4c6e3e1c 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -80,6 +80,8 @@ module psb_s_vect_mod procedure, pass(x) :: set_dev => s_vect_set_dev procedure, pass(x) :: set_sync => s_vect_set_sync + procedure, pass(x) :: get_entry => s_vect_get_entry + procedure, pass(x) :: dot_v => s_vect_dot_v procedure, pass(x) :: dot_a => s_vect_dot_a generic, public :: dot => dot_v, dot_a @@ -193,10 +195,10 @@ contains end function psb_s_get_vect_default - subroutine psb_s_clear_vect_default() - implicit none + subroutine psb_s_clear_vect_default() + implicit none - if (allocated(psb_s_base_vect_default)) then + if (allocated(psb_s_base_vect_default)) then deallocate(psb_s_base_vect_default) end if @@ -610,6 +612,15 @@ contains end function s_vect_is_dev + function s_vect_get_entry(x,index) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_entry(index) + end function s_vect_get_entry + function s_vect_dot_v(n,x,y) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x, y diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index f44f31db..1daed233 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -128,6 +128,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: set_scal => z_base_set_scal procedure, pass(x) :: set_vect => z_base_set_vect generic, public :: set => set_vect, set_scal + procedure, pass(x) :: get_entry=> z_base_get_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -445,7 +446,7 @@ contains class(psb_z_base_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i, isz + integer(psb_ipk_) :: isz info = 0 if (psb_errstatus_fatal()) return @@ -811,7 +812,7 @@ contains complex(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_ + integer(psb_ipk_) :: first_, last_ first_=1 last_=size(x%v) @@ -837,7 +838,7 @@ contains complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - integer(psb_ipk_) :: info, first_, last_, nr + integer(psb_ipk_) :: first_, last_ first_ = 1 if (present(first)) first_ = max(1,first) @@ -855,6 +856,26 @@ contains end subroutine z_base_set_vect + ! + ! Get entry. + ! + ! + !> Function base_get_entry + !! \memberof psb_z_base_vect_type + !! \brief Get one entry from the vector + !! + ! + function z_base_get_entry(x, index) result(res) + implicit none + class(psb_z_base_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + + res = 0 + if (allocated(x%v)) res = x%v(index) + + end function z_base_get_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 8ab68a53..52523b61 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -80,6 +80,8 @@ module psb_z_vect_mod procedure, pass(x) :: set_dev => z_vect_set_dev procedure, pass(x) :: set_sync => z_vect_set_sync + procedure, pass(x) :: get_entry => z_vect_get_entry + procedure, pass(x) :: dot_v => z_vect_dot_v procedure, pass(x) :: dot_a => z_vect_dot_a generic, public :: dot => dot_v, dot_a @@ -186,10 +188,10 @@ contains end function psb_z_get_vect_default - subroutine psb_z_clear_vect_default() - implicit none + subroutine psb_z_clear_vect_default() + implicit none - if (allocated(psb_z_base_vect_default)) then + if (allocated(psb_z_base_vect_default)) then deallocate(psb_z_base_vect_default) end if @@ -603,6 +605,15 @@ contains end function z_vect_is_dev + function z_vect_get_entry(x,index) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_entry(index) + end function z_vect_get_entry + function z_vect_dot_v(n,x,y) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x, y diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index fdcc5e56..81e78d3a 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_c_tools_mod use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type @@ -37,6 +37,7 @@ Module psb_c_tools_mod & psb_c_csr_sparse_mat, psb_c_coo_sparse_mat use psb_l_vect_mod, only : psb_l_vect_type use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_calloc_vect(x, desc_a,info) @@ -195,7 +196,7 @@ Module psb_c_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_csphalo Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_c_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lcsphalo Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_c_tools_mod logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc - end Subroutine psb_c_lc_csr_halo + end Subroutine psb_c_lc_csr_halo end interface @@ -296,7 +297,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local end subroutine psb_cspins_csr_lirp -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_c_tools_mod Implicit None type(psb_c_csr_sparse_mat),intent(in) :: acsr type(psb_c_csr_sparse_mat),intent(inout) :: bcsr - type(psb_c_csr_sparse_mat),intent(out) :: ccsr + type(psb_c_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -364,7 +365,7 @@ Module psb_c_tools_mod Implicit None type(psb_lc_csr_sparse_mat),intent(in) :: acsr type(psb_lc_csr_sparse_mat),intent(inout) :: bcsr - type(psb_lc_csr_sparse_mat),intent(out) :: ccsr + type(psb_lc_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -419,6 +420,16 @@ Module psb_c_tools_mod end subroutine psb_c_simple_glob_transpose_ip end interface psb_glob_transpose - - + interface psb_getelem + function psb_c_getelem(x,index,desc_a,info) result(res) + import + type(psb_c_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + end function + end interface + + end module psb_c_tools_mod diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index aa127872..76a5bdf2 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_d_tools_mod use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type @@ -37,6 +37,7 @@ Module psb_d_tools_mod & psb_d_csr_sparse_mat, psb_d_coo_sparse_mat use psb_l_vect_mod, only : psb_l_vect_type use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_dalloc_vect(x, desc_a,info) @@ -195,7 +196,7 @@ Module psb_d_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_dsphalo Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_d_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_ldsphalo Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_d_tools_mod logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc - end Subroutine psb_d_ld_csr_halo + end Subroutine psb_d_ld_csr_halo end interface @@ -296,7 +297,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local end subroutine psb_dspins_csr_lirp -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_d_tools_mod Implicit None type(psb_d_csr_sparse_mat),intent(in) :: acsr type(psb_d_csr_sparse_mat),intent(inout) :: bcsr - type(psb_d_csr_sparse_mat),intent(out) :: ccsr + type(psb_d_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -364,7 +365,7 @@ Module psb_d_tools_mod Implicit None type(psb_ld_csr_sparse_mat),intent(in) :: acsr type(psb_ld_csr_sparse_mat),intent(inout) :: bcsr - type(psb_ld_csr_sparse_mat),intent(out) :: ccsr + type(psb_ld_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -419,6 +420,16 @@ Module psb_d_tools_mod end subroutine psb_d_simple_glob_transpose_ip end interface psb_glob_transpose - - + interface psb_getelem + function psb_d_getelem(x,index,desc_a,info) result(res) + import + type(psb_d_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + end function + end interface + + end module psb_d_tools_mod diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index 1faffd66..def96326 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_i_tools_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type use psb_l_vect_mod, only : psb_l_vect_type use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_ialloc_vect(x, desc_a,info) @@ -169,5 +170,5 @@ Module psb_i_tools_mod end subroutine psb_iins_multivect end interface - + end module psb_i_tools_mod diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 96f44fd7..b389ef85 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_l_tools_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ use psb_l_vect_mod, only : psb_l_base_vect_type, psb_l_vect_type ! use psb_i_vect_mod, only : psb_i_vect_type use psb_l_multivect_mod, only : psb_l_base_multivect_type, psb_l_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_lalloc_vect(x, desc_a,info) @@ -169,5 +170,5 @@ Module psb_l_tools_mod end subroutine psb_lins_multivect end interface - + end module psb_l_tools_mod diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 24453728..2b6058da 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_s_tools_mod use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type @@ -37,6 +37,7 @@ Module psb_s_tools_mod & psb_s_csr_sparse_mat, psb_s_coo_sparse_mat use psb_l_vect_mod, only : psb_l_vect_type use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_salloc_vect(x, desc_a,info) @@ -195,7 +196,7 @@ Module psb_s_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_ssphalo Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_s_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lssphalo Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_s_tools_mod logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc - end Subroutine psb_s_ls_csr_halo + end Subroutine psb_s_ls_csr_halo end interface @@ -296,7 +297,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local end subroutine psb_sspins_csr_lirp -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_s_tools_mod Implicit None type(psb_s_csr_sparse_mat),intent(in) :: acsr type(psb_s_csr_sparse_mat),intent(inout) :: bcsr - type(psb_s_csr_sparse_mat),intent(out) :: ccsr + type(psb_s_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -364,7 +365,7 @@ Module psb_s_tools_mod Implicit None type(psb_ls_csr_sparse_mat),intent(in) :: acsr type(psb_ls_csr_sparse_mat),intent(inout) :: bcsr - type(psb_ls_csr_sparse_mat),intent(out) :: ccsr + type(psb_ls_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -419,6 +420,16 @@ Module psb_s_tools_mod end subroutine psb_s_simple_glob_transpose_ip end interface psb_glob_transpose - - + interface psb_getelem + function psb_s_getelem(x,index,desc_a,info) result(res) + import + type(psb_s_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + end function + end interface + + end module psb_s_tools_mod diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 2b639fdc..09997e94 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! Module psb_z_tools_mod use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type @@ -37,6 +37,7 @@ Module psb_z_tools_mod & psb_z_csr_sparse_mat, psb_z_coo_sparse_mat use psb_l_vect_mod, only : psb_l_vect_type use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type + use psi_mod, only : psb_snd, psb_rcv ! Needed only for psb_getelem interface psb_geall subroutine psb_zalloc_vect(x, desc_a,info) @@ -195,7 +196,7 @@ Module psb_z_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_zsphalo Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -207,7 +208,7 @@ Module psb_z_tools_mod Type(psb_desc_type),Intent(in), target :: desc_a integer(psb_ipk_), intent(out) :: info logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale - character(len=5), optional :: outfmt + character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_lzsphalo Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& @@ -233,7 +234,7 @@ Module psb_z_tools_mod logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale,outcol_glob integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc - end Subroutine psb_z_lz_csr_halo + end Subroutine psb_z_lz_csr_halo end interface @@ -296,7 +297,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local end subroutine psb_zspins_csr_lirp -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) import implicit none @@ -353,7 +354,7 @@ Module psb_z_tools_mod Implicit None type(psb_z_csr_sparse_mat),intent(in) :: acsr type(psb_z_csr_sparse_mat),intent(inout) :: bcsr - type(psb_z_csr_sparse_mat),intent(out) :: ccsr + type(psb_z_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -364,7 +365,7 @@ Module psb_z_tools_mod Implicit None type(psb_lz_csr_sparse_mat),intent(in) :: acsr type(psb_lz_csr_sparse_mat),intent(inout) :: bcsr - type(psb_lz_csr_sparse_mat),intent(out) :: ccsr + type(psb_lz_csr_sparse_mat),intent(out) :: ccsr type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(inout) :: desc_c integer(psb_ipk_), intent(out) :: info @@ -419,6 +420,16 @@ Module psb_z_tools_mod end subroutine psb_z_simple_glob_transpose_ip end interface psb_glob_transpose - - + interface psb_getelem + function psb_z_getelem(x,index,desc_a,info) result(res) + import + type(psb_z_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + end function + end interface + + end module psb_z_tools_mod diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 4769f5ff..bfefebad 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2379,7 +2379,7 @@ subroutine psb_c_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc @@ -4263,7 +4263,7 @@ subroutine psb_lc_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 7b2f61a2..1f4242fd 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -55,8 +55,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc + integer(psb_ipk_) :: m, n logical :: tra, ctra integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) @@ -126,7 +125,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra, ctra - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j,ir complex(psb_spk_) :: acc if (alpha == czero) then @@ -400,7 +399,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: j,m,n, nc complex(psb_spk_), allocatable :: acc(:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -478,7 +477,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra,ctra complex(psb_spk_), intent(inout) :: acc(*) - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j, ir if (alpha == czero) then @@ -749,8 +748,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_spk_) :: acc + integer(psb_ipk_) :: i,k,m complex(psb_spk_), allocatable :: tmp(:) logical :: tra,ctra integer(psb_ipk_) :: err_act @@ -854,7 +852,7 @@ contains complex(psb_spk_), intent(in) :: x(*) complex(psb_spk_), intent(out) :: y(*) - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc complex(psb_spk_) :: acc if ((.not.tra).and.(.not.ctra)) then @@ -1013,8 +1011,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc + integer(psb_ipk_) :: i,k,m, nc complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -1109,7 +1106,7 @@ contains complex(psb_spk_), intent(in) :: val(*), x(ldx,*) complex(psb_spk_), intent(out) :: y(ldy,*) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc complex(psb_spk_), allocatable :: acc(:) info = psb_success_ @@ -1268,7 +1265,7 @@ function psb_c_csr_maxval(a) result(res) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: nnz, nc integer(psb_ipk_) :: info character(len=20) :: name='c_csr_maxval' logical, parameter :: debug=.false. @@ -1290,10 +1287,9 @@ function psb_c_csr_csnmi(a) result(res) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nr, ir, jc, nc + integer(psb_ipk_) :: i,j real(psb_spk_) :: acc logical :: tra - integer(psb_ipk_) :: err_act character(len=20) :: name='c_csnmi' logical, parameter :: debug=.false. @@ -1318,10 +1314,7 @@ subroutine psb_c_csr_rowsum(d,a) class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' @@ -1368,9 +1361,7 @@ subroutine psb_c_csr_arwsum(d,a) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) + integer(psb_ipk_) :: i,j,m logical :: tra integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) @@ -1418,10 +1409,7 @@ subroutine psb_c_csr_colsum(d,a) class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_spk_) :: acc - complex(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' @@ -1471,10 +1459,7 @@ subroutine psb_c_csr_aclsum(d,a) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n, nnz integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' @@ -1581,7 +1566,7 @@ subroutine psb_c_csr_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i, j, m integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ @@ -1652,7 +1637,7 @@ subroutine psb_c_csr_scals(d,a,info) complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1928,7 +1913,7 @@ contains logical, intent(in) :: append integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl,nrd,ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='csr_getptn' @@ -2109,7 +2094,7 @@ contains logical, intent(in) :: append, chksz integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl, nrd, ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='coo_getrow' @@ -2198,7 +2183,6 @@ subroutine psb_c_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2352,7 +2336,6 @@ subroutine psb_c_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2503,7 +2486,7 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='c_csr_csput_a' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i, debug_level, debug_unit call psb_erractionsave(err_act) @@ -2764,7 +2747,7 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) character(len=20) :: name='c_csr_print' logical, parameter :: debug=.false. character(len=80) :: frmt - integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -2832,7 +2815,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) integer(psb_ipk_), allocatable :: itemp(:) !locals logical :: rwshr_ - integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl + integer(psb_ipk_) :: nza, nr, nc, i,k,ip, ncl integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='c_cp_csr_from_coo' @@ -3228,7 +3211,7 @@ subroutine psb_c_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr @@ -5343,7 +5326,7 @@ subroutine psb_lc_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index eb1f2021..eced8477 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2379,7 +2379,7 @@ subroutine psb_d_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc @@ -4263,7 +4263,7 @@ subroutine psb_ld_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 01f36eaa..0c572ac3 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -55,8 +55,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc + integer(psb_ipk_) :: m, n logical :: tra, ctra integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) @@ -126,7 +125,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra, ctra - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j,ir real(psb_dpk_) :: acc if (alpha == dzero) then @@ -400,7 +399,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: j,m,n, nc real(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -478,7 +477,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra,ctra real(psb_dpk_), intent(inout) :: acc(*) - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j, ir if (alpha == dzero) then @@ -749,8 +748,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_dpk_) :: acc + integer(psb_ipk_) :: i,k,m real(psb_dpk_), allocatable :: tmp(:) logical :: tra,ctra integer(psb_ipk_) :: err_act @@ -854,7 +852,7 @@ contains real(psb_dpk_), intent(in) :: x(*) real(psb_dpk_), intent(out) :: y(*) - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc real(psb_dpk_) :: acc if ((.not.tra).and.(.not.ctra)) then @@ -1013,8 +1011,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc + integer(psb_ipk_) :: i,k,m, nc real(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -1109,7 +1106,7 @@ contains real(psb_dpk_), intent(in) :: val(*), x(ldx,*) real(psb_dpk_), intent(out) :: y(ldy,*) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc real(psb_dpk_), allocatable :: acc(:) info = psb_success_ @@ -1268,7 +1265,7 @@ function psb_d_csr_maxval(a) result(res) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: nnz, nc integer(psb_ipk_) :: info character(len=20) :: name='d_csr_maxval' logical, parameter :: debug=.false. @@ -1290,10 +1287,9 @@ function psb_d_csr_csnmi(a) result(res) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nr, ir, jc, nc + integer(psb_ipk_) :: i,j real(psb_dpk_) :: acc logical :: tra - integer(psb_ipk_) :: err_act character(len=20) :: name='d_csnmi' logical, parameter :: debug=.false. @@ -1318,10 +1314,7 @@ subroutine psb_d_csr_rowsum(d,a) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' @@ -1368,9 +1361,7 @@ subroutine psb_d_csr_arwsum(d,a) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) + integer(psb_ipk_) :: i,j,m logical :: tra integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) @@ -1418,10 +1409,7 @@ subroutine psb_d_csr_colsum(d,a) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' @@ -1471,10 +1459,7 @@ subroutine psb_d_csr_aclsum(d,a) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n, nnz integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' @@ -1581,7 +1566,7 @@ subroutine psb_d_csr_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i, j, m integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ @@ -1652,7 +1637,7 @@ subroutine psb_d_csr_scals(d,a,info) real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1928,7 +1913,7 @@ contains logical, intent(in) :: append integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl,nrd,ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='csr_getptn' @@ -2109,7 +2094,7 @@ contains logical, intent(in) :: append, chksz integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl, nrd, ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='coo_getrow' @@ -2198,7 +2183,6 @@ subroutine psb_d_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2352,7 +2336,6 @@ subroutine psb_d_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2503,7 +2486,7 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='d_csr_csput_a' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i, debug_level, debug_unit call psb_erractionsave(err_act) @@ -2764,7 +2747,7 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) character(len=20) :: name='d_csr_print' logical, parameter :: debug=.false. character(len=80) :: frmt - integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -2832,7 +2815,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) integer(psb_ipk_), allocatable :: itemp(:) !locals logical :: rwshr_ - integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl + integer(psb_ipk_) :: nza, nr, nc, i,k,ip, ncl integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='d_cp_csr_from_coo' @@ -3228,7 +3211,7 @@ subroutine psb_d_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr @@ -5343,7 +5326,7 @@ subroutine psb_ld_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index 71e24051..b16cb5bf 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2379,7 +2379,7 @@ subroutine psb_s_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc @@ -4263,7 +4263,7 @@ subroutine psb_ls_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 2fa87adf..a0c56d35 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -55,8 +55,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc + integer(psb_ipk_) :: m, n logical :: tra, ctra integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) @@ -126,7 +125,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra, ctra - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j,ir real(psb_spk_) :: acc if (alpha == szero) then @@ -400,7 +399,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: j,m,n, nc real(psb_spk_), allocatable :: acc(:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -478,7 +477,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra,ctra real(psb_spk_), intent(inout) :: acc(*) - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j, ir if (alpha == szero) then @@ -749,8 +748,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - real(psb_spk_) :: acc + integer(psb_ipk_) :: i,k,m real(psb_spk_), allocatable :: tmp(:) logical :: tra,ctra integer(psb_ipk_) :: err_act @@ -854,7 +852,7 @@ contains real(psb_spk_), intent(in) :: x(*) real(psb_spk_), intent(out) :: y(*) - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc real(psb_spk_) :: acc if ((.not.tra).and.(.not.ctra)) then @@ -1013,8 +1011,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc + integer(psb_ipk_) :: i,k,m, nc real(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -1109,7 +1106,7 @@ contains real(psb_spk_), intent(in) :: val(*), x(ldx,*) real(psb_spk_), intent(out) :: y(ldy,*) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc real(psb_spk_), allocatable :: acc(:) info = psb_success_ @@ -1268,7 +1265,7 @@ function psb_s_csr_maxval(a) result(res) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: nnz, nc integer(psb_ipk_) :: info character(len=20) :: name='s_csr_maxval' logical, parameter :: debug=.false. @@ -1290,10 +1287,9 @@ function psb_s_csr_csnmi(a) result(res) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nr, ir, jc, nc + integer(psb_ipk_) :: i,j real(psb_spk_) :: acc logical :: tra - integer(psb_ipk_) :: err_act character(len=20) :: name='s_csnmi' logical, parameter :: debug=.false. @@ -1318,10 +1314,7 @@ subroutine psb_s_csr_rowsum(d,a) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' @@ -1368,9 +1361,7 @@ subroutine psb_s_csr_arwsum(d,a) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) + integer(psb_ipk_) :: i,j,m logical :: tra integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) @@ -1418,10 +1409,7 @@ subroutine psb_s_csr_colsum(d,a) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' @@ -1471,10 +1459,7 @@ subroutine psb_s_csr_aclsum(d,a) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_spk_) :: acc - real(psb_spk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n, nnz integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' @@ -1581,7 +1566,7 @@ subroutine psb_s_csr_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i, j, m integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ @@ -1652,7 +1637,7 @@ subroutine psb_s_csr_scals(d,a,info) real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1928,7 +1913,7 @@ contains logical, intent(in) :: append integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl,nrd,ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='csr_getptn' @@ -2109,7 +2094,7 @@ contains logical, intent(in) :: append, chksz integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl, nrd, ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='coo_getrow' @@ -2198,7 +2183,6 @@ subroutine psb_s_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2352,7 +2336,6 @@ subroutine psb_s_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2503,7 +2486,7 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='s_csr_csput_a' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i, debug_level, debug_unit call psb_erractionsave(err_act) @@ -2764,7 +2747,7 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) character(len=20) :: name='s_csr_print' logical, parameter :: debug=.false. character(len=80) :: frmt - integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -2832,7 +2815,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) integer(psb_ipk_), allocatable :: itemp(:) !locals logical :: rwshr_ - integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl + integer(psb_ipk_) :: nza, nr, nc, i,k,ip, ncl integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='s_cp_csr_from_coo' @@ -3228,7 +3211,7 @@ subroutine psb_s_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr @@ -5343,7 +5326,7 @@ subroutine psb_ls_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index e1c003d0..457489f3 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2379,7 +2379,7 @@ subroutine psb_z_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc @@ -4263,7 +4263,7 @@ subroutine psb_lz_csc_clean_zeros(a, info) info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp a%icp(1) = 1 j = a%icp(1) do i=1, nc diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index f3b7b45f..498f2b28 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -55,8 +55,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc + integer(psb_ipk_) :: m, n logical :: tra, ctra integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) @@ -126,7 +125,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra, ctra - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j,ir complex(psb_dpk_) :: acc if (alpha == zzero) then @@ -400,7 +399,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: j,m,n, nc complex(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -478,7 +477,7 @@ contains logical, intent(in) :: is_triangle,is_unit,tra,ctra complex(psb_dpk_), intent(inout) :: acc(*) - integer(psb_ipk_) :: i,j,k, ir, jc + integer(psb_ipk_) :: i,j, ir if (alpha == zzero) then @@ -749,8 +748,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc - complex(psb_dpk_) :: acc + integer(psb_ipk_) :: i,k,m complex(psb_dpk_), allocatable :: tmp(:) logical :: tra,ctra integer(psb_ipk_) :: err_act @@ -854,7 +852,7 @@ contains complex(psb_dpk_), intent(in) :: x(*) complex(psb_dpk_), intent(out) :: y(*) - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc complex(psb_dpk_) :: acc if ((.not.tra).and.(.not.ctra)) then @@ -1013,8 +1011,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans character :: trans_ - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc + integer(psb_ipk_) :: i,k,m, nc complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act @@ -1109,7 +1106,7 @@ contains complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) complex(psb_dpk_), intent(out) :: y(ldy,*) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i,j,k,m, ir, jc + integer(psb_ipk_) :: i,j, jc complex(psb_dpk_), allocatable :: acc(:) info = psb_success_ @@ -1268,7 +1265,7 @@ function psb_z_csr_maxval(a) result(res) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: nnz, nc integer(psb_ipk_) :: info character(len=20) :: name='z_csr_maxval' logical, parameter :: debug=.false. @@ -1290,10 +1287,9 @@ function psb_z_csr_csnmi(a) result(res) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nr, ir, jc, nc + integer(psb_ipk_) :: i,j real(psb_dpk_) :: acc logical :: tra - integer(psb_ipk_) :: err_act character(len=20) :: name='z_csnmi' logical, parameter :: debug=.false. @@ -1318,10 +1314,7 @@ subroutine psb_z_csr_rowsum(d,a) class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' @@ -1368,9 +1361,7 @@ subroutine psb_z_csr_arwsum(d,a) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) + integer(psb_ipk_) :: i,j,m logical :: tra integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) @@ -1418,10 +1409,7 @@ subroutine psb_z_csr_colsum(d,a) class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - complex(psb_dpk_) :: acc - complex(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' @@ -1471,10 +1459,7 @@ subroutine psb_z_csr_aclsum(d,a) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc - real(psb_dpk_) :: acc - real(psb_dpk_), allocatable :: vt(:) - logical :: tra + integer(psb_ipk_) :: i,j,k,m,n, nnz integer(psb_ipk_) :: err_act, info integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' @@ -1581,7 +1566,7 @@ subroutine psb_z_csr_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i, j, m integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ @@ -1652,7 +1637,7 @@ subroutine psb_z_csr_scals(d,a,info) complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m + integer(psb_ipk_) :: err_act, i character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1928,7 +1913,7 @@ contains logical, intent(in) :: append integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl,nrd,ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='csr_getptn' @@ -2109,7 +2094,7 @@ contains logical, intent(in) :: append, chksz integer(psb_ipk_) :: info integer(psb_ipk_), optional :: iren(:) - integer(psb_ipk_) :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl,lcl, nrd, ncd + integer(psb_ipk_) :: nzin_, nza,i,j, nzt, irw, lrw, icl,lcl integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='coo_getrow' @@ -2198,7 +2183,6 @@ subroutine psb_z_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2352,7 +2336,6 @@ subroutine psb_z_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -2503,7 +2486,7 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer(psb_ipk_) :: err_act character(len=20) :: name='z_csr_csput_a' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + integer(psb_ipk_) :: nza, i, debug_level, debug_unit call psb_erractionsave(err_act) @@ -2764,7 +2747,7 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) character(len=20) :: name='z_csr_print' logical, parameter :: debug=.false. character(len=80) :: frmt - integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -2832,7 +2815,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) integer(psb_ipk_), allocatable :: itemp(:) !locals logical :: rwshr_ - integer(psb_ipk_) :: nza, nr, nc, i,j,k,ip,irw, err_act, ncl + integer(psb_ipk_) :: nza, nr, nc, i,k,ip, ncl integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name='z_cp_csr_from_coo' @@ -3228,7 +3211,7 @@ subroutine psb_z_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr @@ -5343,7 +5326,7 @@ subroutine psb_lz_csr_clean_zeros(a, info) info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp a%irp(1) = 1 j = a%irp(1) do i=1, nr diff --git a/base/tools/Makefile b/base/tools/Makefile index 6b103d41..c8b488d3 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -26,7 +26,8 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt psb_cspins.o psb_csprn.o psb_cd_set_bld.o \ psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o \ psb_s_par_csr_spspmm.o psb_d_par_csr_spspmm.o psb_c_par_csr_spspmm.o psb_z_par_csr_spspmm.o \ - psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o + psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o \ + psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o # psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \ @@ -37,12 +38,12 @@ INCDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(FIFLAG)$(MODDIR) -lib: mpfobjs $(FOBJS) +lib: mpfobjs $(FOBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(FOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) -mpfobjs: +mpfobjs: (make $(MPFOBJS) FC="$(MPFC)") clean: diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 new file mode 100644 index 00000000..728b4d1e --- /dev/null +++ b/base/tools/psb_cgetelem.f90 @@ -0,0 +1,103 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Function: psb_c_getelem +! Extract entries from a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_c_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_c_getelem(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_c_getelem + use psi_mod + implicit none + + type(psb_c_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localindex(1) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + gindex(1) = index + res = -1.0 + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_c_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + res = x%get_entry(localindex(1)) + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function + diff --git a/base/tools/psb_dgetelem.f90 b/base/tools/psb_dgetelem.f90 new file mode 100644 index 00000000..0611221e --- /dev/null +++ b/base/tools/psb_dgetelem.f90 @@ -0,0 +1,103 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Function: psb_d_getelem +! Extract entries from a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_d_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_d_getelem(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_d_getelem + use psi_mod + implicit none + + type(psb_d_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localindex(1) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + gindex(1) = index + res = -1.0 + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_d_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + res = x%get_entry(localindex(1)) + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function + diff --git a/base/tools/psb_sgetelem.f90 b/base/tools/psb_sgetelem.f90 new file mode 100644 index 00000000..6a8f764e --- /dev/null +++ b/base/tools/psb_sgetelem.f90 @@ -0,0 +1,103 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Function: psb_s_getelem +! Extract entries from a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_s_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_s_getelem(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_s_getelem + use psi_mod + implicit none + + type(psb_s_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localindex(1) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + gindex(1) = index + res = -1.0 + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_s_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + res = x%get_entry(localindex(1)) + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function + diff --git a/base/tools/psb_zgetelem.f90 b/base/tools/psb_zgetelem.f90 new file mode 100644 index 00000000..5e7e975f --- /dev/null +++ b/base/tools/psb_zgetelem.f90 @@ -0,0 +1,103 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Function: psb_z_getelem +! Extract entries from a dense vector. Note: the row indices in index +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process have to be in the halo, +! othewise failure is ensured. +! +! Arguments: +! x - type(psb_z_vect_type) The source vector +! desc_a - type(psb_desc_type). The communication descriptor. +! index - integer. Row index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_z_getelem(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_z_getelem + use psi_mod + implicit none + + type(psb_z_vect_type), intent(inout) :: x + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localindex(1) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_lpk_) :: gindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + character(len=20) :: name + logical, parameter :: debug = .false. + + gindex(1) = index + res = -1.0 + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_z_getelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.false.) + if(debug.and.(localindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global index is ",gindex,"Local index is ",localindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + res = x%get_entry(localindex(1)) + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function + diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index b00058ec..0b7d09e2 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -90,7 +90,6 @@ extern "C" { psb_i_t psb_c_cd_get_local_rows(psb_c_descriptor *cd); psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd); psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); - psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); psb_i_t psb_c_cd_get_global_indices(psb_l_t idx[], psb_i_t nidx, bool owned, psb_c_descriptor *cd); /* legal values for upd argument */ diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index c2cd173c..55c437a4 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -30,6 +30,7 @@ psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh); +psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd); /* sparse matrices*/ psb_c_cspmat* psb_c_new_cspmat(); diff --git a/cbind/base/psb_c_dbase.c b/cbind/base/psb_c_dbase.c index 8eefca21..6b619194 100644 --- a/cbind/base/psb_c_dbase.c +++ b/cbind/base/psb_c_dbase.c @@ -4,27 +4,26 @@ psb_c_dvector* psb_c_new_dvector() { psb_c_dvector* temp; - + temp=(psb_c_dvector *) malloc(sizeof(psb_c_dvector)); temp->dvector=NULL; return(temp); } psb_d_t* psb_c_dvect_get_cpy(psb_c_dvector *xh) -{ +{ psb_d_t *temp=NULL; - psb_i_t vsize=0; - - if ((vsize=psb_c_dvect_get_nrows(xh))<0) + psb_i_t vsize=0; + + if ((vsize=psb_c_dvect_get_nrows(xh))<0) return(temp); - - if (vsize==0) + + if (vsize==0) vsize=1; - + if ((temp=(psb_d_t *)malloc(vsize*sizeof(psb_d_t)))!=NULL) psb_c_dvect_f_get_cpy(temp,xh); - fprintf(stderr,"dvect_get_cpy: %lf\n",temp[0]); return(temp); } @@ -33,7 +32,7 @@ psb_d_t* psb_c_dvect_get_cpy(psb_c_dvector *xh) psb_c_dspmat* psb_c_new_dspmat() { psb_c_dspmat* temp; - + temp=(psb_c_dspmat *) malloc(sizeof(psb_c_dspmat)); temp->dspmat=NULL; return(temp); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index d1bd39af..40d59a58 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -30,6 +30,7 @@ psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); +psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd); /* sparse matrices*/ psb_c_dspmat* psb_c_new_dspmat(); diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index c259767f..73e3aa2d 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -30,6 +30,7 @@ psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh); +psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd); /* sparse matrices*/ psb_c_sspmat* psb_c_new_sspmat(); diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 43014ac8..a935b6c2 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_cgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_cgeall function psb_c_cgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_cgeasb - + function psb_c_cgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_cgefree - + function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_float_complex) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_cgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_float_complex) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_cspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_cspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_cspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_c_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_cspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) complex(c_float_complex) :: val(*) type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_csprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_cspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -398,6 +398,39 @@ contains !!$ return !!$ end function psb_c_cspprint + function psb_c_cgetelem(xh,index,cdh) bind(c) result(res) + implicit none -end module psb_c_tools_cbind_mod + type(psb_c_cvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_float_complex) :: res + + type(psb_c_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(xp,index,descp,info) + else + res = psb_getelem(xp,index+(1-ixb),descp,info) + end if + return + + end function psb_c_cgetelem + +end module psb_c_tools_cbind_mod diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 48250c55..ee74a651 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -30,6 +30,7 @@ psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh); +psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd); /* sparse matrices*/ psb_c_zspmat* psb_c_new_zspmat(); diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index 31f87433..40a9d2f6 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_dgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_dgeall function psb_c_dgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_dgeasb - + function psb_c_dgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_dgefree - + function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_double) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_dgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_double) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_dspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_dspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_dspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_d_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) real(c_double) :: val(*) type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_dspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -398,6 +398,39 @@ contains !!$ return !!$ end function psb_c_dspprint + function psb_c_dgetelem(xh,index,cdh) bind(c) result(res) + implicit none -end module psb_d_tools_cbind_mod + type(psb_c_dvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_double) :: res + + type(psb_d_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(xp,index,descp,info) + else + res = psb_getelem(xp,index+(1-ixb),descp,info) + end if + return + + end function psb_c_dgetelem + +end module psb_d_tools_cbind_mod diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index fad6cdc4..bae645be 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_sgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_sgeall function psb_c_sgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_sgeasb - + function psb_c_sgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_sgefree - + function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_float) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_sgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) real(c_float) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_sspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_sspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_sspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_s_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_sspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) real(c_float) :: val(*) type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_ssprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_sspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -398,6 +398,39 @@ contains !!$ return !!$ end function psb_c_sspprint + function psb_c_sgetelem(xh,index,cdh) bind(c) result(res) + implicit none -end module psb_s_tools_cbind_mod + type(psb_c_svector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_float) :: res + + type(psb_s_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(xp,index,descp,info) + else + res = psb_getelem(xp,index+(1-ixb),descp,info) + end if + return + + end function psb_c_sgetelem + +end module psb_s_tools_cbind_mod diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index 99125022..19802f62 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -10,8 +10,8 @@ contains function psb_c_zgeall(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -21,26 +21,26 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then - return + if (c_associated(xh%item)) then + return end if allocate(xp) call psb_geall(xp,descp,info) xh%item = c_loc(xp) res = min(0,info) - + return end function psb_c_zgeall function psb_c_zgeasb(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -50,27 +50,27 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_geasb(xp,descp,info) res = min(0,info) - + return end function psb_c_zgeasb - + function psb_c_zgefree(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -80,29 +80,29 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if call psb_gefree(xp,descp,info) res = min(0,info) xh%item = c_null_ptr - + return end function psb_c_zgefree - + function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_double_complex) :: val(*) @@ -114,19 +114,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_ovwrt_) else @@ -142,8 +142,8 @@ contains function psb_c_zgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz integer(psb_c_lpk_) :: irw(*) complex(c_double_complex) :: val(*) @@ -155,19 +155,19 @@ contains integer(psb_c_ipk_) :: ixb, info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_geins(nz,irw(1:nz),val(1:nz),& & xp,descp,info, dupl=psb_dupl_add_) else @@ -182,8 +182,8 @@ contains function psb_c_zspall(mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -192,13 +192,13 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then - return + if (c_associated(mh%item)) then + return end if allocate(ap) call psb_spall(ap,descp,info) @@ -211,9 +211,9 @@ contains function psb_c_zspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -222,15 +222,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spasb(ap,descp,info) @@ -240,9 +240,9 @@ contains function psb_c_zspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res + + implicit none + integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -251,15 +251,15 @@ contains integer(psb_c_ipk_) :: info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call psb_spfree(ap,descp,info) @@ -276,8 +276,8 @@ contains #ifdef HAVE_LIBRSB use psb_z_rsb_mat_mod #endif - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) integer(psb_c_ipk_) :: info,n, fdupl @@ -288,10 +288,10 @@ contains res = -1 call psb_check_descriptor_handle(cdh,info) - if (info < 0) return + if (info < 0) return call psb_check_double_spmat_handle(mh,info) - if (info < 0) return - + if (info < 0) return + call stringc2f(afmt,fafmt) select case(fafmt) #ifdef HAVE_LIBRSB @@ -303,7 +303,7 @@ contains call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& & afmt=fafmt,upd=upd,dupl=dupl) end select - + res = min(0,info) return @@ -312,10 +312,10 @@ contains function psb_c_zspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) + integer(psb_c_lpk_) :: irw(*), icl(*) complex(c_double_complex) :: val(*) type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -325,19 +325,19 @@ contains integer(psb_c_ipk_) :: ixb,info,n res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if ixb = psb_c_get_index_base() - if (ixb == 1) then + if (ixb == 1) then call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) else call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) @@ -349,8 +349,8 @@ contains function psb_c_zsprn(mh,cdh,clear) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res logical(c_bool), value :: clear type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh @@ -358,18 +358,18 @@ contains type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap integer(psb_c_ipk_) :: info - logical :: fclear + logical :: fclear res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if fclear = clear @@ -381,15 +381,15 @@ contains !!$ !!$ function psb_c_zspprint(mh) bind(c) result(res) !!$ -!!$ implicit none -!!$ integer(psb_c_ipk_) :: res +!!$ implicit none +!!$ integer(psb_c_ipk_) :: res !!$ integer(psb_c_ipk_), value :: mh !!$ integer(psb_c_ipk_) :: info !!$ !!$ !!$ res = -1 !!$ call psb_check_double_spmat_handle(mh,info) -!!$ if (info < 0) return +!!$ if (info < 0) return !!$ !!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') !!$ @@ -398,6 +398,39 @@ contains !!$ return !!$ end function psb_c_zspprint + function psb_c_zgetelem(xh,index,cdh) bind(c) result(res) + implicit none -end module psb_z_tools_cbind_mod + type(psb_c_zvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_double_complex) :: res + + type(psb_z_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(xp,index,descp,info) + else + res = psb_getelem(xp,index+(1-ixb),descp,info) + end if + return + + end function psb_c_zgetelem + +end module psb_z_tools_cbind_mod diff --git a/cbind/krylov/psb_ckrylov_cbind_mod.f90 b/cbind/krylov/psb_ckrylov_cbind_mod.f90 index fb423e3a..56cd51ab 100644 --- a/cbind/krylov/psb_ckrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_ckrylov_cbind_mod.f90 @@ -48,7 +48,6 @@ contains integer(psb_c_ipk_) :: iter real(c_double) :: err character(c_char) :: methd(*) - type(solveroptions) :: options type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap type(psb_cprec_type), pointer :: precp diff --git a/cbind/krylov/psb_dkrylov_cbind_mod.f90 b/cbind/krylov/psb_dkrylov_cbind_mod.f90 index 7bfe011c..43b3ca8c 100644 --- a/cbind/krylov/psb_dkrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_dkrylov_cbind_mod.f90 @@ -48,7 +48,6 @@ contains integer(psb_c_ipk_) :: iter real(c_double) :: err character(c_char) :: methd(*) - type(solveroptions) :: options type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap type(psb_dprec_type), pointer :: precp diff --git a/cbind/krylov/psb_skrylov_cbind_mod.f90 b/cbind/krylov/psb_skrylov_cbind_mod.f90 index 7460d825..60d41d14 100644 --- a/cbind/krylov/psb_skrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_skrylov_cbind_mod.f90 @@ -48,7 +48,6 @@ contains integer(psb_c_ipk_) :: iter real(c_double) :: err character(c_char) :: methd(*) - type(solveroptions) :: options type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap type(psb_sprec_type), pointer :: precp diff --git a/cbind/krylov/psb_zkrylov_cbind_mod.f90 b/cbind/krylov/psb_zkrylov_cbind_mod.f90 index 585731e8..22e74386 100644 --- a/cbind/krylov/psb_zkrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_zkrylov_cbind_mod.f90 @@ -48,7 +48,6 @@ contains integer(psb_c_ipk_) :: iter real(c_double) :: err character(c_char) :: methd(*) - type(solveroptions) :: options type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap type(psb_zprec_type), pointer :: precp diff --git a/config/pac.m4 b/config/pac.m4 index c9f55d94..0fa7324e 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -1865,7 +1865,7 @@ if test "x$pac_metis_header_ok" == "xyes" ; then AC_LANG_POP() fi -if test "x$pac_metis_header_ok" == "xyes" ; then +if test "x$pac_metis_header_ok" = "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $LIBS"; @@ -1874,7 +1874,7 @@ if test "x$pac_metis_header_ok" == "xyes" ; then [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) - if test "x$pac_metis_lib_ok" == "xno" ; then + if test "x$pac_metis_lib_ok" = "xno" ; then dnl Maybe Lib or lib? METIS_LIBDIR="-L$psblas_cv_metisdir/Lib -L$psblas_cv_metisdir/lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" @@ -1886,24 +1886,29 @@ if test "x$pac_metis_header_ok" == "xyes" ; then [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) fi - if test "x$pac_metis_lib_ok" == "xno" ; then + + if test "x$pac_metis_lib_ok" = "xno" ; then dnl Maybe METIS/Lib? METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" AC_MSG_CHECKING([for METIS_PartGraphKway in $METIS_LIBS]) AC_TRY_LINK_FUNC(METIS_PartGraphKway, - [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], - [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) + [psblas_cv_have_metis=yes;pac_metis_lib_ok="yes"; ], + [psblas_cv_have_metis=no;pac_metis_lib_ok="no"; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) - fi -fi -if test "x$pac_metis_lib_ok" == "xyes" ; then + fi + fi +dnl AC_MSG_NOTICE([ metis lib ok $pac_metis_lib_ok]) + + if test "x$pac_metis_lib_ok" = "xyes" ; then AC_MSG_CHECKING([for METIS_SetDefaultOptions in $LIBS]) AC_TRY_LINK_FUNC(METIS_SetDefaultOptions, - [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], - [psblas_cv_have_metis=no;pac_metis_lib_ok="no. Unusable METIS version, sorry."; METIS_LIBS=""]) + [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], + [psblas_cv_have_metis=no;pac_metis_lib_ok="no. Unusable METIS version, sorry."; METIS_LIBS="" + ]) AC_MSG_RESULT($pac_metis_lib_ok) + fi LIBS="$SAVE_LIBS"; diff --git a/configure b/configure index ccefc2c0..bacb6175 100755 --- a/configure +++ b/configure @@ -6873,10 +6873,10 @@ fi # Defaults for IPK/LPK if test x"$pac_cv_ipk_size" == x"" ; then - pac_cv_ipk_size=4; + pac_cv_ipk_size=4 fi if test x"$pac_cv_lpk_size" == x"" ; then - pac_cv_lpk_size=8; + pac_cv_lpk_size=8 fi # Enforce sensible combination if (( $pac_cv_lpk_size < $pac_cv_ipk_size )); then @@ -9017,7 +9017,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu fi -if test "x$pac_metis_header_ok" == "xyes" ; then +if test "x$pac_metis_header_ok" = "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $LIBS"; @@ -9050,7 +9050,7 @@ rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } - if test "x$pac_metis_lib_ok" == "xno" ; then + if test "x$pac_metis_lib_ok" = "xno" ; then METIS_LIBDIR="-L$psblas_cv_metisdir/Lib -L$psblas_cv_metisdir/lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" @@ -9085,7 +9085,8 @@ rm -f core conftest.err conftest.$ac_objext \ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } fi - if test "x$pac_metis_lib_ok" == "xno" ; then + + if test "x$pac_metis_lib_ok" = "xno" ; then METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" @@ -9110,17 +9111,18 @@ return METIS_PartGraphKway (); } _ACEOF if ac_fn_c_try_link "$LINENO"; then : - psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; + psblas_cv_have_metis=yes;pac_metis_lib_ok="yes"; else - psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" + psblas_cv_have_metis=no;pac_metis_lib_ok="no"; METIS_LIBS="" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } - fi -fi -if test "x$pac_metis_lib_ok" == "xyes" ; then + fi + fi + + if test "x$pac_metis_lib_ok" = "xyes" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for METIS_SetDefaultOptions in $LIBS" >&5 $as_echo_n "checking for METIS_SetDefaultOptions in $LIBS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -9145,19 +9147,40 @@ if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; else psblas_cv_have_metis=no;pac_metis_lib_ok="no. Unusable METIS version, sorry."; METIS_LIBS="" + fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } + fi LIBS="$SAVE_LIBS"; CPPFLAGS="$SAVE_CPPFLAGS"; + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking Compatibility between metis and LPK" >&5 +$as_echo_n "checking Compatibility between metis and LPK... " >&6; } +if test "x$pac_cv_lpk_size" == "x4" ; then + if test "x$pac_cv_metis_idx" == "x64" ; then + psblas_cv_have_metis="no"; + fi + fi + if test "x$pac_cv_lpk_size" == "x8" ; then + if test "x$pac_cv_metis_idx" == "x32" ; then + psblas_cv_have_metis="no"; + fi + fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $psblas_cv_have_metis" >&5 +$as_echo "$psblas_cv_have_metis" >&6; } + if test "x$pac_cv_metis_idx" == "xunknown" ; then - true ; # do nothing -elif test "x$psblas_cv_have_metis" == "xyes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: Unknown METIS bitsize." >&5 +$as_echo "$as_me: Unknown METIS bitsize." >&6;} + $psblas_cv_have_metis = "no"; +fi +if test "x$psblas_cv_have_metis" == "xyes" ; then FDEFINES="$psblas_cv_define_prepend-DHAVE_METIS $psblas_cv_define_prepend-DMETIS_$pac_cv_metis_idx $FDEFINES" CDEFINES="-DHAVE_METIS_ $psblas_cv_metis_includes $CDEFINES -DMETIS_$pac_cv_metis_idx" METISINCFILE=$psblas_cv_metisincfile @@ -10782,7 +10805,8 @@ fi BLAS : ${BLAS_LIBS} - METIS detected : ${psblas_cv_have_metis} + METIS usable : ${psblas_cv_have_metis} + METIS bitsize : ${pac_cv_metis_idx} AMD detected : ${psblas_cv_have_amd} LIBS : ${LIBS} LDLIBS : ${LDLIBS} @@ -10810,7 +10834,8 @@ $as_echo "$as_me: BLAS : ${BLAS_LIBS} - METIS detected : ${psblas_cv_have_metis} + METIS usable : ${psblas_cv_have_metis} + METIS bitsize : ${pac_cv_metis_idx} AMD detected : ${psblas_cv_have_amd} LIBS : ${LIBS} LDLIBS : ${LDLIBS} diff --git a/configure.ac b/configure.ac index 9edcb290..8bfd5806 100755 --- a/configure.ac +++ b/configure.ac @@ -483,10 +483,10 @@ PAC_ARG_WITH_IPK PAC_ARG_WITH_LPK # Defaults for IPK/LPK if test x"$pac_cv_ipk_size" == x"" ; then - pac_cv_ipk_size=4; + pac_cv_ipk_size=4 fi if test x"$pac_cv_lpk_size" == x"" ; then - pac_cv_lpk_size=8; + pac_cv_lpk_size=8 fi # Enforce sensible combination if (( $pac_cv_lpk_size < $pac_cv_ipk_size )); then @@ -694,9 +694,29 @@ LIBS="$RSB_LIBS ${LIBS}" dnl AC_CHECK_HEADERS([rsb.h], [ LIBS="${LIBS} $want_rsb_libs"], []) PAC_CHECK_METIS + +AC_MSG_CHECKING([Compatibility between metis and LPK]) +if test "x$pac_cv_lpk_size" == "x4" ; then + if test "x$pac_cv_metis_idx" == "x64" ; then + dnl mismatch between metis size and PSBLAS LPK + psblas_cv_have_metis="no"; + dnl + fi + fi + if test "x$pac_cv_lpk_size" == "x8" ; then + if test "x$pac_cv_metis_idx" == "x32" ; then + dnl mismatch between metis size and PSBLAS LPK + psblas_cv_have_metis="no"; + fi + fi +AC_MSG_RESULT([$psblas_cv_have_metis]) + if test "x$pac_cv_metis_idx" == "xunknown" ; then - true ; # do nothing -elif test "x$psblas_cv_have_metis" == "xyes" ; then + dnl mismatch between metis size and PSBLAS LPK + AC_MSG_NOTICE([Unknown METIS bitsize.]) + $psblas_cv_have_metis = "no"; +fi +if test "x$psblas_cv_have_metis" == "xyes" ; then FDEFINES="$psblas_cv_define_prepend-DHAVE_METIS $psblas_cv_define_prepend-DMETIS_$pac_cv_metis_idx $FDEFINES" CDEFINES="-DHAVE_METIS_ $psblas_cv_metis_includes $CDEFINES -DMETIS_$pac_cv_metis_idx" METISINCFILE=$psblas_cv_metisincfile @@ -814,7 +834,8 @@ AC_MSG_NOTICE([ BLAS : ${BLAS_LIBS} - METIS detected : ${psblas_cv_have_metis} + METIS usable : ${psblas_cv_have_metis} + METIS bitsize : ${pac_cv_metis_idx} AMD detected : ${psblas_cv_have_amd} LIBS : ${LIBS} dnl Note : we should use LDLIBS sooner or later! diff --git a/prec/Makefile b/prec/Makefile index 5b9551f2..e3b727b7 100644 --- a/prec/Makefile +++ b/prec/Makefile @@ -9,10 +9,10 @@ MODOBJS=psb_prec_const_mod.o\ psb_s_base_prec_mod.o psb_d_base_prec_mod.o psb_c_base_prec_mod.o psb_z_base_prec_mod.o \ psb_prec_type.o \ psb_prec_mod.o psb_s_prec_mod.o psb_d_prec_mod.o psb_c_prec_mod.o psb_z_prec_mod.o \ - psb_d_diagprec.o psb_d_nullprec.o psb_d_bjacprec.o \ - psb_s_diagprec.o psb_s_nullprec.o psb_s_bjacprec.o \ - psb_c_diagprec.o psb_c_nullprec.o psb_c_bjacprec.o \ - psb_z_diagprec.o psb_z_nullprec.o psb_z_bjacprec.o + psb_d_diagprec.o psb_d_nullprec.o psb_d_bjacprec.o psb_s_ilu_fact_mod.o \ + psb_s_diagprec.o psb_s_nullprec.o psb_s_bjacprec.o psb_d_ilu_fact_mod.o \ + psb_c_diagprec.o psb_c_nullprec.o psb_c_bjacprec.o psb_c_ilu_fact_mod.o \ + psb_z_diagprec.o psb_z_nullprec.o psb_z_bjacprec.o psb_z_ilu_fact_mod.o LIBNAME=$(PRECLIBNAME) @@ -32,7 +32,8 @@ impld: $(OBJS) $(OBJS): $(MODDIR)/$(BASEMODNAME)$(.mod) -psb_s_base_prec_mod.o psb_d_base_prec_mod.o psb_c_base_prec_mod.o psb_z_base_prec_mod.o: psb_prec_const_mod.o +psb_s_base_prec_mod.o psb_d_base_prec_mod.o psb_c_base_prec_mod.o psb_z_base_prec_mod.o \ +psb_s_ilu_fact_mod.o psb_d_ilu_fact_mod.o psb_c_ilu_fact_mod.o psb_z_ilu_fact_mod.o : psb_prec_const_mod.o psb_s_prec_type.o: psb_s_base_prec_mod.o psb_d_prec_type.o: psb_d_base_prec_mod.o psb_c_prec_type.o: psb_c_base_prec_mod.o @@ -46,7 +47,11 @@ psb_prec_mod.o: psb_s_prec_mod.o psb_d_prec_mod.o psb_c_prec_mod.o psb_z_prec_mo psb_s_bjacprec.o psb_s_diagprec.o psb_s_nullprec.o: psb_prec_mod.o psb_s_base_prec_mod.o psb_d_bjacprec.o psb_d_diagprec.o psb_d_nullprec.o: psb_prec_mod.o psb_d_base_prec_mod.o psb_c_bjacprec.o psb_c_diagprec.o psb_c_nullprec.o: psb_prec_mod.o psb_c_base_prec_mod.o -psb_z_bjacprec.o psb_z_diagprec.o psb_z_nullprec.o: psb_prec_mod.o psb_z_base_prec_mod.o +psb_z_bjacprec.o psb_z_diagprec.o psb_z_nullprec.o: psb_prec_mod.o psb_z_base_prec_mod.o +psb_s_bjacprec.o: psb_s_ilu_fact_mod.o +psb_d_bjacprec.o: psb_d_ilu_fact_mod.o +psb_c_bjacprec.o: psb_c_ilu_fact_mod.o +psb_z_bjacprec.o: psb_z_ilu_fact_mod.o veryclean: clean /bin/rm -f $(LIBNAME) *$(.mod) diff --git a/prec/impl/Makefile b/prec/impl/Makefile index 07562777..80e87a54 100644 --- a/prec/impl/Makefile +++ b/prec/impl/Makefile @@ -7,16 +7,16 @@ HERE=.. OBJS=psb_s_prec_type_impl.o psb_d_prec_type_impl.o \ psb_c_prec_type_impl.o psb_z_prec_type_impl.o \ psb_d_diagprec_impl.o psb_d_bjacprec_impl.o psb_d_nullprec_impl.o \ - psb_dilu_fct.o\ + psb_dilu_fct.o psb_d_ilu0_fact.o psb_d_iluk_fact.o psb_d_ilut_fact.o \ psb_dprecbld.o psb_dprecset.o psb_dprecinit.o \ psb_s_diagprec_impl.o psb_s_bjacprec_impl.o psb_s_nullprec_impl.o \ - psb_silu_fct.o\ + psb_silu_fct.o psb_s_ilu0_fact.o psb_s_iluk_fact.o psb_s_ilut_fact.o \ psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ psb_c_diagprec_impl.o psb_c_bjacprec_impl.o psb_c_nullprec_impl.o \ - psb_cilu_fct.o\ + psb_cilu_fct.o psb_c_ilu0_fact.o psb_c_iluk_fact.o psb_c_ilut_fact.o \ psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ psb_z_diagprec_impl.o psb_z_bjacprec_impl.o psb_z_nullprec_impl.o \ - psb_zilu_fct.o\ + psb_zilu_fct.o psb_z_ilu0_fact.o psb_z_iluk_fact.o psb_z_ilut_fact.o \ psb_zprecbld.o psb_zprecset.o psb_zprecinit.o LIBNAME=$(PRECLIBNAME) diff --git a/prec/impl/psb_c_ilu0_fact.f90 b/prec/impl/psb_c_ilu0_fact.f90 new file mode 100644 index 00000000..c4097dea --- /dev/null +++ b/prec/impl/psb_c_ilu0_fact.f90 @@ -0,0 +1,698 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cilu0_fact.f90 +! +! Subroutine: psb_cilu0_fact +! Version: complex +! Contains: psb_cilu0_factint, ilu_copyin +! +! This routine computes either the ILU(0) or the MILU(0) factorization of +! the diagonal blocks of a distributed matrix. These factorizations are used +! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a given level of a +! multilevel preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated +! to the ILU(0)/MILU(0) factorization). +! +! The routine copies and factors "on the fly" from a and blck into l (L factor), +! u (U factor, except its diagonal) and d (diagonal of U). +! +! This implementation of ILU(0)/MILU(0) is faster than the implementation in +! psb_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). +! +! +! Arguments: +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The MILU(0) factorization is computed if ialg = 2 (= psb_milu_n_); +! the ILU(0) factorization otherwise. +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_as_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck is empty. +! +subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) + + use psb_base_mod + use psb_c_ilu_fact_mod, psb_protect_name => psb_cilu0_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + complex(psb_spk_), intent(inout) :: d(:) + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd + + ! Local variables + integer(psb_ipk_) :: l1, l2, m, err_act + type(psb_cspmat_type), pointer :: blck_ + type(psb_c_csr_sparse_mat) :: ll, uu + character :: upd_ + character(len=20) :: name, ch_err + + name='psb_cilu0_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_ = 'F' + end if + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call psb_cilu0_factint(ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_cilu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_cilu0_factint + ! Version: complex + ! Note: internal subroutine of psb_cilu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= psb_ilu_n_), + ! the MILU(0) one if ialg = 2 (= psb_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! lval - complex(psb_spk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in lval. + ! l2 - integer, output. + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_cilu0_factint(ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_cspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) + character, intent(in) :: upd + + ! Local variables + integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m + integer(psb_ipk_) :: ma,mb + complex(psb_spk_) :: dia,temp + integer(psb_ipk_), parameter :: nrb=16 + type(psb_c_coo_sparse_mat) :: trw + integer(psb_ipk_) :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_cilu0_factint' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + ma = a%get_nrows() + mb = b%get_nrows() + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/ione,ialg,izero,izero,izero/)) + goto 9999 + end select + + call trw%allocate(izero,izero,ione) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + m = ma+mb + + if (psb_toupper(upd) == 'F' ) then + lirp(1) = 1 + uirp(1) = 1 + l1 = 0 + l2 = 0 + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = czero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into lval/d(i)/uval + ! + call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into lval/d(i)/uval + ! + call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + endif + + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + dia = d(i) + do kk = lirp(i), lirp(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = lval(kk) + k = lja(kk) + lval(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uirp(i) + ! + updateloop: do jj = uirp(k), uirp(k+1) - 1 + ! + j = uja(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lirp(i+1) - 1 + l = lja(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + lval(ll) = lval(ll) - temp*uval(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uval(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uirp(i+1) - 1 + l = uja(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uval(ll) = uval(ll) - temp*uval(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == psb_milu_n_) then + dia = dia - temp*uval(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = cone/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uirp(i), uirp(i+1) - 1 + uval(kk) = uval(kk)*dia + enddo + enddo + else + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call trw%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cilu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: complex + ! Note: internal subroutine of psb_cilu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_cspmat_type + ! data structure a, into the arrays lval and uval and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in lval and uval are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lja and uja. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into lval, dia, uval row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by psb_cilu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of lval. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in lval row by row (see psb_cilu0_factint), according + ! to the CSR storage format. + ! lval - complex(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - complex(psb_spk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uval. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uval row by row (see psb_cilu0_factint), according + ! to the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_cspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& + & dia,l2,uja,uval,ktrw,trw,upd) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 + integer(psb_ipk_), intent(inout) :: lja(:), uja(:) + complex(psb_spk_), intent(inout) :: lval(:), uval(:), dia + character, intent(in) :: upd + ! Local variables + integer(psb_ipk_) :: k,j,info,irb, nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + if (psb_toupper(upd) == 'F') then + + select type(aa => a%a) + type is (psb_c_csr_sparse_mat) + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = aa%val(j) + lja(l1) = k + else if (k == jd) then + dia = aa%val(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = aa%val(j) + uja(l2) = k + end if + enddo + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into lval, dia, uval, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csget' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = trw%val(ktrw) + lja(l1) = k + else if (k == jd) then + dia = trw%val(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = trw%val(ktrw) + uja(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end select + + else + + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine ilu_copyin + +end subroutine psb_cilu0_fact diff --git a/prec/impl/psb_c_iluk_fact.f90 b/prec/impl/psb_c_iluk_fact.f90 new file mode 100644 index 00000000..8748816d --- /dev/null +++ b/prec/impl/psb_c_iluk_fact.f90 @@ -0,0 +1,1001 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ciluk_fact.f90 +! +! Subroutine: psb_ciluk_fact +! Version: complex +! Contains: psb_ciluk_factint, iluk_copyin, iluk_fact, iluk_copyout. +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to +! build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a +! multilevel preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= psb_ilu_n_); +! the MILU(k) one if ialg = 2 (= psb_milu_n_); other values are +! not allowed. +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use psb_c_ilu_fact_mod, psb_protect_name => psb_ciluk_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + type(psb_cspmat_type),intent(in), optional, target :: blck + complex(psb_spk_), intent(inout) :: d(:) + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act + + type(psb_cspmat_type), pointer :: blck_ + type(psb_c_csr_sparse_mat) :: ll, uu + character(len=20) :: name, ch_err + + name='psb_ciluk_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call psb_ciluk_factint(fill_in,ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ciluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_ciluk_factint + ! Version: complex + ! Note: internal subroutine of psb_ciluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= psb_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - complex(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_ciluk_factint(fill_in,ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + type(psb_cspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) + complex(psb_spk_), intent(inout) :: d(:) + + ! Local variables + integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_c_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_ciluk_factint' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/itwo,ialg,izero,izero,izero/)) + goto 9999 + end select + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = czero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uja,uirp,uval,uplevs,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_ciluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: complex + ! Note: internal subroutine of psb_ciluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see psb_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by psb_ciluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see psb_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in iluk_fact. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_cspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act,nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + call heap%init(info) + + select type (aa=> a%a) + type is (psb_c_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + ktrw = ktrw + 1 + enddo + end select + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: complex + ! Note: internal subroutine of psb_ciluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine psb_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by psb_ciluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - complex(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! iluk_copyout, called by psb_ciluk_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see iluk_copyout, called by psb_ciluk_factint), according to + ! the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) + complex(psb_spk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + complex(psb_spk_) :: rwk + + info = psb_success_ + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= psb_success_) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= czero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) + if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uja(l2) = j + uval(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == psb_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = czero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! lval and uval + ! + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uirp(i), uirp(i+1)-1 + uval(j) = d(i)*uval(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyout + + +end subroutine psb_ciluk_fact diff --git a/prec/impl/psb_c_ilut_fact.f90 b/prec/impl/psb_c_ilut_fact.f90 new file mode 100644 index 00000000..06b8b477 --- /dev/null +++ b/prec/impl/psb_c_ilut_fact.f90 @@ -0,0 +1,1218 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cilut_fact.f90 +! +! Subroutine: psb_cilut_fact +! Version: complex +! Contains: psb_cilut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks +! of a distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is +! CSR. The diagonal of the U factor is stored separately (actually, the +! inverse of the diagonal entries is stored; this is then managed in the +! solve stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - real, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_cspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_cspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_cspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + + use psb_base_mod + use psb_c_ilu_fact_mod, psb_protect_name => psb_cilut_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type),intent(in) :: a + type(psb_cspmat_type),intent(inout) :: l,u + complex(psb_spk_), intent(inout) :: d(:) + type(psb_cspmat_type),intent(in), optional, target :: blck + integer(psb_ipk_), intent(in), optional :: iscale + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + + type(psb_cspmat_type), pointer :: blck_ + type(psb_c_csr_sparse_mat) :: ll, uu + real(psb_spk_) :: scale + character(len=20) :: name, ch_err + + name='psb_cilut_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(iscale)) then + iscale_ = iscale + else + iscale_ = psb_ilu_scale_none_ + end if + + select case(iscale_) + case(psb_ilu_scale_none_) + scale = sone + case(psb_ilu_scale_maxval_) + scale = max(a%maxval(),blck_%maxval()) + scale = sone/scale + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) + goto 9999 + end select + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k,t) factorization + ! + call psb_cilut_factint(fill_in,thres,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cilut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +contains + + ! + ! Subroutine: psb_cilut_factint + ! Version: complex + ! Note: internal subroutine of psb_cilut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! lval - complex(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in lval. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_cilut_factint(fill_in,thres,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + type(psb_cspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) + complex(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in), optional :: scale + + ! Local Variables + integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m + real(psb_spk_) :: nrmi + real(psb_spk_) :: weight + integer(psb_ipk_), allocatable :: idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_c_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_cilut_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = czero + weight = sone + if (present(scale)) weight = abs(scale) + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uja,uirp,uval,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& + & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + ! + ! Adjust diagonal accounting for scale factor + ! + if (weight /= sone) then + d(1:m) = d(1:m)*weight + end if + + ! + ! And we're sone, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_cilut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: complex + ! Note: internal subroutine of psb_cilut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see psb_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by psb_cilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_cspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_spk_), output. + ! The 2-norm of the current row. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see psb_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_cspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& + & nrmi,weight,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_cspmat_type), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_spk_), intent(inout) :: nrmi + complex(psb_spk_), intent(inout) :: row(:) + real(psb_spk_), intent(in) :: weight + type(psb_i_heap), intent(inout) :: heap + + integer(psb_ipk_) :: k,j,irb,kin,nz + integer(psb_ipk_), parameter :: nrb=40 + real(psb_spk_) :: dmaxup + real(psb_spk_), external :: dnrm2 + character(len=20), parameter :: name='psb_cilut_factint' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + select type (aa=> a%a) + type is (psb_c_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + nz = aa%irp(i+1) - aa%irp(i) + nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) + + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = weight*dnrm2(nz,trw%val(kin),ione) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: complex + ! Note: internal subroutine of psb_cilut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine psb_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by psb_cilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_spk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - complex(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - complex(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! ilut_copyout, called by psb_cilut_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see ilut_copyout, called by psb_cilut_factint), according to + ! the CSR storage format. + ! uval - complex(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) + complex(psb_spk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + complex(psb_spk_) :: rwk + + info = psb_success_ + call psb_ensure_size(200*ione,idxs,info) + if (info /= psb_success_) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(lval) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lja(l1) = xwid(k) + lval(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call heap%init(info,dir=psb_asort_down_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i psb_dilu0_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_dspmat_type),intent(in) :: a + type(psb_dspmat_type),intent(inout) :: l,u + real(psb_dpk_), intent(inout) :: d(:) + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd + + ! Local variables + integer(psb_ipk_) :: l1, l2, m, err_act + type(psb_dspmat_type), pointer :: blck_ + type(psb_d_csr_sparse_mat) :: ll, uu + character :: upd_ + character(len=20) :: name, ch_err + + name='psb_dilu0_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_ = 'F' + end if + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call psb_dilu0_factint(ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_dilu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_dilu0_factint + ! Version: real + ! Note: internal subroutine of psb_dilu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= psb_ilu_n_), + ! the MILU(0) one if ialg = 2 (= psb_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! lval - real(psb_dpk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in lval. + ! l2 - integer, output. + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_dilu0_factint(ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_dspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) + character, intent(in) :: upd + + ! Local variables + integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m + integer(psb_ipk_) :: ma,mb + real(psb_dpk_) :: dia,temp + integer(psb_ipk_), parameter :: nrb=16 + type(psb_d_coo_sparse_mat) :: trw + integer(psb_ipk_) :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_dilu0_factint' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + ma = a%get_nrows() + mb = b%get_nrows() + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/ione,ialg,izero,izero,izero/)) + goto 9999 + end select + + call trw%allocate(izero,izero,ione) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + m = ma+mb + + if (psb_toupper(upd) == 'F' ) then + lirp(1) = 1 + uirp(1) = 1 + l1 = 0 + l2 = 0 + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = dzero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into lval/d(i)/uval + ! + call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into lval/d(i)/uval + ! + call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + endif + + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + dia = d(i) + do kk = lirp(i), lirp(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = lval(kk) + k = lja(kk) + lval(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uirp(i) + ! + updateloop: do jj = uirp(k), uirp(k+1) - 1 + ! + j = uja(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lirp(i+1) - 1 + l = lja(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + lval(ll) = lval(ll) - temp*uval(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uval(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uirp(i+1) - 1 + l = uja(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uval(ll) = uval(ll) - temp*uval(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == psb_milu_n_) then + dia = dia - temp*uval(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = done/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uirp(i), uirp(i+1) - 1 + uval(kk) = uval(kk)*dia + enddo + enddo + else + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call trw%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_dilu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: real + ! Note: internal subroutine of psb_dilu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type + ! data structure a, into the arrays lval and uval and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in lval and uval are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lja and uja. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into lval, dia, uval row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by psb_dilu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of lval. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in lval row by row (see psb_dilu0_factint), according + ! to the CSR storage format. + ! lval - real(psb_dpk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - real(psb_dpk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uval. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uval row by row (see psb_dilu0_factint), according + ! to the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_dspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& + & dia,l2,uja,uval,ktrw,trw,upd) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 + integer(psb_ipk_), intent(inout) :: lja(:), uja(:) + real(psb_dpk_), intent(inout) :: lval(:), uval(:), dia + character, intent(in) :: upd + ! Local variables + integer(psb_ipk_) :: k,j,info,irb, nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + if (psb_toupper(upd) == 'F') then + + select type(aa => a%a) + type is (psb_d_csr_sparse_mat) + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = aa%val(j) + lja(l1) = k + else if (k == jd) then + dia = aa%val(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = aa%val(j) + uja(l2) = k + end if + enddo + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into lval, dia, uval, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csget' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = trw%val(ktrw) + lja(l1) = k + else if (k == jd) then + dia = trw%val(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = trw%val(ktrw) + uja(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end select + + else + + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine ilu_copyin + +end subroutine psb_dilu0_fact diff --git a/prec/impl/psb_d_iluk_fact.f90 b/prec/impl/psb_d_iluk_fact.f90 new file mode 100644 index 00000000..6d644e42 --- /dev/null +++ b/prec/impl/psb_d_iluk_fact.f90 @@ -0,0 +1,1001 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_diluk_fact.f90 +! +! Subroutine: psb_diluk_fact +! Version: real +! Contains: psb_diluk_factint, iluk_copyin, iluk_fact, iluk_copyout. +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to +! build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a +! multilevel preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= psb_ilu_n_); +! the MILU(k) one if ialg = 2 (= psb_milu_n_); other values are +! not allowed. +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_dspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_dspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_dpk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_dspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use psb_d_ilu_fact_mod, psb_protect_name => psb_diluk_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type),intent(in) :: a + type(psb_dspmat_type),intent(inout) :: l,u + type(psb_dspmat_type),intent(in), optional, target :: blck + real(psb_dpk_), intent(inout) :: d(:) + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act + + type(psb_dspmat_type), pointer :: blck_ + type(psb_d_csr_sparse_mat) :: ll, uu + character(len=20) :: name, ch_err + + name='psb_diluk_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call psb_diluk_factint(fill_in,ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_diluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_diluk_factint + ! Version: real + ! Note: internal subroutine of psb_diluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= psb_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - real(psb_dpk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_diluk_factint(fill_in,ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + type(psb_dspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) + real(psb_dpk_), intent(inout) :: d(:) + + ! Local variables + integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + real(psb_dpk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_d_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_diluk_factint' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/itwo,ialg,izero,izero,izero/)) + goto 9999 + end select + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = dzero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = dzero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uja,uirp,uval,uplevs,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_diluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: real + ! Note: internal subroutine of psb_diluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see psb_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by psb_diluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - real(psb_dpk_), dimension(:), input/output. + ! In input it is the null vector (see psb_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in iluk_fact. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_dspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act,nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + call heap%init(info) + + select type (aa=> a%a) + type is (psb_d_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + ktrw = ktrw + 1 + enddo + end select + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: real + ! Note: internal subroutine of psb_diluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine psb_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by psb_diluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - real(psb_dpk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - real(psb_dpk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! iluk_copyout, called by psb_diluk_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see iluk_copyout, called by psb_diluk_factint), according to + ! the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) + real(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_dpk_) :: rwk + + info = psb_success_ + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= psb_success_) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= dzero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) + if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uja(l2) = j + uval(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == psb_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = dzero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! lval and uval + ! + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = done/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uirp(i), uirp(i+1)-1 + uval(j) = d(i)*uval(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyout + + +end subroutine psb_diluk_fact diff --git a/prec/impl/psb_d_ilut_fact.f90 b/prec/impl/psb_d_ilut_fact.f90 new file mode 100644 index 00000000..bcd26396 --- /dev/null +++ b/prec/impl/psb_d_ilut_fact.f90 @@ -0,0 +1,1218 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dilut_fact.f90 +! +! Subroutine: psb_dilut_fact +! Version: real +! Contains: psb_dilut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks +! of a distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is +! CSR. The diagonal of the U factor is stored separately (actually, the +! inverse of the diagonal entries is stored; this is then managed in the +! solve stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - real, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_dspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_dspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_dpk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_dspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + + use psb_base_mod + use psb_d_ilu_fact_mod, psb_protect_name => psb_dilut_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_dpk_), intent(in) :: thres + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type),intent(in) :: a + type(psb_dspmat_type),intent(inout) :: l,u + real(psb_dpk_), intent(inout) :: d(:) + type(psb_dspmat_type),intent(in), optional, target :: blck + integer(psb_ipk_), intent(in), optional :: iscale + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + + type(psb_dspmat_type), pointer :: blck_ + type(psb_d_csr_sparse_mat) :: ll, uu + real(psb_dpk_) :: scale + character(len=20) :: name, ch_err + + name='psb_dilut_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(iscale)) then + iscale_ = iscale + else + iscale_ = psb_ilu_scale_none_ + end if + + select case(iscale_) + case(psb_ilu_scale_none_) + scale = sone + case(psb_ilu_scale_maxval_) + scale = max(a%maxval(),blck_%maxval()) + scale = sone/scale + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) + goto 9999 + end select + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k,t) factorization + ! + call psb_dilut_factint(fill_in,thres,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_dilut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +contains + + ! + ! Subroutine: psb_dilut_factint + ! Version: real + ! Note: internal subroutine of psb_dilut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! lval - real(psb_dpk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in lval. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_dilut_factint(fill_in,thres,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_dpk_), intent(in) :: thres + type(psb_dspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) + real(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in), optional :: scale + + ! Local Variables + integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m + real(psb_dpk_) :: nrmi + real(psb_dpk_) :: weight + integer(psb_ipk_), allocatable :: idxs(:) + real(psb_dpk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_d_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_dilut_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = czero + weight = sone + if (present(scale)) weight = abs(scale) + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uja,uirp,uval,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& + & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + ! + ! Adjust diagonal accounting for scale factor + ! + if (weight /= sone) then + d(1:m) = d(1:m)*weight + end if + + ! + ! And we're sone, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_dilut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: real + ! Note: internal subroutine of psb_dilut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see psb_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by psb_dilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_dspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_dpk_), output. + ! The 2-norm of the current row. + ! row - real(psb_dpk_), dimension(:), input/output. + ! In input it is the null vector (see psb_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_dspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& + & nrmi,weight,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_dspmat_type), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_dpk_), intent(inout) :: nrmi + real(psb_dpk_), intent(inout) :: row(:) + real(psb_dpk_), intent(in) :: weight + type(psb_i_heap), intent(inout) :: heap + + integer(psb_ipk_) :: k,j,irb,kin,nz + integer(psb_ipk_), parameter :: nrb=40 + real(psb_dpk_) :: dmaxup + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='psb_dilut_factint' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + select type (aa=> a%a) + type is (psb_d_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + nz = aa%irp(i+1) - aa%irp(i) + nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) + + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = weight*dnrm2(nz,trw%val(kin),ione) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: real + ! Note: internal subroutine of psb_dilut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine psb_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by psb_dilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_dpk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - real(psb_dpk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - real(psb_dpk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! ilut_copyout, called by psb_dilut_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see ilut_copyout, called by psb_dilut_factint), according to + ! the CSR storage format. + ! uval - real(psb_dpk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) + real(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_dpk_) :: rwk + + info = psb_success_ + call psb_ensure_size(200*ione,idxs,info) + if (info /= psb_success_) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(lval) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lja(l1) = xwid(k) + lval(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call heap%init(info,dir=psb_asort_down_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i psb_silu0_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + real(psb_spk_), intent(inout) :: d(:) + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd + + ! Local variables + integer(psb_ipk_) :: l1, l2, m, err_act + type(psb_sspmat_type), pointer :: blck_ + type(psb_s_csr_sparse_mat) :: ll, uu + character :: upd_ + character(len=20) :: name, ch_err + + name='psb_silu0_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_ = 'F' + end if + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call psb_silu0_factint(ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_silu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_silu0_factint + ! Version: real + ! Note: internal subroutine of psb_silu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= psb_ilu_n_), + ! the MILU(0) one if ialg = 2 (= psb_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! lval - real(psb_spk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in lval. + ! l2 - integer, output. + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_silu0_factint(ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_sspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) + character, intent(in) :: upd + + ! Local variables + integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m + integer(psb_ipk_) :: ma,mb + real(psb_spk_) :: dia,temp + integer(psb_ipk_), parameter :: nrb=16 + type(psb_s_coo_sparse_mat) :: trw + integer(psb_ipk_) :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_silu0_factint' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + ma = a%get_nrows() + mb = b%get_nrows() + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/ione,ialg,izero,izero,izero/)) + goto 9999 + end select + + call trw%allocate(izero,izero,ione) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + m = ma+mb + + if (psb_toupper(upd) == 'F' ) then + lirp(1) = 1 + uirp(1) = 1 + l1 = 0 + l2 = 0 + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = szero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into lval/d(i)/uval + ! + call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into lval/d(i)/uval + ! + call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + endif + + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + dia = d(i) + do kk = lirp(i), lirp(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = lval(kk) + k = lja(kk) + lval(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uirp(i) + ! + updateloop: do jj = uirp(k), uirp(k+1) - 1 + ! + j = uja(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lirp(i+1) - 1 + l = lja(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + lval(ll) = lval(ll) - temp*uval(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uval(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uirp(i+1) - 1 + l = uja(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uval(ll) = uval(ll) - temp*uval(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == psb_milu_n_) then + dia = dia - temp*uval(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = sone/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uirp(i), uirp(i+1) - 1 + uval(kk) = uval(kk)*dia + enddo + enddo + else + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call trw%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_silu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: real + ! Note: internal subroutine of psb_silu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type + ! data structure a, into the arrays lval and uval and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in lval and uval are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lja and uja. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into lval, dia, uval row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by psb_silu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of lval. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in lval row by row (see psb_silu0_factint), according + ! to the CSR storage format. + ! lval - real(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - real(psb_spk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uval. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uval row by row (see psb_silu0_factint), according + ! to the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& + & dia,l2,uja,uval,ktrw,trw,upd) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 + integer(psb_ipk_), intent(inout) :: lja(:), uja(:) + real(psb_spk_), intent(inout) :: lval(:), uval(:), dia + character, intent(in) :: upd + ! Local variables + integer(psb_ipk_) :: k,j,info,irb, nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + if (psb_toupper(upd) == 'F') then + + select type(aa => a%a) + type is (psb_s_csr_sparse_mat) + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = aa%val(j) + lja(l1) = k + else if (k == jd) then + dia = aa%val(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = aa%val(j) + uja(l2) = k + end if + enddo + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into lval, dia, uval, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csget' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = trw%val(ktrw) + lja(l1) = k + else if (k == jd) then + dia = trw%val(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = trw%val(ktrw) + uja(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end select + + else + + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine ilu_copyin + +end subroutine psb_silu0_fact diff --git a/prec/impl/psb_s_iluk_fact.f90 b/prec/impl/psb_s_iluk_fact.f90 new file mode 100644 index 00000000..4b9f1f3f --- /dev/null +++ b/prec/impl/psb_s_iluk_fact.f90 @@ -0,0 +1,1001 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_siluk_fact.f90 +! +! Subroutine: psb_siluk_fact +! Version: real +! Contains: psb_siluk_factint, iluk_copyin, iluk_fact, iluk_copyout. +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to +! build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a +! multilevel preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= psb_ilu_n_); +! the MILU(k) one if ialg = 2 (= psb_milu_n_); other values are +! not allowed. +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_sspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_sspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use psb_s_ilu_fact_mod, psb_protect_name => psb_siluk_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act + + type(psb_sspmat_type), pointer :: blck_ + type(psb_s_csr_sparse_mat) :: ll, uu + character(len=20) :: name, ch_err + + name='psb_siluk_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call psb_siluk_factint(fill_in,ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_siluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_siluk_factint + ! Version: real + ! Note: internal subroutine of psb_siluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= psb_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - real(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_siluk_factint(fill_in,ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + type(psb_sspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) + real(psb_spk_), intent(inout) :: d(:) + + ! Local variables + integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_s_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_siluk_factint' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/itwo,ialg,izero,izero,izero/)) + goto 9999 + end select + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = szero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = szero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uja,uirp,uval,uplevs,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_siluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: real + ! Note: internal subroutine of psb_siluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see psb_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by psb_siluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see psb_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in iluk_fact. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act,nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + call heap%init(info) + + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + ktrw = ktrw + 1 + enddo + end select + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: real + ! Note: internal subroutine of psb_siluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine psb_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by psb_siluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - real(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! iluk_copyout, called by psb_siluk_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see iluk_copyout, called by psb_siluk_factint), according to + ! the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) + real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_spk_) :: rwk + + info = psb_success_ + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= psb_success_) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= szero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) + if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uja(l2) = j + uval(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == psb_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = szero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! lval and uval + ! + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = sone/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uirp(i), uirp(i+1)-1 + uval(j) = d(i)*uval(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyout + + +end subroutine psb_siluk_fact diff --git a/prec/impl/psb_s_ilut_fact.f90 b/prec/impl/psb_s_ilut_fact.f90 new file mode 100644 index 00000000..33b4374c --- /dev/null +++ b/prec/impl/psb_s_ilut_fact.f90 @@ -0,0 +1,1218 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_silut_fact.f90 +! +! Subroutine: psb_silut_fact +! Version: real +! Contains: psb_silut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks +! of a distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is +! CSR. The diagonal of the U factor is stored separately (actually, the +! inverse of the diagonal entries is stored; this is then managed in the +! solve stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - real, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_sspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_sspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - real(psb_spk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_sspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + + use psb_base_mod + use psb_s_ilu_fact_mod, psb_protect_name => psb_silut_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + real(psb_spk_), intent(inout) :: d(:) + type(psb_sspmat_type),intent(in), optional, target :: blck + integer(psb_ipk_), intent(in), optional :: iscale + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + + type(psb_sspmat_type), pointer :: blck_ + type(psb_s_csr_sparse_mat) :: ll, uu + real(psb_spk_) :: scale + character(len=20) :: name, ch_err + + name='psb_silut_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(iscale)) then + iscale_ = iscale + else + iscale_ = psb_ilu_scale_none_ + end if + + select case(iscale_) + case(psb_ilu_scale_none_) + scale = sone + case(psb_ilu_scale_maxval_) + scale = max(a%maxval(),blck_%maxval()) + scale = sone/scale + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) + goto 9999 + end select + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k,t) factorization + ! + call psb_silut_factint(fill_in,thres,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_silut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +contains + + ! + ! Subroutine: psb_silut_factint + ! Version: real + ! Note: internal subroutine of psb_silut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - real(psb_spk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! lval - real(psb_spk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in lval. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_silut_factint(fill_in,thres,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + type(psb_sspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) + real(psb_spk_), intent(inout) :: d(:) + real(psb_spk_), intent(in), optional :: scale + + ! Local Variables + integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m + real(psb_spk_) :: nrmi + real(psb_spk_) :: weight + integer(psb_ipk_), allocatable :: idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_s_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_silut_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = czero + weight = sone + if (present(scale)) weight = abs(scale) + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uja,uirp,uval,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& + & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + ! + ! Adjust diagonal accounting for scale factor + ! + if (weight /= sone) then + d(1:m) = d(1:m)*weight + end if + + ! + ! And we're sone, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_silut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: real + ! Note: internal subroutine of psb_silut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see psb_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by psb_silut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_sspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_spk_), output. + ! The 2-norm of the current row. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it is the null vector (see psb_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_sspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& + & nrmi,weight,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_spk_), intent(inout) :: nrmi + real(psb_spk_), intent(inout) :: row(:) + real(psb_spk_), intent(in) :: weight + type(psb_i_heap), intent(inout) :: heap + + integer(psb_ipk_) :: k,j,irb,kin,nz + integer(psb_ipk_), parameter :: nrb=40 + real(psb_spk_) :: dmaxup + real(psb_spk_), external :: dnrm2 + character(len=20), parameter :: name='psb_silut_factint' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + nz = aa%irp(i+1) - aa%irp(i) + nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) + + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = weight*dnrm2(nz,trw%val(kin),ione) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: real + ! Note: internal subroutine of psb_silut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine psb_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by psb_silut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_spk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - real(psb_spk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - real(psb_spk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! ilut_copyout, called by psb_silut_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see ilut_copyout, called by psb_silut_factint), according to + ! the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) + real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_spk_) :: rwk + + info = psb_success_ + call psb_ensure_size(200*ione,idxs,info) + if (info /= psb_success_) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(lval) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lja(l1) = xwid(k) + lval(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < s_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call heap%init(info,dir=psb_asort_down_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i psb_zilu0_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_zspmat_type),intent(in) :: a + type(psb_zspmat_type),intent(inout) :: l,u + complex(psb_dpk_), intent(inout) :: d(:) + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd + + ! Local variables + integer(psb_ipk_) :: l1, l2, m, err_act + type(psb_zspmat_type), pointer :: blck_ + type(psb_z_csr_sparse_mat) :: ll, uu + character :: upd_ + character(len=20) :: name, ch_err + + name='psb_zilu0_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_ = 'F' + end if + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! + ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg + ! + call psb_zilu0_factint(ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_zilu0_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + deallocate(blck_) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_zilu0_factint + ! Version: complex + ! Note: internal subroutine of psb_zilu0_fact. + ! + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' + ! (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a given level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(0)/MILU(0) factorization). + ! + ! The routine copies and factors "on the fly" from the sparse matrix structures a + ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). + ! + ! + ! Arguments: + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The ILU(0) factorization is computed if ialg = 1 (= psb_ilu_n_), + ! the MILU(0) one if ialg = 2 (= psb_milu_n_); other values + ! are not allowed. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! ma - integer, input + ! The number of rows of the local submatrix stored into a. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! mb - integer, input. + ! The number of rows of the local submatrix stored into b. + ! b - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been + ! reordered (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the + ! incomplete factorization. + ! lval - complex(psb_dpk_), dimension(:), input/output. + ! The entries of U are stored according to the CSR format. + ! The L factor in the incomplete factorization. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output. + ! The number of nonzero entries in lval. + ! l2 - integer, output. + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_zilu0_factint(ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: ialg + type(psb_zspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_dpk_), intent(inout) :: lval(:),uval(:),d(:) + character, intent(in) :: upd + + ! Local variables + integer(psb_ipk_) :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m + integer(psb_ipk_) :: ma,mb + complex(psb_dpk_) :: dia,temp + integer(psb_ipk_), parameter :: nrb=16 + type(psb_z_coo_sparse_mat) :: trw + integer(psb_ipk_) :: int_err(5) + character(len=20) :: name, ch_err + + name='psb_zilu0_factint' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + ma = a%get_nrows() + mb = b%get_nrows() + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/ione,ialg,izero,izero,izero/)) + goto 9999 + end select + + call trw%allocate(izero,izero,ione) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + m = ma+mb + + if (psb_toupper(upd) == 'F' ) then + lirp(1) = 1 + uirp(1) = 1 + l1 = 0 + l2 = 0 + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + d(i) = zzero + + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into lval/d(i)/uval + ! + call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into lval/d(i)/uval + ! + call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + endif + + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + dia = d(i) + do kk = lirp(i), lirp(i+1) - 1 + ! + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization + ! + temp = lval(kk) + k = lja(kk) + lval(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uirp(i) + ! + updateloop: do jj = uirp(k), uirp(k+1) - 1 + ! + j = uja(jj) + ! + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lirp(i+1) - 1 + l = lja(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + lval(ll) = lval(ll) - temp*uval(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uval(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uirp(i+1) - 1 + l = uja(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uval(ll) = uval(ll) - temp*uval(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if + ! + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). + ! + if (ialg == psb_milu_n_) then + dia = dia - temp*uval(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + dia = zone/dia + end if + d(i) = dia + ! + ! Scale row i of upper triangle + ! + do kk = uirp(i), uirp(i+1) - 1 + uval(kk) = uval(kk)*dia + enddo + enddo + else + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call trw%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_zilu0_factint + + ! + ! Subroutine: ilu_copyin + ! Version: complex + ! Note: internal subroutine of psb_zilu0_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the psb_zspmat_type + ! data structure a, into the arrays lval and uval and into the scalar variable + ! dia, corresponding to the lower and upper triangles of A and to the diagonal + ! entry of the row, respectively. The entries in lval and uval are stored + ! according to the CSR format; the corresponding column indices are stored in + ! the arrays lja and uja. + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied into lval, dia, uval row by row, through successive calls to + ! ilu_copyin. + ! + ! The routine is used by psb_zilu0_factint in the computation of the ILU(0)/MILU(0) + ! factorization of a local sparse matrix. + ! + ! TODO: modify the routine to allow copying into output L and U that are + ! already filled with indices; this would allow computing an ILU(k) pattern, + ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! Minimum valid column index. + ! jmax - integer, input. + ! Maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! l1 - integer, input/output. + ! Pointer to the last occupied entry of lval. + ! lja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the lower triangle + ! copied in lval row by row (see psb_zilu0_factint), according + ! to the CSR storage format. + ! lval - complex(psb_dpk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! lower triangle are copied. + ! dia - complex(psb_dpk_), output. + ! The diagonal entry of the copied row. + ! l2 - integer, input/output. + ! Pointer to the last occupied entry of uval. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the upper triangle + ! copied in uval row by row (see psb_zilu0_factint), according + ! to the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input/output. + ! The array where the entries of the row corresponding to the + ! upper triangle are copied. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_zspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& + & dia,l2,uja,uval,ktrw,trw,upd) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jd,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,l1,l2 + integer(psb_ipk_), intent(inout) :: lja(:), uja(:) + complex(psb_dpk_), intent(inout) :: lval(:), uval(:), dia + character, intent(in) :: upd + ! Local variables + integer(psb_ipk_) :: k,j,info,irb, nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='ilu_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + if (psb_toupper(upd) == 'F') then + + select type(aa => a%a) + type is (psb_z_csr_sparse_mat) + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = aa%val(j) + lja(l1) = k + else if (k == jd) then + dia = aa%val(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = aa%val(j) + uja(l2) = k + end if + enddo + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into lval, dia, uval, through + ! successive calls to ilu_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csget' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = trw%val(ktrw) + lja(l1) = k + else if (k == jd) then + dia = trw%val(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = trw%val(ktrw) + uja(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end select + + else + + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,& + & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) + goto 9999 + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine ilu_copyin + +end subroutine psb_zilu0_fact diff --git a/prec/impl/psb_z_iluk_fact.f90 b/prec/impl/psb_z_iluk_fact.f90 new file mode 100644 index 00000000..fe9e92d9 --- /dev/null +++ b/prec/impl/psb_z_iluk_fact.f90 @@ -0,0 +1,1001 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ziluk_fact.f90 +! +! Subroutine: psb_ziluk_fact +! Version: complex +! Contains: psb_ziluk_factint, iluk_copyin, iluk_fact, iluk_copyout. +! +! This routine computes either the ILU(k) or the MILU(k) factorization of the +! diagonal blocks of a distributed matrix. These factorizations are used to +! build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! Additive Schwarz preconditioner) corresponding to a certain level of a +! multilevel preconditioner. +! +! Details on the above factorizations can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in +! the description of the arguments below. The storage format for both the L and +! U factors is CSR. The diagonal of the U factor is stored separately (actually, +! the inverse of the diagonal entries is stored; this is then managed in the solve +! stage associated to the ILU(k)/MILU(k) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in level k in ILU(k)/MILU(k). +! ialg - integer, input. +! The type of incomplete factorization to be performed. +! The ILU(k) factorization is computed if ialg = 1 (= psb_ilu_n_); +! the MILU(k) one if ialg = 2 (= psb_milu_n_); other values are +! not allowed. +! a - type(psb_zspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_zspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_zspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_dpk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_zspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) + + use psb_base_mod + use psb_z_ilu_fact_mod, psb_protect_name => psb_ziluk_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type),intent(in) :: a + type(psb_zspmat_type),intent(inout) :: l,u + type(psb_zspmat_type),intent(in), optional, target :: blck + complex(psb_dpk_), intent(inout) :: d(:) + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act + + type(psb_zspmat_type), pointer :: blck_ + type(psb_z_csr_sparse_mat) :: ll, uu + character(len=20) :: name, ch_err + + name='psb_ziluk_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg + ! + call psb_ziluk_factint(fill_in,ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ziluk_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! Subroutine: psb_ziluk_factint + ! Version: complex + ! Note: internal subroutine of psb_ziluk_fact + ! + ! This routine computes either the ILU(k) or the MILU(k) factorization of the + ! diagonal blocks of a distributed matrix. These factorizations are used to build + ! the 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k)/MILU(k) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in level k in ILU(k)/MILU(k). + ! ialg - integer, input. + ! The type of incomplete factorization to be performed. + ! The MILU(k) factorization is computed if ialg = 2 (= psb_milu_n_); + ! the ILU(k) factorization otherwise. + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! laspk - complex(psb_dpk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lia2 - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in laspk, according to the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in laspk. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_ziluk_factint(fill_in,ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, ialg + type(psb_zspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) + complex(psb_dpk_), intent(inout) :: d(:) + + ! Local variables + integer(psb_ipk_) :: ma,mb,i, ktrw,err_act,nidx, m + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + complex(psb_dpk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_z_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_ziluk_factint' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + select case(ialg) + case(psb_ilu_n_,psb_milu_n_) + ! Ok + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,& + & i_err=(/itwo,ialg,izero,izero,izero/)) + goto 9999 + end select + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the iluk_copyin function + ! + + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row and the corresponding + ! fill levels + ! + allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + uplevs(:) = m+1 + row(:) = zzero + rowlevs(:) = -(m+1) + + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the iluk_copyin routine, and updated during the elimination, in + ! the iluk_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = zzero + if (i<=ma) then + ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! + call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) + else + ! + ! Copy into trw the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row) + ! + call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) + endif + + ! Do an elimination step on the current row. It turns out we only + ! need to keep track of fill levels for the upper triangle, hence we + ! do not have a lowlevs variable. + ! + if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& + & d,uja,uirp,uval,uplevs,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + end do + + ! + ! And we're done, so deallocate the memory + ! + deallocate(uplevs,rowlevs,row,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_ziluk_factint + + ! + ! Subroutine: iluk_copyin + ! Version: complex + ! Note: internal subroutine of psb_ziluk_fact + ! + ! This routine copies a row of a sparse matrix A, stored in the sparse matrix + ! structure a, into the array row and stores into a heap the column indices of + ! the nonzero entries of the copied row. The output array row is such that it + ! contains a full row of A, i.e. it contains also the zero entries of the row. + ! This is useful for the elimination step performed by iluk_fact after the call + ! to iluk_copyin (see psb_iluk_factint). + ! The routine also sets to zero the entries of the array rowlevs corresponding + ! to the nonzero entries of the copied row (see the description of the arguments + ! below). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilu_copyin. + ! + ! This routine is used by psb_ziluk_factint in the computation of the + ! ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the row to be copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! row - complex(psb_dpk_), dimension(:), input/output. + ! In input it is the null vector (see psb_iluk_factint and + ! iluk_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in iluk_fact. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_zspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine iluk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act,nz + integer(psb_ipk_), parameter :: nrb=40 + character(len=20), parameter :: name='iluk_copyin' + character(len=20) :: ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + call heap%init(info) + + select type (aa=> a%a) + type is (psb_z_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to iluk_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getblk' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 + end if + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + ktrw = ktrw + 1 + enddo + end select + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyin + + ! + ! Subroutine: iluk_fact + ! Version: complex + ! Note: internal subroutine of psb_ziluk_fact + ! + ! This routine does an elimination step of the ILU(k) factorization on a + ! single matrix row (see the calling routine psb_iluk_factint). + ! + ! This step is also the base for a MILU(k) elimination step on the row (see + ! iluk_copyout). This routine is used by psb_ziluk_factint in the computation + ! of the ILU(k)/MILU(k) factorization of a local sparse matrix. + ! + ! NOTE: it turns out we only need to keep track of the fill levels for + ! the upper triangle. + ! + ! + ! Arguments + ! fill_in - integer, input. + ! The fill-in level k in ILU(k). + ! i - integer, input. + ! The local index of the row to which the factorization is + ! applied. + ! row - complex(psb_dpk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = 0 if the k-th entry of the row is + ! nonzero, and rowlevs(k) = -(m+1) otherwise. In output + ! rowlevs(k) contains the fill kevel of the k-th entry of + ! the row after the current elimination step; rowlevs(k) = -(m+1) + ! means that the k-th row entry is zero throughout the elimination + ! step. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the indices concerning the transformed row. + ! d - complex(psb_dpk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see iluk_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! iluk_copyout, called by psb_ziluk_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see iluk_copyout, called by psb_ziluk_factint), according to + ! the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! uplevs - integer, dimension(:), input. + ! The fill levels of the nonzero entries in the part of the + ! U factor above the current row. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine iluk_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine iluk_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, done by this routine. + ! + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:),uplevs(:) + complex(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + complex(psb_dpk_) :: rwk + + info = psb_success_ + if (.not.allocated(idxs)) then + allocate(idxs(200),stat=info) + if (info /= psb_success_) return + endif + nidx = 0 + lastk = -1 + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) return + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= zzero).and.(rowlevs(k) <= fill_in).and.(ki) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max((l2/i)*m,int(1.2*l2),l2+100) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) + if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uja(l2) = j + uval(l2) = row(j) + uplevs(l2) = rowlevs(j) + else if (ialg == psb_milu_n_) then + ! + ! MILU(k): add discarded entries to the diagonal one + ! + d(i) = d(i) + row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = zzero + rowlevs(j) = -(m+1) + end if + end do + + ! + ! Store the pointers to the first non occupied entry of in + ! lval and uval + ! + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 + + ! + ! Check the pivot size + ! + if (abs(d(i)) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = zone/d(i) + end if + + ! + ! Scale the upper part + ! + do j=uirp(i), uirp(i+1)-1 + uval(j) = d(i)*uval(j) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine iluk_copyout + + +end subroutine psb_ziluk_fact diff --git a/prec/impl/psb_z_ilut_fact.f90 b/prec/impl/psb_z_ilut_fact.f90 new file mode 100644 index 00000000..b7e8da05 --- /dev/null +++ b/prec/impl/psb_z_ilut_fact.f90 @@ -0,0 +1,1218 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! Moved here from MLD2P4, original copyright below. +! +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 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 MLD2P4 GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zilut_fact.f90 +! +! Subroutine: psb_zilut_fact +! Version: complex +! Contains: psb_zilut_factint, ilut_copyin, ilut_fact, ilut_copyout +! +! This routine computes the ILU(k,t) factorization of the diagonal blocks +! of a distributed matrix. This factorization is used to build the 'base +! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz +! preconditioner) corresponding to a certain level of a multilevel preconditioner. +! +! Details on the above factorization can be found in +! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, +! SIAM, 2003, Chapter 10. +! +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is +! CSR. The diagonal of the U factor is stored separately (actually, the +! inverse of the diagonal entries is stored; this is then managed in the +! solve stage associated to the ILU(k,t) factorization). +! +! +! Arguments: +! fill_in - integer, input. +! The fill-in parameter k in ILU(k,t). +! thres - real, input. +! The threshold t, i.e. the drop tolerance, in ILU(k,t). +! a - type(psb_zspmat_type), input. +! The sparse matrix structure containing the local matrix. +! Note that if the 'base' Additive Schwarz preconditioner +! has overlap greater than 0 and the matrix has not been reordered +! (see psb_fact_bld), then a contains only the 'original' local part +! of the distributed matrix, i.e. the rows of the matrix held +! by the calling process according to the initial data distribution. +! l - type(psb_zspmat_type), input/output. +! The L factor in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! u - type(psb_zspmat_type), input/output. +! The U factor (except its diagonal) in the incomplete factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! d - complex(psb_dpk_), dimension(:), input/output. +! The inverse of the diagonal entries of the U factor in the incomplete +! factorization. +! Note: its allocation is managed by the calling routine psb_ilu_bld, +! hence it cannot be only intent(out). +! info - integer, output. +! Error code. +! blck - type(psb_zspmat_type), input, optional, target. +! The sparse matrix structure containing the remote rows of the +! distributed matrix, that have been retrieved by psb_as_bld +! to build an Additive Schwarz base preconditioner with overlap +! greater than 0. If the overlap is 0 or the matrix has been reordered +! (see psb_fact_bld), then blck does not contain any row. +! +subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) + + use psb_base_mod + use psb_z_ilu_fact_mod, psb_protect_name => psb_zilut_fact + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_dpk_), intent(in) :: thres + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type),intent(in) :: a + type(psb_zspmat_type),intent(inout) :: l,u + complex(psb_dpk_), intent(inout) :: d(:) + type(psb_zspmat_type),intent(in), optional, target :: blck + integer(psb_ipk_), intent(in), optional :: iscale + ! Local Variables + integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ + + type(psb_zspmat_type), pointer :: blck_ + type(psb_z_csr_sparse_mat) :: ll, uu + real(psb_dpk_) :: scale + character(len=20) :: name, ch_err + + name='psb_zilut_fact' + info = psb_success_ + call psb_erractionsave(err_act) + + if (fill_in < 0) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name, & + & i_err=(/ione,fill_in,izero,izero,izero/)) + goto 9999 + end if + ! + ! Point to / allocate memory for the incomplete factorization + ! + if (present(blck)) then + blck_ => blck + else + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + if (present(iscale)) then + iscale_ = iscale + else + iscale_ = psb_ilu_scale_none_ + end if + + select case(iscale_) + case(psb_ilu_scale_none_) + scale = sone + case(psb_ilu_scale_maxval_) + scale = max(a%maxval(),blck_%maxval()) + scale = sone/scale + case default + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) + goto 9999 + end select + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + + ! + ! Compute the ILU(k,t) factorization + ! + call psb_zilut_factint(fill_in,thres,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info,scale) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_zilut_factint' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Store information on the L and U sparse matrices + ! + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + + ! + ! Nullify pointer / deallocate memory + ! + if (present(blck)) then + blck_ => null() + else + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +contains + + ! + ! Subroutine: psb_zilut_factint + ! Version: complex + ! Note: internal subroutine of psb_zilut_fact + ! + ! This routine computes the ILU(k,t) factorization of the diagonal blocks of a + ! distributed matrix. This factorization is used to build the 'base + ! preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz + ! preconditioner) corresponding to a certain level of a multilevel preconditioner. + ! + ! The local matrix to be factorized is stored into a and b, as specified in the + ! description of the arguments below. The storage format for both the L and U + ! factors is CSR. The diagonal of the U factor is stored separately (actually, + ! the inverse of the diagonal entries is stored; this is then managed in the + ! solve stage associated to the ILU(k,t) factorization). + ! + ! + ! Arguments: + ! fill_in - integer, input. + ! The fill-in parameter k in ILU(k,t). + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! m - integer, output. + ! The total number of rows of the local matrix to be factorized, + ! i.e. ma+mb. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the local matrix. + ! Note that, if the 'base' Additive Schwarz preconditioner + ! has overlap greater than 0 and the matrix has not been reordered + ! (see psb_fact_bld), then a contains only the 'original' local part + ! of the distributed matrix, i.e. the rows of the matrix held + ! by the calling process according to the initial data distribution. + ! b - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the remote rows of the + ! distributed matrix, that have been retrieved by psb_as_bld + ! to build an Additive Schwarz base preconditioner with overlap + ! greater than 0. If the overlap is 0 or the matrix has been reordered + ! (see psb_fact_bld), then b does not contain any row. + ! d - complex(psb_dpk_), dimension(:), output. + ! The inverse of the diagonal entries of the U factor in the incomplete + ! factorization. + ! lval - complex(psb_dpk_), dimension(:), input/output. + ! The L factor in the incomplete factorization. + ! lia1 - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the L factor, + ! according to the CSR storage format. + ! lirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the L factor in lval, according to the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input/output. + ! The U factor in the incomplete factorization. + ! The entries of U are stored according to the CSR format. + ! uja - integer, dimension(:), input/output. + ! The column indices of the nonzero entries of the U factor, + ! according to the CSR storage format. + ! uirp - integer, dimension(:), input/output. + ! The indices identifying the first nonzero entry of each row + ! of the U factor in uval, according to the CSR storage format. + ! l1 - integer, output + ! The number of nonzero entries in lval. + ! l2 - integer, output + ! The number of nonzero entries in uval. + ! info - integer, output. + ! Error code. + ! + subroutine psb_zilut_factint(fill_in,thres,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info,scale) + + use psb_base_mod + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in + real(psb_dpk_), intent(in) :: thres + type(psb_zspmat_type),intent(in) :: a,b + integer(psb_ipk_),intent(inout) :: l1,l2,info + integer(psb_ipk_), allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:) + complex(psb_dpk_), intent(inout) :: d(:) + real(psb_dpk_), intent(in), optional :: scale + + ! Local Variables + integer(psb_ipk_) :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m + real(psb_dpk_) :: nrmi + real(psb_dpk_) :: weight + integer(psb_ipk_), allocatable :: idxs(:) + complex(psb_dpk_), allocatable :: row(:) + type(psb_i_heap) :: heap + type(psb_z_coo_sparse_mat) :: trw + character(len=20), parameter :: name='psb_zilut_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + + ma = a%get_nrows() + mb = b%get_nrows() + m = ma+mb + + ! + ! Allocate a temporary buffer for the ilut_copyin function + ! + call trw%allocate(izero,izero,ione) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_all') + goto 9999 + end if + + l1=0 + l2=0 + lirp(1) = 1 + uirp(1) = 1 + + ! + ! Allocate memory to hold the entries of a row + ! + allocate(row(m),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + row(:) = czero + weight = sone + if (present(scale)) weight = abs(scale) + ! + ! Cycle over the matrix rows + ! + do i = 1, m + + ! + ! At each iteration of the loop we keep in a heap the column indices + ! affected by the factorization. The heap is initialized and filled + ! in the ilut_copyin function, and updated during the elimination, in + ! the ilut_fact routine. The heap is ideal because at each step we need + ! the lowest index, but we also need to insert new items, and the heap + ! allows to do both in log time. + ! + d(i) = czero + if (i<=ma) then + call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + else + call ilut_copyin(i-ma,mb,b,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& + & row,heap,ktrw,trw,info) + endif + + ! + ! Do an elimination step on current row + ! + if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& + & d,uja,uirp,uval,nidx,idxs,info) + ! + ! Copy the row into lval/d(i)/uval + ! + if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& + & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Copy/factor loop') + goto 9999 + end if + + end do + ! + ! Adjust diagonal accounting for scale factor + ! + if (weight /= sone) then + d(1:m) = d(1:m)*weight + end if + + ! + ! And we're sone, so deallocate the memory + ! + deallocate(row,idxs,stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Deallocate') + goto 9999 + end if + if (info == psb_success_) call trw%free() + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine psb_zilut_factint + + ! + ! Subroutine: ilut_copyin + ! Version: complex + ! Note: internal subroutine of psb_zilut_fact + ! + ! This routine performs the following tasks: + ! - copying a row of a sparse matrix A, stored in the sparse matrix structure a, + ! into the array row; + ! - storing into a heap the column indices of the nonzero entries of the copied + ! row; + ! - computing the column index of the first entry with maximum absolute value + ! in the part of the row belonging to the upper triangle; + ! - computing the 2-norm of the row. + ! The output array row is such that it contains a full row of A, i.e. it contains + ! also the zero entries of the row. This is useful for the elimination step + ! performed by ilut_fact after the call to ilut_copyin (see psb_ilut_factint). + ! + ! If the sparse matrix is in CSR format, a 'straight' copy is performed; + ! otherwise psb_sp_getblk is used to extract a block of rows, which is then + ! copied, row by row, into the array row, through successive calls to + ! ilut_copyin. + ! + ! This routine is used by psb_zilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments: + ! i - integer, input. + ! The local index of the row to be extracted from the + ! sparse matrix structure a. + ! m - integer, input. + ! The number of rows of the local matrix stored into a. + ! a - type(psb_zspmat_type), input. + ! The sparse matrix structure containing the row to be + ! copied. + ! jd - integer, input. + ! The column index of the diagonal entry of the row to be + ! copied. + ! jmin - integer, input. + ! The minimum valid column index. + ! jmax - integer, input. + ! The maximum valid column index. + ! The output matrix will contain a clipped copy taken from + ! a(1:m,jmin:jmax). + ! nlw - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the lower triangle of the matrix. + ! nup - integer, output. + ! The number of nonzero entries in the part of the row + ! belonging to the upper triangle of the matrix. + ! jmaxup - integer, output. + ! The column index of the first entry with maximum absolute + ! value in the part of the row belonging to the upper triangle + ! nrmi - real(psb_dpk_), output. + ! The 2-norm of the current row. + ! row - complex(psb_dpk_), dimension(:), input/output. + ! In input it is the null vector (see psb_ilut_factint and + ! ilut_copyout). In output it contains the row extracted + ! from the matrix A. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! rowlevs - integer, dimension(:), input/output. + ! In input rowlevs(k) = -(m+1) for k=1,...,m. In output + ! rowlevs(k) = 0 for 1 <= k <= jmax and A(i,k) /= 0, for + ! future use in ilut_fact. + ! heap - type(psb_int_heap), input/output. + ! The heap containing the column indices of the nonzero + ! entries in the array row. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by psb_init_heap inside this + ! routine. + ! ktrw - integer, input/output. + ! The index identifying the last entry taken from the + ! staging buffer trw. See below. + ! trw - type(psb_zspmat_type), input/output. + ! A staging buffer. If the matrix A is not in CSR format, we use + ! the psb_sp_getblk routine and store its output in trw; when we + ! need to call psb_sp_getblk we do it for a block of rows, and then + ! we consume them from trw in successive calls to this routine, + ! until we empty the buffer. Thus we will make a call to psb_sp_getblk + ! every nrb calls to copyin. If A is in CSR format it is unused. + ! + subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& + & nrmi,weight,row,heap,ktrw,trw,info) + use psb_base_mod + implicit none + type(psb_zspmat_type), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_dpk_), intent(inout) :: nrmi + complex(psb_dpk_), intent(inout) :: row(:) + real(psb_dpk_), intent(in) :: weight + type(psb_i_heap), intent(inout) :: heap + + integer(psb_ipk_) :: k,j,irb,kin,nz + integer(psb_ipk_), parameter :: nrb=40 + real(psb_dpk_) :: dmaxup + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='psb_zilut_factint' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + select type (aa=> a%a) + type is (psb_z_csr_sparse_mat) + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + nz = aa%irp(i+1) - aa%irp(i) + nrmi = weight*dnrm2(nz,aa%val(aa%irp(i)),ione) + + + class default + + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into the array row, through successive + ! calls to ilut_copyin. + ! + + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getblk') + goto 9999 + end if + ktrw=1 + end if + + kin = ktrw + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = trw%val(ktrw)*weight + call heap%insert(k,info) + if (info /= psb_success_) exit + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end if + ktrw = ktrw + 1 + enddo + nz = ktrw - kin + nrmi = weight*dnrm2(nz,trw%val(kin),ione) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine ilut_copyin + + ! + ! Subroutine: ilut_fact + ! Version: complex + ! Note: internal subroutine of psb_zilut_fact + ! + ! This routine does an elimination step of the ILU(k,t) factorization on a single + ! matrix row (see the calling routine psb_ilut_factint). Actually, only the dropping + ! rule based on the threshold is applied here. The dropping rule based on the + ! fill-in is applied by ilut_copyout. + ! + ! The routine is used by psb_zilut_factint in the computation of the ILU(k,t) + ! factorization of a local sparse matrix. + ! + ! + ! Arguments + ! thres - real, input. + ! The threshold t, i.e. the drop tolerance, in ILU(k,t). + ! i - integer, input. + ! The local index of the row to which the factorization is applied. + ! nrmi - real(psb_dpk_), input. + ! The 2-norm of the row to which the elimination step has to be + ! applied. + ! row - complex(psb_dpk_), dimension(:), input/output. + ! In input it contains the row to which the elimination step + ! has to be applied. In output it contains the row after the + ! elimination step. It actually contains a full row, i.e. + ! it contains also the zero entries of the row. + ! heap - type(psb_i_heap), input/output. + ! The heap containing the column indices of the nonzero entries + ! in the processed row. In input it contains the indices concerning + ! the row before the elimination step, while in output it contains + ! the previous indices plus the ones corresponding to transformed + ! entries in the 'upper part' that have not been dropped. + ! d - complex(psb_dpk_), input. + ! The inverse of the diagonal entries of the part of the U factor + ! above the current row (see ilut_copyout). + ! uja - integer, dimension(:), input. + ! The column indices of the nonzero entries of the part of the U + ! factor above the current row, stored in uval row by row (see + ! ilut_copyout, called by psb_zilut_factint), according to the CSR + ! storage format. + ! uirp - integer, dimension(:), input. + ! The indices identifying the first nonzero entry of each row of + ! the U factor above the current row, stored in uval row by row + ! (see ilut_copyout, called by psb_zilut_factint), according to + ! the CSR storage format. + ! uval - complex(psb_dpk_), dimension(:), input. + ! The entries of the U factor above the current row (except the + ! diagonal ones), stored according to the CSR format. + ! nidx - integer, output. + ! The number of entries of the array row that have been + ! examined during the elimination step. This will be used + ! by the routine ilut_copyout. + ! idxs - integer, dimension(:), allocatable, input/output. + ! The indices of the entries of the array row that have been + ! examined during the elimination step.This will be used by + ! by the routine ilut_copyout. + ! Note: this argument is intent(inout) and not only intent(out) + ! to retain its allocation, sone by this routine. + ! + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) + + use psb_base_mod + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: uja(:),uirp(:) + complex(psb_dpk_), intent(inout) :: row(:), uval(:),d(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + complex(psb_dpk_) :: rwk + + info = psb_success_ + call psb_ensure_size(200*ione,idxs,info) + if (info /= psb_success_) return + nidx = 0 + lastk = -1 + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + lowert: if (k nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + ! + ! Now we have to take out the first nlw+fill_in entries + ! + if (nz <= nlw+fill_in) then + ! + ! Just copy everything from xw, and it is already ordered + ! + else + nz = nlw+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_heap_get_first') + goto 9999 + end if + + xw(k) = witem + xwid(k) = widx + end do + end if + + ! + ! Now put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the lower part of the row + ! + do k=1,nz + l1 = l1 + 1 + if (size(lval) < l1) then + ! + ! Figure out a good reallocation size! + ! + isz = (max((l1/i)*m,int(1.2*l1),l1+100)) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + lja(l1) = xwid(k) + lval(l1) = xw(indx(k)) + end do + + ! + ! Make sure idxp points to the diagonal entry + ! + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + if (idxp > size(idxs)) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else + if (idxs(idxp) > i) then +!!$ write(0,*) 'Warning: missing diagonal element in the row ' + else if (idxs(idxp) /= i) then +!!$ write(0,*) 'Warning: impossible error: diagonal has vanished' + else + ! + ! Copy the diagonal entry + ! + widx = idxs(idxp) + witem = row(widx) + d(i) = witem + if (abs(d(i)) < d_epstol) then + ! + ! Too small pivot: unstable factorization + ! + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') d(i) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else + ! + ! Compute 1/pivot + ! + d(i) = cone/d(i) + end if + end if + end if + + ! + ! Now the upper part + ! + + call heap%init(info,dir=psb_asort_down_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + nz = 0 + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx <= i) then +!!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then +!!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i +#include +#include "@METISINCFILE@" + +typedef int32_t psb_m_t; + +#if defined(IPK4) && defined(LPK4) +typedef int32_t psb_i_t; +typedef int32_t psb_l_t; +#elif defined(IPK4) && defined(LPK8) +typedef int32_t psb_i_t; +typedef int64_t psb_l_t; +#elif defined(IPK8) && defined(LPK8) +typedef int64_t psb_i_t; +typedef int64_t psb_l_t; +#else +#endif +typedef int64_t psb_e_t; + +typedef float psb_s_t; +typedef double psb_d_t; +typedef float complex psb_c_t; +typedef double complex psb_z_t;