fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-21 05:12:13 +00:00
Code Issues Packages Projects Releases Wiki Activity

Reorganized USE hierarchy.

Browse Source 
Cleaned up the PREC directory.
This commit is contained in:
Salvatore Filippone
2007-02-21 14:29:58 +00:00
parent 96304ec351
commit 217e6b2a52
41 changed files with 730 additions and 1100 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/internals/Makefile
+2 -3
View File
@@ -2,9 +2,8 @@ include ../../Make.inc
FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \
psi_crea_ovr_elem.o psi_dl_check.o \
psi_gthsct.o \
psi_sort_dl.o \
psi_gthsct.o psi_ldsc_pre_halo.o\
psi_ldsc_pre_halo.o\
psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o psi_fnd_owner.o
FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o
COBJS = avltree.o srcht.o
@@ -22,7 +21,7 @@ lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
mpfobjs: psi_gthsct.o
mpfobjs:
(make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)")
(make $(FOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)")
clean:
base/internals/psi_compute_size.f90
+1
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
use psi_mod, psb_protect_name => psi_compute_size
use psb_const_mod
use psb_descriptor_type
use psb_error_mod
base/internals/psi_crea_bnd_elem.f90
+1
View File
@@ -29,6 +29,7 @@
!!$
!!$
subroutine psi_crea_bnd_elem(bndel,desc_a,info)
use psi_mod, psb_protect_name => psi_crea_bnd_elem
use psb_realloc_mod
use psb_descriptor_type
use psb_error_mod
base/internals/psi_crea_index.f90
+1 -27
View File
@@ -34,6 +34,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
use psb_descriptor_type
use psb_error_mod
use psb_penv_mod
use psi_mod, psb_protect_name => psi_crea_index
implicit none
type(psb_desc_type), intent(in) :: desc_a
@@ -50,33 +51,6 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
logical,parameter :: debug=.false.
character(len=20) :: name
interface
subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
integer :: np,dep_list(:,:), l_dep_list(:), info
end subroutine psi_sort_dl
end interface
interface
subroutine psi_dl_check(dep_list,dl_lda,np,length_dl)
integer :: np,dl_lda,length_dl(0:np)
integer :: dep_list(dl_lda,0:np)
end subroutine psi_dl_check
end interface
interface
subroutine psi_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,&
& isglob_in,info)
use psb_descriptor_type
type(psb_desc_type) :: desc
integer :: index_in(:),dep_list(:)
integer, allocatable :: desc_index(:)
integer :: length_dl,nsnd,nrcv,info
logical :: isglob_in
end subroutine psi_desc_index
end interface
info = 0
name='psi_crea_index'
call psb_erractionsave(err_act)
base/internals/psi_crea_ovr_elem.f90
+1
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info)
use psi_mod, psb_protect_name => psi_crea_ovr_elem
use psb_realloc_mod
use psb_error_mod
use psb_penv_mod
base/internals/psi_desc_index.f90
+1 -1
View File
@@ -36,7 +36,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
use psb_const_mod
use mpi
use psb_penv_mod
use psi_mod, only : psi_idx_cnv
use psi_mod, psb_protect_name => psi_desc_index
implicit none
! ...array parameters.....
base/internals/psi_dl_check.f90
+1
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_dl_check(dep_list,dl_lda,np,length_dl)
use psi_mod, psb_protect_name => psi_dl_check
use psb_const_mod
use psb_descriptor_type
implicit none
base/internals/psi_dswapdata.f90
+2 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdatam
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti, data_
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -442,6 +442,7 @@ end subroutine psi_dswapdatam
!!$
subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdatav
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -465,7 +466,6 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/internals/psi_dswaptran.f90
+2 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -427,6 +427,7 @@ end subroutine psi_dswaptranm
!!$
subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptranv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -450,7 +451,6 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/internals/psi_extrct_dl.f90
+2 -1
View File
@@ -117,6 +117,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
! desc_str list.
! length_dl integer array(0:np)
! length_dl(i) is the length of dep_list(*,i) list
use psi_mod, psb_protect_name => psi_extract_dep_list
use mpi
use psb_penv_mod
use psb_const_mod
@@ -128,7 +129,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
! ....array parameters....
integer :: desc_str(*),desc_data(*),dep_list(dl_lda,0:np),length_dl(0:np)
integer, pointer :: itmp(:)
integer, allocatable :: itmp(:)
! .....local arrays....
integer int_err(5)
double precision real_err(5)
base/internals/psi_fnd_owner.f90
+2 -1
View File
@@ -35,7 +35,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, only : psi_idx_cnv
use psi_mod, psb_protect_name => psi_fnd_owner
implicit none
integer, intent(in) :: nv
integer, intent(in) :: idx(:)
base/internals/psi_idx_cnv.f90
+5 -24
View File
@@ -34,6 +34,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psi_mod, psb_protect_name => psi_idx_cnv1
implicit none
integer, intent(in) :: nv
integer, intent(inout) :: idxin(:)
@@ -41,17 +42,6 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: owned
interface
subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv2
end interface
integer :: i,ictxt,row,k,mglob, nglob,err
integer :: np, me, isize
integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt
@@ -184,7 +174,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psi_mod, only : psi_inner_cnv
use psi_mod, psb_protect_name => psi_idx_cnv2
implicit none
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
@@ -366,6 +356,8 @@ end subroutine psi_idx_cnv2
!!$
!!$
subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
use psi_mod, psb_protect_name => psi_idx_cnvs
use psb_descriptor_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
@@ -373,17 +365,6 @@ subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
logical, intent(in), optional :: owned
interface
subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv2
end interface
integer :: iout(1)
logical :: mask_, owned_
@@ -397,7 +378,7 @@ subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
else
owned_ = .true.
endif
call psi_idx_cnv2(1,(/idxin/),iout,desc,info,(/mask_/),owned_)
call psi_idx_cnv(1,(/idxin/),iout,desc,info,(/mask_/),owned_)
idxout=iout(1)
return
base/internals/psi_idx_ins_cnv.f90
+4 -21
View File
@@ -29,6 +29,7 @@
!!$
!!$
subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_ins_cnv1
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
@@ -40,16 +41,6 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
interface
subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
end subroutine psi_idx_ins_cnv2
end interface
integer :: i,ictxt,row,k,mglob, nglob,err
integer :: np, me, isize
integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt
@@ -170,6 +161,7 @@ end subroutine psi_idx_ins_cnv1
!!$
subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_ins_cnv2
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
@@ -408,22 +400,13 @@ end subroutine psi_idx_ins_cnv2
!!$
!!$
subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask)
use psi_mod, psb_protect_name => psi_idx_cnvs
use psb_descriptor_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
interface
subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
end subroutine psi_idx_ins_cnv2
end interface
integer :: iout(1)
logical :: mask_
@@ -432,7 +415,7 @@ subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask)
else
mask_ = .true.
endif
call psi_idx_ins_cnv2(1,(/idxin/),iout,desc,info,(/mask_/))
call psi_idx_ins_cnv(1,(/idxin/),iout,desc,info,(/mask_/))
idxout=iout(1)
return
base/internals/psi_iswapdata.f90
+2 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdatam
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti, data_
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -442,6 +442,7 @@ end subroutine psi_iswapdatam
!!$
subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdatav
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -465,7 +466,6 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/internals/psi_iswaptran.f90
+2 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -428,6 +428,7 @@ end subroutine psi_iswaptranm
!!$
subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptranv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -451,7 +452,6 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/internals/psi_ldsc_pre_halo.f90
+1 -1
View File
@@ -35,7 +35,7 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, only : psi_fnd_owner
use psi_mod, psb_protect_name => psi_ldsc_pre_halo
implicit none
type(psb_desc_type), intent(inout) :: desc
logical, intent(in) :: ext_hv
base/internals/psi_sort_dl.f90
+1
View File
@@ -33,6 +33,7 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
! interface between former sort_dep_list subroutine
! and new srtlist
!
use psi_mod, psb_protect_name => psi_sort_dl
use psb_const_mod
use psb_error_mod
implicit none
base/internals/psi_zswapdata.f90
+2 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdatam
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti, data_
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -442,6 +442,7 @@ end subroutine psi_zswapdatam
!!$
subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswapdatav
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -465,7 +466,6 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/internals/psi_zswaptran.f90
+1 -2
View File
@@ -30,6 +30,7 @@
!!$
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@@ -49,7 +50,6 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,&
& snd_pt, rcv_pt, pnti
integer :: krecvid, ksendid
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
@@ -445,7 +445,6 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
integer, allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer, pointer :: d_idx(:)
integer :: krecvid, ksendid
integer :: int_err(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
base/modules/Makefile
+2 -1
View File
@@ -3,6 +3,7 @@ include ../../Make.inc
MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
psb_desc_type.o psb_spsb_mod.o \
psb_serial_mod.o psb_tools_mod.o \
psi_gthsct_mod.o \
psb_error_mod.o \
psb_const_mod.o \
psb_comm_mod.o psb_psblas_mod.o psi_mod.o \
@@ -21,7 +22,7 @@ psb_realloc_mod.o : psb_error_mod.o
psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o
psb_error_mod.o: psb_const_mod.o
psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psi_gthsct_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o
psb_check_mod.o: psb_desc_type.o
psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
base/modules/psb_gthsct_mod.f90
-349
View File
@@ -1,349 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psi_gthsct_mod
interface psi_gth
module procedure psi_igthm, psi_igthv,&
& psi_dgthm, psi_dgthv,&
& psi_zgthm, psi_zgthv
end interface
interface psi_sct
module procedure psi_isctm, psi_isctv,&
& psi_dsctm, psi_dsctv,&
& psi_zsctm, psi_zsctv
end interface
contains
subroutine psi_dgthm(n,k,idx,x,y)
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_dgthm
subroutine psi_dgthv(n,idx,x,y)
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i, j
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_dgthv
subroutine psi_dsctm(n,k,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta.eq.1.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_dsctm
subroutine psi_dsctv(n,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta.eq.1.d0) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_dsctv
subroutine psi_igthm(n,k,idx,x,y)
implicit none
integer :: n, k, idx(:)
integer :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_igthm
subroutine psi_igthv(n,idx,x,y)
implicit none
integer :: n, idx(:)
integer :: x(:), y(:)
! Locals
integer :: i, j
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_igthv
subroutine psi_isctm(n,k,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
integer :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta.eq.1.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_isctm
subroutine psi_isctv(n,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
integer :: beta, x(:), y(:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta.eq.1.d0) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_isctv
subroutine psi_zgthm(n,k,idx,x,y)
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_zgthm
subroutine psi_zgthv(n,idx,x,y)
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i, j
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_zgthv
subroutine psi_zsctm(n,k,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta.eq.1.d0) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_zsctm
subroutine psi_zsctv(n,idx,x,beta,y)
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i, j, pt
if (beta.eq.0.d0) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta.eq.1.d0) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_zsctv
end module psi_gthsct_mod
base/modules/psb_penv_mod.F90
+14
View File
@@ -168,6 +168,20 @@ module psb_penv_mod
#if defined(SERIAL_MPI)
integer, private, save :: nctxt=0
#endif
#if defined(NETLIB_BLACS)
interface
integer function krecvid(contxt,proc_to_comm,myrow)
integer contxt,proc_to_comm,myrow
end function krecvid
end interface
interface
integer function ksendid(contxt,proc_to_comm,myrow)
integer contxt,proc_to_comm,myrow
end function ksendid
end interface
#endif
contains
base/modules/psb_serial_mod.f90
+4 -2
View File
@@ -309,19 +309,21 @@ module psb_serial_mod
end interface
interface psb_rwextd
subroutine psb_drwextd(nr,a,info,b)
subroutine psb_drwextd(nr,a,info,b,rowscale)
use psb_spmat_type
integer, intent(in) :: nr
type(psb_dspmat_type), intent(inout) :: a
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), optional :: b
logical, intent(in), optional :: rowscale
end subroutine psb_drwextd
subroutine psb_zrwextd(nr,a,info,b)
subroutine psb_zrwextd(nr,a,info,b,rowscale)
use psb_spmat_type
integer, intent(in) :: nr
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), optional :: b
logical, intent(in), optional :: rowscale
end subroutine psb_zrwextd
end interface
base/modules/psb_spmat_type.f90
+1 -1
View File
@@ -508,7 +508,7 @@ contains
if (info /= 0) return
call psb_realloc(max(nnz,a%m+1,a%k+1),a%ia2,info)
if (info /= 0) return
call psb_realloc(ifc*nnz+200,a%ia1,info)
call psb_realloc(max(ifc*nnz+200,a%m+1,a%k+1),a%ia1,info)
if (info /= 0) return
end if
if (info /= 0) return
base/modules/psb_tools_mod.f90
+1 -2
View File
@@ -726,7 +726,7 @@ contains
subroutine psb_cdasb(desc_a,info)
use psb_descriptor_type
interface psb_icdasb
interface
subroutine psb_icdasb(desc_a,info,ext_hv)
use psb_descriptor_type
Type(psb_desc_type), intent(inout) :: desc_a
@@ -735,7 +735,6 @@ contains
end subroutine psb_icdasb
end interface
Type(psb_desc_type), intent(inout) :: desc_a
integer, intent(out) :: info
base/internals/psi_gthsct.f90 → base/modules/psi_gthsct_mod.f90
View File
base/modules/psi_mod.f90
+24 -73
View File
@@ -30,16 +30,8 @@
!!$
module psi_mod
use psi_gthsct_mod
!!$ use psb_descriptor_type
!!$ interface
!!$ subroutine psi_inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
!!$ integer, intent(in) :: n, hashsize,hashmask,hashv(0:),glb_lc(:,:)
!!$ integer, intent(inout) :: x(:)
!!$ end subroutine psi_inner_cnv
!!$ end interface
interface
subroutine psi_compute_size(desc_data,&
& index_in, dl_lda, info)
@@ -77,17 +69,24 @@ module psi_mod
end interface
interface
subroutine psi_desc_index(desc_data,index_in,dep_list,&
& length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,&
& isglob_in,info)
integer :: desc_data(:),index_in(:),dep_list(:)
integer :: loc_to_glob(:),glob_to_loc(:)
integer,allocatable, intent(inout) :: desc_index(:)
integer :: length_dl,nsnd,nrcv,info
logical :: isglob_in
end subroutine psi_desc_index
subroutine psi_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,isglob_in,info)
use psb_descriptor_type
type(psb_desc_type) :: desc
integer :: index_in(:),dep_list(:)
integer,allocatable, intent(inout) :: desc_index(:)
integer :: length_dl,nsnd,nrcv,info
logical :: isglob_in
end subroutine psi_desc_index
end interface
interface
subroutine psi_dl_check(dep_list,dl_lda,np,length_dl)
integer :: np,dl_lda,length_dl(0:np)
integer :: dep_list(dl_lda,0:np)
end subroutine psi_dl_check
end interface
interface
subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
integer :: np,dep_list(:,:), l_dep_list(:), info
@@ -203,61 +202,6 @@ module psi_mod
end subroutine psi_zswaptranv
end interface
interface psi_gth
subroutine psi_dgthm(n,k,idx,x,y)
integer :: n, k, idx(:)
real(kind(1.d0)) :: x(:,:), y(:)
end subroutine psi_dgthm
subroutine psi_dgthv(n,idx,x,y)
integer :: n, idx(:)
real(kind(1.d0)) :: x(:), y(:)
end subroutine psi_dgthv
subroutine psi_igthm(n,k,idx,x,y)
integer :: n, k, idx(:)
integer :: x(:,:), y(:)
end subroutine psi_igthm
subroutine psi_igthv(n,idx,x,y)
integer :: n, idx(:)
integer :: x(:), y(:)
end subroutine psi_igthv
subroutine psi_zgthm(n,k,idx,x,y)
integer :: n, k, idx(:)
complex(kind(1.d0)) :: x(:,:), y(:)
end subroutine psi_zgthm
subroutine psi_zgthv(n,idx,x,y)
integer :: n, idx(:)
complex(kind(1.d0)) :: x(:), y(:)
end subroutine psi_zgthv
end interface
interface psi_sct
subroutine psi_dsctm(n,k,idx,x,beta,y)
integer :: n, k, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:,:)
end subroutine psi_dsctm
subroutine psi_dsctv(n,idx,x,beta,y)
integer :: n, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:)
end subroutine psi_dsctv
subroutine psi_isctm(n,k,idx,x,beta,y)
integer :: n, k, idx(:)
integer :: beta, x(:), y(:,:)
end subroutine psi_isctm
subroutine psi_isctv(n,idx,x,beta,y)
integer :: n, idx(:)
integer :: beta, x(:), y(:)
end subroutine psi_isctv
subroutine psi_zsctm(n,k,idx,x,beta,y)
integer :: n, k, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:,:)
end subroutine psi_zsctm
subroutine psi_zsctv(n,idx,x,beta,y)
integer :: n, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:)
end subroutine psi_zsctv
end interface
interface psi_cnv_dsc
module procedure psi_cnv_dsc
end interface
@@ -266,6 +210,13 @@ module psi_mod
module procedure psi_inner_cnv1, psi_inner_cnv2
end interface
interface
subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
& length_dl,np,dl_lda,mode,info)
integer :: np,dl_lda,mode, info
integer :: desc_str(*),desc_data(*),dep_list(dl_lda,0:np),length_dl(0:np)
end subroutine psi_extract_dep_list
end interface
interface psi_fnd_owner
subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
use psb_descriptor_type
base/serial/psb_drwextd.f90
+77 -25
View File
@@ -31,8 +31,13 @@
! File: psb_drwextd.f90
! Subroutine:
! Parameters:
subroutine psb_drwextd(nr,a,info,b)
!
! We have a problem here: 1. How to handle well all the formats?
! 2. What should we do with rowscale? Does it only
! apply when a%fida='COO' ??????
!
!
subroutine psb_drwextd(nr,a,info,b,rowscale)
use psb_spmat_type
use psb_error_mod
implicit none
@@ -42,39 +47,49 @@ subroutine psb_drwextd(nr,a,info,b)
type(psb_dspmat_type), intent(inout) :: a
integer,intent(out) :: info
type(psb_dspmat_type), intent(in), optional :: b
integer :: i,j,ja,jb,err_act
logical,intent(in), optional :: rowscale
integer :: i,j,ja,jb,err_act,nza,nzb
character(len=20) :: name, ch_err
logical rowscale_
name='psb_drwextd'
info = 0
call psb_erractionsave(err_act)
if (nr > a%m) then
if (present(rowscale)) then
rowscale_ = rowscale
else
rowscale_ = .true.
end if
if (nr > a%m) then
if (a%fida == 'CSR') then
call psb_realloc(nr+1,a%ia2,info)
if (present(b)) then
jb = b%ia2(b%m+1)-1
call psb_realloc(size(a%ia1)+jb,a%ia1,info)
call psb_realloc(size(a%aspk)+jb,a%aspk,info)
do i=1, min(nr-a%m,b%m)
! Should use spgtblk.
! Don't care for the time being.
a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i)
ja = a%ia2(a%m+i)
jb = b%ia2(i)
do
if (jb >= b%ia2(i+1)) exit
a%aspk(ja) = b%aspk(jb)
a%ia1(ja) = b%ia1(jb)
ja = ja + 1
jb = jb + 1
end do
end do
do j=i,nr-a%m
a%ia2(a%m+i+1) = a%ia2(a%m+i)
end do
nzb = psb_sp_get_nnzeros(b)
call psb_realloc(size(a%ia1)+nzb,a%ia1,info)
call psb_realloc(size(a%aspk)+nzb,a%aspk,info)
if (b%fida=='CSR') then
do i=1, min(nr-a%m,b%m)
a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i)
ja = a%ia2(a%m+i)
jb = b%ia2(i)
do
if (jb >= b%ia2(i+1)) exit
a%aspk(ja) = b%aspk(jb)
a%ia1(ja) = b%ia1(jb)
ja = ja + 1
jb = jb + 1
end do
end do
do j=i,nr-a%m
a%ia2(a%m+i+1) = a%ia2(a%m+i)
end do
else
write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!'
endif
else
do i=a%m+2,nr+1
a%ia2(i) = a%ia2(i-1)
@@ -83,7 +98,44 @@ subroutine psb_drwextd(nr,a,info,b)
a%m = nr
else if (a%fida == 'COO') then
if (present(b)) then
else
nza = psb_sp_get_nnzeros(a)
nzb = psb_sp_get_nnzeros(b)
call psb_sp_reall(a,nza+nzb,info)
if (b%fida=='COO') then
if (rowscale_) then
do j=1,nzb
if ((a%m + b%ia1(j)) <= nr) then
a%ia1(nza+j) = a%m + b%ia1(j)
a%ia2(nza+j) = b%ia2(j)
a%aspk(nza+j) = b%aspk(j)
end if
enddo
else
do j=1,nzb
if ((b%ia1(j)) <= nr) then
a%ia1(nza+j) = b%ia1(j)
a%ia2(nza+j) = b%ia2(j)
a%aspk(nza+j) = b%aspk(j)
endif
enddo
endif
a%infoa(psb_nnz_) = nza+nzb
else if(b%fida=='CSR') then
do i=1, min(nr-a%m,b%m)
do
jb = b%ia2(i)
if (jb >= b%ia2(i+1)) exit
nza = nza + 1
a%aspk(nza) = b%aspk(jb)
a%ia1(nza) = a%m + i
a%ia2(nza) = b%ia1(jb)
jb = jb + 1
end do
end do
a%infoa(psb_nnz_) = nza
else
write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!'
endif
endif
a%m = nr
else if (a%fida == 'JAD') then
base/serial/psb_zrwextd.f90
+77 -25
View File
@@ -31,8 +31,13 @@
! File: psb_zrwextd.f90
! Subroutine:
! Parameters:
subroutine psb_zrwextd(nr,a,info,b)
!
! We have a problem here: 1. How to handle well all the formats?
! 2. What should we do with rowscale? Does it only
! apply when a%fida='COO' ??????
!
!
subroutine psb_zrwextd(nr,a,info,b,rowscale)
use psb_spmat_type
use psb_error_mod
implicit none
@@ -42,39 +47,49 @@ subroutine psb_zrwextd(nr,a,info,b)
type(psb_zspmat_type), intent(inout) :: a
integer,intent(out) :: info
type(psb_zspmat_type), intent(in), optional :: b
integer :: i,j,ja,jb,err_act
logical,intent(in), optional :: rowscale
integer :: i,j,ja,jb,err_act,nza,nzb
character(len=20) :: name, ch_err
logical rowscale_
name='psb_zrwextd'
info = 0
call psb_erractionsave(err_act)
if (nr > a%m) then
if (present(rowscale)) then
rowscale_ = rowscale
else
rowscale_ = .true.
end if
if (nr > a%m) then
if (a%fida == 'CSR') then
call psb_realloc(nr+1,a%ia2,info)
if (present(b)) then
jb = b%ia2(b%m+1)-1
call psb_realloc(size(a%ia1)+jb,a%ia1,info)
call psb_realloc(size(a%aspk)+jb,a%aspk,info)
do i=1, min(nr-a%m,b%m)
! Should use spgtblk.
! Don't care for the time being.
a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i)
ja = a%ia2(a%m+i)
jb = b%ia2(i)
do
if (jb >= b%ia2(i+1)) exit
a%aspk(ja) = b%aspk(jb)
a%ia1(ja) = b%ia1(jb)
ja = ja + 1
jb = jb + 1
end do
end do
do j=i,nr-a%m
a%ia2(a%m+i+1) = a%ia2(a%m+i)
end do
nzb = psb_sp_get_nnzeros(b)
call psb_realloc(size(a%ia1)+nzb,a%ia1,info)
call psb_realloc(size(a%aspk)+nzb,a%aspk,info)
if (b%fida=='CSR') then
do i=1, min(nr-a%m,b%m)
a%ia2(a%m+i+1) = a%ia2(a%m+i) + b%ia2(i+1) - b%ia2(i)
ja = a%ia2(a%m+i)
jb = b%ia2(i)
do
if (jb >= b%ia2(i+1)) exit
a%aspk(ja) = b%aspk(jb)
a%ia1(ja) = b%ia1(jb)
ja = ja + 1
jb = jb + 1
end do
end do
do j=i,nr-a%m
a%ia2(a%m+i+1) = a%ia2(a%m+i)
end do
else
write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!'
endif
else
do i=a%m+2,nr+1
a%ia2(i) = a%ia2(i-1)
@@ -83,7 +98,44 @@ subroutine psb_zrwextd(nr,a,info,b)
a%m = nr
else if (a%fida == 'COO') then
if (present(b)) then
else
nza = psb_sp_get_nnzeros(a)
nzb = psb_sp_get_nnzeros(b)
call psb_sp_reall(a,nza+nzb,info)
if (b%fida=='COO') then
if (rowscale_) then
do j=1,nzb
if ((a%m + b%ia1(j)) <= nr) then
a%ia1(nza+j) = a%m + b%ia1(j)
a%ia2(nza+j) = b%ia2(j)
a%aspk(nza+j) = b%aspk(j)
end if
enddo
else
do j=1,nzb
if ((b%ia1(j)) <= nr) then
a%ia1(nza+j) = b%ia1(j)
a%ia2(nza+j) = b%ia2(j)
a%aspk(nza+j) = b%aspk(j)
endif
enddo
endif
a%infoa(psb_nnz_) = nza+nzb
else if(b%fida=='CSR') then
do i=1, min(nr-a%m,b%m)
do
jb = b%ia2(i)
if (jb >= b%ia2(i+1)) exit
nza = nza + 1
a%aspk(nza) = b%aspk(jb)
a%ia1(nza) = a%m + i
a%ia2(nza) = b%ia1(jb)
jb = jb + 1
end do
end do
a%infoa(psb_nnz_) = nza
else
write(0,*) 'Implement SPGETBLK in RWEXTD!!!!!!!'
endif
endif
a%m = nr
else if (a%fida == 'JAD') then
base/tools/psb_dcdovr.f90
+4 -4
View File
@@ -46,14 +46,16 @@
!
Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype)
use psb_tools_mod, psb_protect_name => psb_dcdovr
use psb_serial_mod
use psb_descriptor_type
use psb_error_mod
use psb_penv_mod
use psb_tools_mod, only : psb_cdcpy
use psb_realloc_mod
use psi_mod
use mpi
Implicit None
! .. Array Arguments ..
@@ -64,7 +66,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype)
integer, intent(out) :: info
integer, intent(in),optional :: extype
interface psb_icdasb
interface
subroutine psb_icdasb(desc_a,info,ext_hv)
use psb_descriptor_type
Type(psb_desc_type), intent(inout) :: desc_a
@@ -72,8 +74,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info, extype)
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
integer icomm, err_act
! .. Local Scalars ..
base/tools/psb_dspins.f90
+1 -22
View File
@@ -46,6 +46,7 @@
!
subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_tools_mod, psb_protect_name => psb_dspins
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
@@ -69,28 +70,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer, parameter :: relocsz=200
logical :: rebuild_
integer, allocatable :: ila(:),jla(:)
interface psb_cdins
subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla)
use psb_descriptor_type
implicit none
type(psb_desc_type), intent(inout) :: desc_a
integer, intent(in) :: nz,ia(:),ja(:)
integer, intent(out) :: info
integer, optional, intent(out) :: ila(:), jla(:)
end subroutine psb_cdins
end interface
interface psb_glob_to_loc
subroutine psb_glob_to_loc(x,desc_a,info,iact)
use psb_descriptor_type
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: x(:)
integer, intent(out) :: info
character, intent(in), optional :: iact
end subroutine psb_glob_to_loc
end interface
character(len=20) :: name, ch_err
info = 0
base/tools/psb_zcdovr.f90
+2 -4
View File
@@ -45,11 +45,11 @@
!
Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info, extype)
use psb_tools_mod, psb_protect_name => psb_zcdovr
use psb_serial_mod
use psb_descriptor_type
use psb_error_mod
use psb_penv_mod
use psb_tools_mod, only : psb_cdcpy
use psb_realloc_mod
use psi_mod
use mpi
@@ -63,7 +63,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info, extype)
integer, intent(out) :: info
integer, intent(in),optional :: extype
interface psb_icdasb
interface
subroutine psb_icdasb(desc_a,info,ext_hv)
use psb_descriptor_type
Type(psb_desc_type), intent(inout) :: desc_a
@@ -71,8 +71,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info, extype)
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
integer icomm, err_act
! .. Local Scalars ..
base/tools/psb_zspins.f90
+1 -22
View File
@@ -46,13 +46,13 @@
!
subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_tools_mod, psb_protect_name => psb_zspins
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_tools_mod
implicit none
!....parameters...
@@ -71,27 +71,6 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
logical :: rebuild_
integer, allocatable :: ila(:),jla(:)
!!$ interface psb_cdins
!!$ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla)
!!$ use psb_descriptor_type
!!$ implicit none
!!$ type(psb_desc_type), intent(inout) :: desc_a
!!$ integer, intent(in) :: nz,ia(:),ja(:)
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(out) :: ila(:), jla(:)
!!$ end subroutine psb_cdins
!!$ end interface
!!$
!!$ interface psb_glob_to_loc
!!$ subroutine psb_glob_to_loc(x,desc_a,info,iact)
!!$ use psb_descriptor_type
!!$ implicit none
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ integer, intent(inout) :: x(:)
!!$ integer, intent(out) :: info
!!$ character, intent(in), optional :: iact
!!$ end subroutine psb_glob_to_loc
!!$ end interface
character(len=20) :: name, ch_err
info = 0
prec/Makefile
+2 -2
View File
@@ -3,12 +3,12 @@ include ../Make.inc
LIBDIR=../lib
HERE=.
MODOBJS= psb_prec_type.o psb_prec_mod.o
F90OBJS= psb_dilu_bld.o psb_dilu_fct.o\
F90OBJS= psb_dbjac_bld.o psb_dilu_fct.o\
psb_dprecbld.o psb_dprecset.o \
psb_ddiagsc_bld.o \
psb_dprc_aply.o \
psb_dgprec_aply.o psb_dbjac_aply.o\
psb_zilu_bld.o psb_zilu_fct.o\
psb_zbjac_bld.o psb_zilu_fct.o\
psb_zprecbld.o psb_zprecset.o \
psb_zdiagsc_bld.o \
psb_zprc_aply.o psb_zgprec_aply.o psb_zbjac_aply.o
prec/psb_dbjac_bld.f90
+236
View File
@@ -0,0 +1,236 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, psb_protect_name => psb_dbjac_bld
implicit none
!
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. array Arguments ..
type(psb_dspmat_type), intent(in), target :: a
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
! .. Local Scalars ..
integer :: i, j, jj, k, kk, m
integer :: int_err(5)
character :: trans, unitd
type(psb_dspmat_type) :: blck, atmp
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6, t7, t8
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dbjac_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
m = a%m
if (m < 0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
trans = 'N'
unitd = 'U'
call psb_nullify_sp(atmp)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
if (allocated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then
do i=1,size(p%av)
call psb_sp_free(p%av(i),info)
if (info /= 0) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
enddo
deallocate(p%av,stat=info)
endif
end if
if (.not.allocated(p%av)) then
allocate(p%av(max_avsz),stat=info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a)
if (debug) write(0,*)me,': out get_nnzeros',nztota
if (debug) call psb_barrier(ictxt)
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(l_pr_)%m = n_row
p%av(l_pr_)%k = n_row
p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota,info)
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota,info)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
t3 = psb_wtime()
! This is where we have mo renumbering, thus no need
! for ATMP
if (debugprt) then
open(40+me)
call psb_barrier(ictxt)
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix')
close(40+me)
endif
t5= psb_wtime()
if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call psb_barrier(ictxt)
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug) write(0,*) me,' Done dilu_fct'
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
do i=1,p%av(l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
close(80+me)
end if
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
t6 = psb_wtime()
!
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
endif
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
endif
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
if (debug) write(0,*) me,'End of ilu_bld'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dbjac_bld
prec/psb_dilu_bld.f90
-195
View File
@@ -1,195 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dilu_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, psb_protect_name => psb_dilu_bld
implicit none
!
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. array Arguments ..
type(psb_dspmat_type), intent(in), target :: a
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
! .. Local Scalars ..
integer :: i, j, jj, k, kk, m
integer :: int_err(5)
character :: trans, unitd
type(psb_dspmat_type) :: blck, atmp
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6, t7, t8
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dilu_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
m = a%m
if (m < 0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
trans = 'N'
unitd = 'U'
call psb_nullify_sp(atmp)
if (allocated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then
call psb_errpush(4010,name,a_err='Insufficient av size')
goto 9999
endif
else
call psb_errpush(4010,name,a_err='AV not associated')
goto 9999
endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a)
if (debug) write(0,*)me,': out get_nnzeros',nztota
if (debug) call psb_barrier(ictxt)
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(l_pr_)%m = n_row
p%av(l_pr_)%k = n_row
p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota,info)
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota,info)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
t3 = psb_wtime()
! This is where we have mo renumbering, thus no need
! for ATMP
if (debugprt) then
open(40+me)
call psb_barrier(ictxt)
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix')
close(40+me)
endif
t5= psb_wtime()
if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call psb_barrier(ictxt)
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug) write(0,*) me,' Done dilu_fct'
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
do i=1,p%av(l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
close(80+me)
end if
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
t6 = psb_wtime()
!
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
endif
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
endif
if (debug) write(0,*) me,'End of ilu_bld'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dilu_bld
prec/psb_dprecbld.f90
+4 -39
View File
@@ -117,50 +117,15 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) write(0,*)me, ': Calling PSB_BJAC_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
call psb_bjac_bld(a,desc_a,p,iupd,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(4010,name,a_err='psb_bjac_bld')
goto 9999
end if
allocate(p%av(max_avsz),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld',info
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='Unknown p_type_'
prec/psb_prec_mod.f90
+5 -5
View File
@@ -167,8 +167,8 @@ module psb_prec_mod
end subroutine psb_zilu_fct
end interface
interface psb_ilu_bld
subroutine psb_dilu_bld(a,desc_a,p,upd,info)
interface psb_bjac_bld
subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
@@ -176,8 +176,8 @@ module psb_prec_mod
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
end subroutine psb_dilu_bld
subroutine psb_zilu_bld(a,desc_a,p,upd,info)
end subroutine psb_dbjac_bld
subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
@@ -185,7 +185,7 @@ module psb_prec_mod
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
end subroutine psb_zilu_bld
end subroutine psb_zbjac_bld
end interface
interface psb_diagsc_bld
prec/psb_zbjac_bld.f90
+236
View File
@@ -0,0 +1,236 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, psb_protect_name => psb_zbjac_bld
implicit none
!
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. array Arguments ..
type(psb_zspmat_type), intent(in), target :: a
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
! .. Local Scalars ..
integer :: i, j, jj, k, kk, m
integer :: int_err(5)
character :: trans, unitd
type(psb_zspmat_type) :: blck, atmp
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6, t7, t8
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zbjac_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
m = a%m
if (m < 0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
trans = 'N'
unitd = 'U'
call psb_nullify_sp(atmp)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
if (allocated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then
do i=1,size(p%av)
call psb_sp_free(p%av(i),info)
if (info /= 0) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
enddo
deallocate(p%av,stat=info)
endif
end if
if (.not.allocated(p%av)) then
allocate(p%av(max_avsz),stat=info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a)
if (debug) write(0,*)me,': out get_nnzeros',nztota
if (debug) call psb_barrier(ictxt)
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(l_pr_)%m = n_row
p%av(l_pr_)%k = n_row
p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota,info)
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota,info)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
t3 = psb_wtime()
! This is where we have mo renumbering, thus no need
! for ATMP
if (debugprt) then
open(40+me)
call psb_barrier(ictxt)
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix')
close(40+me)
endif
t5= psb_wtime()
if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call psb_barrier(ictxt)
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug) write(0,*) me,' Done dilu_fct'
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
do i=1,p%av(l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
close(80+me)
end if
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
t6 = psb_wtime()
!
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
endif
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
endif
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
if (debug) write(0,*) me,'End of ilu_bld'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zbjac_bld
prec/psb_zilu_bld.f90
-197
View File
@@ -1,197 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zilu_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, psb_protect_name => psb_zilu_bld
implicit none
!
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. array Arguments ..
type(psb_zspmat_type), intent(in), target :: a
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
! .. Local Scalars ..
integer :: i, j, jj, k, kk, m
integer :: int_err(5)
character :: trans, unitd
type(psb_zspmat_type) :: blck, atmp
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6, t7, t8
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false.
integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,&
& n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zilu_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
m = a%m
if (m < 0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
trans = 'N'
unitd = 'U'
call psb_nullify_sp(atmp)
if (allocated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then
call psb_errpush(4010,name,a_err='Insufficient av size')
goto 9999
endif
else
call psb_errpush(4010,name,a_err='AV not associated')
goto 9999
endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a)
if (debug) write(0,*)me,': out get_nnzeros',nztota
if (debug) call psb_barrier(ictxt)
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(l_pr_)%m = n_row
p%av(l_pr_)%k = n_row
p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota,info)
if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota,info)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
t3 = psb_wtime()
! This is where we have mo renumbering, thus no need
! for ATMP
if (debugprt) then
open(40+me)
call psb_barrier(ictxt)
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix')
close(40+me)
endif
t5= psb_wtime()
if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call psb_barrier(ictxt)
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug) write(0,*) me,' Done dilu_fct'
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(l_pr_)%m
do i=1,p%av(l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(u_pr_),head='% Local U factor')
close(80+me)
endif
! ierr = MPE_Log_event( ifcte, 0, "st SIMPLE" )
t6 = psb_wtime()
!
! write(0,'(i3,1x,a,3(1x,g18.9))') me,'renum/factor time',t3-t2,t6-t5
! if (me==0) write(0,'(a,3(1x,g18.9))') 'renum/factor time',t3-t2,t6-t5
if (psb_sp_getifld(psb_upd_,p%av(u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(u_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(u_pr_),i1,i2,ia,info)
endif
if (psb_sp_getifld(psb_upd_,p%av(l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trimsize(p%av(l_pr_),i1,i2,ia,info)
if (info == 0) call psb_sp_reall(p%av(l_pr_),i1,i2,ia,info)
endif
if (debug) write(0,*) me,'End of ilu_bld'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zilu_bld
prec/psb_zprecbld.f90
+5 -41
View File
@@ -50,8 +50,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
integer :: int_err(5)
character :: iupd
logical, parameter :: debug=.false.
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err
@@ -120,50 +119,15 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) write(0,*)me, ': Calling PSB_BJAC_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
call psb_bjac_bld(a,desc_a,p,iupd,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(4010,name,a_err='psb_bjac_bld')
goto 9999
end if
allocate(p%av(max_avsz),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='Unknown p_type_'