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

*** empty log message ***

Browse Source
This commit is contained in:
Alfredo Buttari
2005-09-14 18:22:35 +00:00
parent 9323d3a7f4
commit cd656f8f4b
23 changed files with 204 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Make.inc
+2 -2
View File
@@ -10,8 +10,8 @@ F90=ifort
FC=ifort
CC=icc
F77=$(FC)
F90COPT= -check arg_temp_created
FCOPT=-check arg_temp_created
F90COPT= -check all -g -CB -no_cpprt
FCOPT=-check all -g -CB -no_cpprt
CCOPT=
####################### Section 2 #######################
src/comm/psb_dhalo.f90
+29 -7
View File
@@ -69,7 +69,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
n = desc_a%matrix_data(psb_n_)
nrow = desc_a%matrix_data(psb_n_row_)
maxk=size(x,2)-jx+1
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik.gt.maxk) then
@@ -118,8 +118,18 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
@@ -147,7 +157,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if
if(info.ne.0) then
call psb_errpush(4010,name,a_err='PSI_dSwap...')
ch_err='PSI_dSwap...'
call psb_errpush(4010,name,a_err=ch_err)
goto 9999
end if
@@ -266,8 +277,18 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
end if
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
@@ -288,7 +309,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
end if
if(info.ne.0) then
call psb_errpush(4010,name,a_err='PSI_dSwap...')
ch_err='PSI_dSwap...'
call psb_errpush(4010,name,a_err=ch_err)
goto 9999
end if
src/comm/psb_dovrl.f90
+24 -4
View File
@@ -112,8 +112,18 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,choice,update_type)
! check for presence/size of a work area
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
@@ -279,8 +289,18 @@ subroutine psb_dovrlv(x,desc_a,info,work,choice,update_type)
! check for presence/size of a work area
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
src/comm/psb_ihalo.f90
+25 -4
View File
@@ -1,3 +1,4 @@
! File: psb_ihalo.f90
!
! Subroutine: psb_ihalom
@@ -120,8 +121,18 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
!!$ end if
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
@@ -262,8 +273,18 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
!!$ end if
liwork=ncol
if (present(work).and.(size(work).ge.liwork)) then
iwork => work
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
src/internals/psi_crea_index.f90
+34 -4
View File
@@ -8,7 +8,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer, intent(in) :: index_in(:)
integer, intent(out) :: index_out(:)
integer, pointer :: index_out(:)
logical :: glob_idx
! ....local scalars...
@@ -21,6 +21,32 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
logical,parameter :: debug=.false.
character(len=20) :: name, ch_err
interface
subroutine psi_compute_size(desc_data,&
& index_in, dl_lda, info)
integer :: info, dl_lda
integer :: desc_data(:), index_in(:)
end subroutine psi_compute_size
end interface
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_desc_index(desc_data,index_in,dep_list,&
& length_dl,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,pointer :: desc_index(:)
integer :: length_dl, info
logical :: isglob_in
end subroutine psi_desc_index
end interface
info = 0
name='psi_crea_index'
call psb_erractionsave(err_act)
@@ -40,7 +66,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! allocate dependency list
call psi_compute_size(desc_a%matrix_data, index_in, dl_lda, info)
allocate(dep_list(dl_lda,0:np-1),length_dl(0:np-1))
allocate(dep_list(max(1,dl_lda),0:np-1),length_dl(0:np-1))
! ...extract dependence list (ordered list of identifer process
! which every process must communcate with...
if (debug) write(*,*) 'crea_halo: calling extract_dep_list'
@@ -70,9 +96,13 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! ...create desc_halo array.....
if(debug) write(0,*)'in psi_crea_index calling psi_desc_index',&
& size(index_out)
call psi_desc_index(desc_a%matrix_data,index_in,dep_list(1,me),&
call psi_desc_index(desc_a%matrix_data,index_in,dep_list(1:,me),&
& length_dl(me),desc_a%loc_to_glob,desc_a%glob_to_loc,&
& index_out,glob_idx)
& index_out,glob_idx,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_desc_index')
goto 9999
end if
deallocate(dep_list,length_dl)
call psb_erractionrestore(err_act)
src/internals/psi_dl_check.f90
+1 -1
View File
@@ -3,7 +3,7 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl)
use psb_const_mod
implicit none
integer :: np,dl_lda,length_dl(:)
integer :: np,dl_lda,length_dl(0:np)
integer :: dep_list(dl_lda,0:np-1)
! locals
integer :: proc, proc2, i, j
src/methd/Makefile
+1 -1
View File
@@ -20,6 +20,6 @@ veryclean: clean
/bin/rm -f $(LIBNAME)
clean:
/bin/rm -f $(F90OBJS) $(LOCAL_MODS)
/bin/rm -f $(OBJS) $(LOCAL_MODS)
veryclean: clean
src/modules/psb_desc_type.f90
+7 -6
View File
@@ -8,6 +8,7 @@
module psb_descriptor_type
use psb_const_mod
implicit none
! desc_type contains data for communications.
type psb_desc_type
@@ -47,35 +48,35 @@ contains
logical function psb_is_ok_dec(dectype)
integer :: dectype
psb_is_ok_dec = ((dectype == desc_asb).or.(dectype == desc_bld).or.&
&(dectype == desc_upd).or.(dectype== desc_upd_asb))
psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.&
&(dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_))
end function psb_is_ok_dec
logical function psb_is_bld_dec(dectype)
integer :: dectype
psb_is_bld_dec = (dectype == desc_bld)
psb_is_bld_dec = (dectype == psb_desc_bld_)
end function psb_is_bld_dec
logical function psb_is_upd_dec(dectype)
integer :: dectype
psb_is_upd_dec = (dectype == desc_upd)
psb_is_upd_dec = (dectype == psb_desc_upd_)
end function psb_is_upd_dec
logical function psb_is_asb_upd_dec(dectype)
integer :: dectype
psb_is_asb_upd_dec = (dectype == desc_upd_asb)
psb_is_asb_upd_dec = (dectype == psb_desc_upd_asb_)
end function psb_is_asb_upd_dec
logical function psb_is_asb_dec(dectype)
integer :: dectype
psb_is_asb_dec = (dectype == desc_asb)
psb_is_asb_dec = (dectype == psb_desc_asb_)
end function psb_is_asb_dec
src/modules/psb_error_mod.f90
+2 -2
View File
@@ -113,8 +113,8 @@ contains
subroutine psb_errpush(err_c, r_name, i_err, a_err)
integer, intent(in) :: err_c
character(len=20), intent(in) :: r_name
character(len=20), optional :: a_err
character(len=*), intent(in) :: r_name
character(len=*), optional :: a_err
integer, optional :: i_err(5)
type(psb_errstack_node), pointer :: new_node
src/modules/psi_mod.f90
+1 -1
View File
@@ -26,7 +26,7 @@ module psi_mod
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer, intent(in) :: index_in(:)
integer, intent(out) :: index_out(:)
integer, pointer :: index_out(:)
logical :: glob_idx
end subroutine psi_crea_index
end interface
src/prec/psb_dprec.f90
+61
View File
@@ -23,6 +23,35 @@ subroutine psb_dprecaply(prec,x,y,desc_data,info,trans, work)
real(kind(1.d0)), parameter :: one=1.d0, zero=0.d0
external mpi_wtime
character(len=20) :: name, ch_err
interface
subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type
use psb_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbase_prec), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: beta
character(len=1) :: trans
real(kind(0.d0)),target :: work(:)
integer, intent(out) :: info
end subroutine psb_dbaseprcaply
end interface
interface
subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type
use psb_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbase_prec), intent(in) :: baseprecv(:)
real(kind(0.d0)),intent(in) :: beta
real(kind(0.d0)),intent(inout) :: x(:), y(:)
character :: trans
real(kind(0.d0)),target :: work(:)
integer, intent(out) :: info
end subroutine psb_dmlprcaply
end interface
name='psb_dprecaply'
info = 0
call psb_erractionsave(err_act)
@@ -111,6 +140,20 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
external mpi_wtime
character(len=20) :: name, ch_err
interface
subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type
use psb_prec_type
type(psb_desc_type), intent(in) :: desc_data
type(psb_dbase_prec), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: beta
character(len=1) :: trans
real(kind(0.d0)),target :: work(:)
integer, intent(out) :: info
end subroutine psb_dbjacaply
end interface
name='psb_dbaseprcaply'
info = 0
call psb_erractionsave(err_act)
@@ -161,6 +204,7 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
case(bja_)
write(0,*)'calling bja'
call psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
info=4010
@@ -330,6 +374,8 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
real(kind(1.d0)), parameter :: one=1.d0, zero=0.d0
external mpi_wtime
character(len=20) :: name, ch_err
write(0,*)'inside bja'
name='psb_dbjacaply'
info = 0
call psb_erractionsave(err_act)
@@ -543,6 +589,21 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
integer :: ismth
external mpi_wtime
character(len=20) :: name, ch_err
interface
subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type
use psb_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbase_prec), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: beta
character(len=1) :: trans
real(kind(0.d0)),target :: work(:)
integer, intent(out) :: info
end subroutine psb_dbaseprcaply
end interface
name='psb_dmlprcaply'
info = 0
call psb_erractionsave(err_act)
src/psblas/Makefile
+1 -1
View File
@@ -21,6 +21,6 @@ veryclean: clean
/bin/rm -f $(LIBNAME)
clean:
/bin/rm -f $(F90_PSDOBJS) $(LOCAL_MODS)
/bin/rm -f $(OBJS) $(LOCAL_MODS)
veryclean: clean
src/psblas/psb_dspmm.f90
+1
View File
@@ -419,6 +419,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
iy = 1
jy = 1
ik = 1
ib = 1
if (present(doswap)) then
idoswap = doswap
src/serial/coo/dcoomm.f
+1 -1
View File
@@ -22,7 +22,7 @@ C .. Local Scalars ..
C .. External Subroutines ..
EXTERNAL DCOOMV, XSPERR
EXTERNAL DCOOMV
C .. Executable Statements ..
C
C
src/serial/coo/dcoosm.f
-1
View File
@@ -11,7 +11,6 @@
CHARACTER DESCRA*11
INTEGER I, K, ERR_ACT
CHARACTER DIAG, UPLO
EXTERNAL XERBLA
INTRINSIC DBLE, IDINT
CHARACTER*20 NAME
src/serial/csr/dcsrck.f
-2
View File
@@ -68,8 +68,6 @@ C .. Array Arguments ..
CHARACTER DESCRA*11
C .. Local Scalars ..
INTEGER I, J, nrow, nind
C .. External Subroutines ..
EXTERNAL XERBLA
C
C .. Executable Statements ..
C
src/serial/f77/dcsmm.f
+1 -1
View File
@@ -180,7 +180,7 @@ C .. Local Array..
DOUBLE PRECISION REAL_VAL(5)
CHARACTER*30 STRINGS(2)
C .. External Subroutines ..
EXTERNAL DSWMM, DLPUPD, DSCAL, XERBLA
EXTERNAL DSWMM, DLPUPD, DSCAL
C .. Intrinsic Functions ..
INTRINSIC DBLE, IDINT
src/serial/f77/dcsrp.f
+1 -1
View File
@@ -99,7 +99,7 @@ C .. Array Arguments ..
INTEGER IA1(*), IA2(*), INFOA(*), P(*), INT_VAL(5)
CHARACTER DESCRA*11, FIDA*5
C .. External Subroutines ..
EXTERNAL DCSRRP, XERBLA
EXTERNAL DCSRRP
logical debug
parameter (debug=.false.)
src/serial/f77/dcssm.f
+1 -1
View File
@@ -188,7 +188,7 @@ C .. Parameters ..
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
C .. External Subroutines ..
EXTERNAL DSWSM, DLPUPD, XERBLA
EXTERNAL DSWSM, DLPUPD
C .. Intrinsic Functions ..
INTRINSIC DBLE, IDINT
C .. Executable Statements ..
src/serial/psb_cest.f90
+2 -2
View File
@@ -19,7 +19,7 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info)
afmt = psb_fidef_
endif
if (up.eq.'y') then
if ((up.eq.'y').or.(up.eq.'Y')) then
if (afmt.eq.'JAD') then
lia1 = 2*(nnz + nnz/5) +1000
lia2 = 2*(nnz + nnz/5) +1000
@@ -38,7 +38,7 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info)
goto 9999
endif
else if (up.eq.'n') then
else if ((up.eq.'n').or.(up.eq.'N')) then
if (afmt.eq.'JAD') then
lia1 = nnz + nnz/5
src/tools/psb_dallc.f90
+2
View File
@@ -34,6 +34,7 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
integer, allocatable:: prc_v(:)
character(len=20) :: name, ch_err
name='psb_dallc'
info=0
err=0
int_err(1)=0
@@ -193,6 +194,7 @@ subroutine psb_dallocv(m, x, desc_a,info)
character(len=20) :: name, ch_err
info=0
name='psb_dallcv'
call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_)
test/pargen/RUNS/ppde.inp
+3 -3
View File
@@ -1,11 +1,11 @@
7 Number of entries below this
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL
ILU Preconditioner ILU DIAGSC NONE
SSR A Storage format CSR COO JAD
NONE Preconditioner ILU DIAGSC NONE
CSR A Storage format CSR COO JAD
20 Domain size (acutal sistem is this**3)
1 Stopping criterion
080 MAXIT
00 ITRACE
-1 ITRACE
02 ML
test/pargen/ppde90.f90
+4 -4
View File
@@ -184,7 +184,7 @@ program pde90
!
! iterative method parameters
!
write(*,*) 'calling iterative method', size(b),ml
write(*,*) 'calling iterative method', a%ia2(7999:8001)
call blacs_barrier(icontxt,'ALL')
t1 = mpi_wtime()
eps = 1.d-9
@@ -454,12 +454,12 @@ contains
nnz = ((n*9)/(nprow*npcol))
write(*,*) 'size: n ',n
call psb_dscall(n,n,parts,icontxt,desc_a,info)
write(*,*) 'allocating a : nnz',nnz
write(*,*) 'allocating a : nnz',nnz, info
call psb_spalloc(a,desc_a,info,nnz=nnz)
! define rhs from boundary conditions; also build initial guess
write(*,*) 'allocating b'
write(*,*) 'allocating b', info
call psb_alloc(n,b,desc_a,info)
write(*,*) 'allocating t'
write(*,*) 'allocating t', info
call psb_alloc(n,t,desc_a,info)
if(info.ne.0) then
info=4010