mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-24 23:01:48 +00:00
psblas2-dev:
Make.inc.in README base/comm/Makefile base/comm/psb_cgather.f90 base/comm/psb_chalo.f90 base/comm/psb_covrl.f90 base/comm/psb_sgather.f90 base/comm/psb_shalo.f90 base/comm/psb_sovrl.f90 base/internals/Makefile base/internals/psi_cswapdata.F90 base/internals/psi_cswaptran.F90 base/internals/psi_sswapdata.F90 base/internals/psi_sswaptran.F90 base/modules/Makefile base/modules/psb_blacs_mod.f90 base/modules/psb_comm_mod.f90 base/modules/psb_const_mod.f90 base/modules/psb_error_mod.F90 base/modules/psb_inter_desc_type.f90 base/modules/psb_penv_mod.F90 base/modules/psb_psblas_mod.f90 base/modules/psb_realloc_mod.F90 base/modules/psb_serial_mod.f90 base/modules/psb_sort_mod.f90 base/modules/psb_spmat_type.f90 base/modules/psb_spsb_mod.f90 base/modules/psb_string_mod.f90 base/modules/psb_tools_mod.f90 base/modules/psi_mod.f90 base/modules/psi_serial_mod.f90 base/psblas/Makefile base/psblas/psb_camax.f90 base/psblas/psb_casum.f90 base/psblas/psb_caxpby.f90 base/psblas/psb_cdot.f90 base/psblas/psb_cnrm2.f90 base/psblas/psb_cnrmi.f90 base/psblas/psb_cspmm.f90 base/psblas/psb_cspsm.f90 base/psblas/psb_dnrmi.f90 base/psblas/psb_samax.f90 base/psblas/psb_sasum.f90 base/psblas/psb_saxpby.f90 base/psblas/psb_sdot.f90 base/psblas/psb_snrm2.f90 base/psblas/psb_snrmi.f90 base/psblas/psb_sspmm.f90 base/psblas/psb_sspsm.f90 base/psblas/psb_sxdot.f90 base/psblas/psb_zaxpby.f90 base/psblas/psb_znrmi.f90 base/psblas/pstreecomb.F base/serial/Makefile base/serial/aux/Makefile base/serial/aux/cacmp_mod.f90 base/serial/aux/calcmp_mod.f90 base/serial/aux/calsr.f90 base/serial/aux/calsrx.f90 base/serial/aux/camsort_dw.f90 base/serial/aux/camsort_up.f90 base/serial/aux/camsr.f90 base/serial/aux/camsrx.f90 base/serial/aux/casr.f90 base/serial/aux/casrx.f90 base/serial/aux/clcmp_mod.f90 base/serial/aux/clsr.f90 base/serial/aux/clsrx.f90 base/serial/aux/sasr.f90 base/serial/aux/sasrx.f90 base/serial/aux/smsort_dw.f90 base/serial/aux/smsort_up.f90 base/serial/aux/smsr.f90 base/serial/aux/smsrx.f90 base/serial/aux/ssr.f90 base/serial/aux/ssrx.f90 base/serial/coo/Makefile base/serial/coo/ccoomm.f base/serial/coo/ccoomv.f base/serial/coo/ccoonrmi.f base/serial/coo/ccoorws.f base/serial/coo/ccoosm.f base/serial/coo/ccoosv.f base/serial/coo/dcoosm.f base/serial/coo/scoomm.f base/serial/coo/scoomv.f base/serial/coo/scoonrmi.f base/serial/coo/scoorws.f base/serial/coo/scoosm.f base/serial/coo/scoosv.f base/serial/coo/zcoosm.f base/serial/csr/Makefile base/serial/csr/ccrnrmi.f base/serial/csr/ccsrck.f base/serial/csr/ccsrmm.f base/serial/csr/ccsrrws.f base/serial/csr/ccsrsm.f base/serial/csr/csrmv.f base/serial/csr/csrsv.f base/serial/csr/dcsrck.f base/serial/csr/dcsrmm.f base/serial/csr/dcsrmv.f base/serial/csr/dcsrmv2.f base/serial/csr/dcsrmv3.f base/serial/csr/dcsrmv4.f base/serial/csr/dcsrrws.f base/serial/csr/dcsrsm.f base/serial/csr/dcsrsv.f base/serial/csr/scrnrmi.f base/serial/csr/scsrmm.f base/serial/csr/scsrmv.f base/serial/csr/scsrmv2.f base/serial/csr/scsrmv3.f base/serial/csr/scsrmv4.f base/serial/csr/scsrsm.f base/serial/csr/scsrsv.f base/serial/csr/zcrnrmi.f base/serial/csr/zcsrck.f base/serial/csr/zcsrmm.f base/serial/csr/zcsrrws.f base/serial/csr/zcsrsm.f base/serial/csr/zsrmv.f base/serial/csr/zsrsv.f base/serial/dp/Makefile base/serial/dp/ccoco.f base/serial/dp/ccocr.f base/serial/dp/ccrco.f base/serial/dp/ccrcr.f base/serial/dp/ccrjd.f base/serial/dp/cgind_tri.f base/serial/dp/cgindex.f base/serial/dp/reordvn.f base/serial/dp/scoco.f base/serial/dp/scocr.f base/serial/dp/scrco.f base/serial/dp/scrcr.f base/serial/dp/scrjd.f base/serial/dp/sgind_tri.f base/serial/dp/sgindex.f base/serial/f77/Makefile base/serial/f77/caxpby.f base/serial/f77/ccsmm.f base/serial/f77/ccsnmi.f base/serial/f77/ccsrws.f base/serial/f77/ccssm.f base/serial/f77/cgelp.f base/serial/f77/clpupd.f base/serial/f77/cswmm.f base/serial/f77/cswsm.f base/serial/f77/daxpby.f base/serial/f77/dcsmm.f base/serial/f77/dcsnmi.f base/serial/f77/dcsrp.f base/serial/f77/dcsrws.f base/serial/f77/dcssm.f base/serial/f77/dgelp.f base/serial/f77/dlpupd.f base/serial/f77/dswmm.f base/serial/f77/dswsm.f base/serial/f77/saxpby.f base/serial/f77/scsmm.f base/serial/f77/scsnmi.f base/serial/f77/scsrws.f base/serial/f77/scssm.f base/serial/f77/sgelp.f base/serial/f77/slpupd.f base/serial/f77/smmp.f base/serial/f77/sswmm.f base/serial/f77/sswsm.f base/serial/f77/zcsmm.f base/serial/f77/zcsnmi.f base/serial/f77/zcsrws.f base/serial/f77/zcssm.f base/serial/f77/zgelp.f base/serial/f77/zlpupd.f base/serial/f77/zswmm.f base/serial/f77/zswsm.f base/serial/jad/Makefile base/serial/jad/sjadmm.f base/serial/jad/sjadmv.f base/serial/jad/sjadmv2.f base/serial/jad/sjadmv3.f base/serial/jad/sjadmv4.f base/serial/jad/sjadnr.f base/serial/jad/sjadrws.f base/serial/jad/sjadsm.f base/serial/jad/sjadsv.f base/serial/jad/sjdnrmi.f base/serial/jad/sjdrws.f base/serial/psb_ccoins.f90 base/serial/psb_ccsmm.f90 base/serial/psb_ccsmv.f90 base/serial/psb_ccsnmi.f90 base/serial/psb_ccsprt.f90 base/serial/psb_ccssm.f90 base/serial/psb_ccssv.f90 base/serial/psb_cfixcoo.f90 base/serial/psb_cgelp.f90 base/serial/psb_cipcoo2csc.f90 base/serial/psb_cipcoo2csr.f90 base/serial/psb_cipcsr2coo.f90 base/serial/psb_cneigh.f90 base/serial/psb_cnumbmm.f90 base/serial/psb_crwextd.f90 base/serial/psb_cspclip.f90 base/serial/psb_cspcnv.f90 base/serial/psb_cspgetrow.f90 base/serial/psb_cspgtblk.f90 base/serial/psb_cspgtdiag.f90 base/serial/psb_cspscal.f90 base/serial/psb_csymbmm.f90 base/serial/psb_ctransc.f90 base/serial/psb_ctransp.f90 base/serial/psb_dcoins.f90 base/serial/psb_dspcnv.f90 base/serial/psb_getrow_mod.f90 base/serial/psb_regen_mod.f90 base/serial/psb_scoins.f90 base/serial/psb_scsmm.f90 base/serial/psb_scsmv.f90 base/serial/psb_scsnmi.f90 base/serial/psb_scsprt.f90 base/serial/psb_scssm.f90 base/serial/psb_scssv.f90 base/serial/psb_sfixcoo.f90 base/serial/psb_sgelp.f90 base/serial/psb_sipcoo2csc.f90 base/serial/psb_sipcoo2csr.f90 base/serial/psb_sipcsr2coo.f90 base/serial/psb_sneigh.f90 base/serial/psb_snumbmm.f90 base/serial/psb_srwextd.f90 base/serial/psb_sspclip.f90 base/serial/psb_sspcnv.f90 base/serial/psb_sspgetrow.f90 base/serial/psb_sspgtblk.f90 base/serial/psb_sspgtdiag.f90 base/serial/psb_sspscal.f90 base/serial/psb_ssymbmm.f90 base/serial/psb_stransp.f90 base/serial/psb_update_mod.f90 base/serial/psb_zcoins.f90 base/serial/psb_zcsnmi.f90 base/serial/psb_zspcnv.f90 base/tools/Makefile base/tools/psb_callc.f90 base/tools/psb_casb.f90 base/tools/psb_ccdbldext.F90 base/tools/psb_cfree.f90 base/tools/psb_cins.f90 base/tools/psb_cspalloc.f90 base/tools/psb_cspasb.f90 base/tools/psb_cspfree.f90 base/tools/psb_csphalo.F90 base/tools/psb_cspins.f90 base/tools/psb_csprn.f90 base/tools/psb_dspins.f90 base/tools/psb_sallc.f90 base/tools/psb_sasb.f90 base/tools/psb_scdbldext.F90 base/tools/psb_sfree.f90 base/tools/psb_sins.f90 base/tools/psb_sspalloc.f90 base/tools/psb_sspasb.f90 base/tools/psb_sspfree.f90 base/tools/psb_ssphalo.F90 base/tools/psb_sspins.f90 base/tools/psb_ssprn.f90 base/tools/psb_zspins.f90 config/acx_lapack.m4 configure.ac configure krylov/Makefile krylov/psb_cbicg.f90 krylov/psb_ccg.f90 krylov/psb_ccgs.f90 krylov/psb_ccgstab.f90 krylov/psb_ccgstabl.f90 krylov/psb_crgmres.f90 krylov/psb_dcg.F90 krylov/psb_dcg.f90 krylov/psb_krylov_mod.f90 krylov/psb_sbicg.f90 krylov/psb_scg.F90 krylov/psb_scgs.f90 krylov/psb_scgstab.F90 krylov/psb_scgstabl.f90 krylov/psb_srgmres.f90 krylov/psb_zcg.F90 krylov/psb_zcg.f90 prec/Makefile prec/psb_cbjac_aply.f90 prec/psb_cbjac_bld.f90 prec/psb_cdiagsc_bld.f90 prec/psb_cgprec_aply.f90 prec/psb_cilu_fct.f90 prec/psb_cprc_aply.f90 prec/psb_cprecbld.f90 prec/psb_cprecinit.f90 prec/psb_cprecset.f90 prec/psb_prec_mod.f90 prec/psb_prec_type.f90 prec/psb_sbjac_aply.f90 prec/psb_sbjac_bld.f90 prec/psb_sdiagsc_bld.f90 prec/psb_sgprec_aply.f90 prec/psb_silu_fct.f90 prec/psb_sprc_aply.f90 prec/psb_sprecbld.f90 prec/psb_sprecinit.f90 prec/psb_sprecset.f90 test/fileread/Makefile test/fileread/cf_sample.f90 test/fileread/df_sample.f90 test/fileread/getp.f90 test/fileread/runs/cfs.inp test/fileread/runs/sfs.inp test/fileread/sf_sample.f90 test/fileread/zf_sample.f90 test/pargen/Makefile test/pargen/ppde.f90 test/pargen/runs/ppde.inp test/pargen/spde.f90 util/psb_hbio_mod.f90 util/psb_mat_dist_mod.f90 util/psb_mmio_mod.f90 util/psb_read_mat_mod.f90 Merged the single precision branch.
This commit is contained in:
Salvatore Filippone
+12
-4
@@ -8,26 +8,34 @@ LDLIBS=$(PSBLDLIBS)
|
||||
|
||||
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG).
|
||||
|
||||
SFOBJS=getp.o sf_sample.o
|
||||
DFOBJS=getp.o df_sample.o
|
||||
CFOBJS=getp.o cf_sample.o
|
||||
ZFOBJS=getp.o zf_sample.o
|
||||
|
||||
EXEDIR=./runs
|
||||
|
||||
all: df_sample zf_sample
|
||||
all: sf_sample df_sample cf_sample zf_sample
|
||||
|
||||
|
||||
sf_sample: $(SFOBJS)
|
||||
$(F90LINK) $(LOPT) $(SFOBJS) -o sf_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv sf_sample $(EXEDIR)
|
||||
df_sample: $(DFOBJS)
|
||||
$(F90LINK) $(DFOBJS) -o df_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
$(F90LINK) $(LOPT) $(DFOBJS) -o df_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv df_sample $(EXEDIR)
|
||||
cf_sample: $(CFOBJS)
|
||||
$(F90LINK) $(LOPT) $(CFOBJS) -o cf_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv cf_sample $(EXEDIR)
|
||||
zf_sample: $(ZFOBJS)
|
||||
$(F90LINK) $(ZFOBJS) -o zf_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
$(F90LINK) $(LOPT) $(ZFOBJS) -o zf_sample $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv zf_sample $(EXEDIR)
|
||||
|
||||
.f90.o:
|
||||
$(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
|
||||
|
||||
clean:
|
||||
/bin/rm -f $(DFOBJS) $(ZFOBJS) \
|
||||
/bin/rm -f $(DFOBJS) $(ZFOBJS) $(SFOBJS)\
|
||||
*$(.mod) $(EXEDIR)/df_sample $(EXEDIR)/zf_sample
|
||||
|
||||
lib:
|
||||
|
||||
@@ -0,0 +1,291 @@
|
||||
!!$
|
||||
!!$ Parallel Sparse BLAS version 2.2
|
||||
!!$ (C) Copyright 2006/2007/2008
|
||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||
!!$
|
||||
!!$ Redistribution and use in source and binary forms, with or without
|
||||
!!$ modification, are permitted provided that the following conditions
|
||||
!!$ are met:
|
||||
!!$ 1. Redistributions of source code must retain the above copyright
|
||||
!!$ notice, this list of conditions and the following disclaimer.
|
||||
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
||||
!!$ notice, this list of conditions, and the following disclaimer in the
|
||||
!!$ documentation and/or other materials provided with the distribution.
|
||||
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
||||
!!$ not be used to endorse or promote products derived from this
|
||||
!!$ software without specific written permission.
|
||||
!!$
|
||||
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
program cf_sample
|
||||
use psb_base_mod
|
||||
use psb_prec_mod
|
||||
use psb_krylov_mod
|
||||
use psb_util_mod
|
||||
use getp
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file
|
||||
|
||||
! sparse matrices
|
||||
type(psb_cspmat_type) :: a, aux_a
|
||||
|
||||
! preconditioner data
|
||||
type(psb_cprec_type) :: prec
|
||||
|
||||
! dense matrices
|
||||
complex(psb_spk_), allocatable, target :: aux_b(:,:), d(:)
|
||||
complex(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), &
|
||||
& x_col_glob(:), r_col_glob(:)
|
||||
complex(psb_spk_), pointer :: b_col_glob(:)
|
||||
|
||||
! communications data structure
|
||||
type(psb_desc_type):: desc_a
|
||||
|
||||
integer :: ictxt, iam, np
|
||||
|
||||
! solver paramters
|
||||
integer :: iter, itmax, ierr, itrace, ircode, ipart,&
|
||||
& methd, istopc, irst,amatsize,precsize,descsize
|
||||
real(psb_spk_) :: err, eps
|
||||
|
||||
character(len=5) :: afmt
|
||||
character(len=20) :: name
|
||||
integer :: iparm(20)
|
||||
|
||||
! other variables
|
||||
integer :: i,info,j,m_problem
|
||||
integer :: internal, m,ii,nnzero
|
||||
real(psb_dpk_) :: t1, t2, tprec
|
||||
real(psb_spk_) :: r_amax, b_amax, scale,resmx,resmxp
|
||||
integer :: nrhs, nrow, n_row, dim, nv, ne
|
||||
integer, allocatable :: ivg(:), ipv(:)
|
||||
|
||||
|
||||
call psb_init(ictxt)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (iam < 0) then
|
||||
! This should not happen, but just in case
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
name='cf_sample'
|
||||
if(psb_get_errstatus() /= 0) goto 9999
|
||||
info=0
|
||||
call psb_set_errverbosity(2)
|
||||
!
|
||||
! get parameters
|
||||
!
|
||||
call get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,&
|
||||
& ipart,afmt,istopc,itmax,itrace,irst,eps)
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
! read the input matrix to be processed and (possibly) the rhs
|
||||
nrhs = 1
|
||||
|
||||
if (iam==psb_root_) then
|
||||
call read_mat(mtrx_file, aux_a, ictxt)
|
||||
|
||||
m_problem = aux_a%m
|
||||
call psb_bcast(ictxt,m_problem)
|
||||
|
||||
if(rhs_file /= 'NONE') then
|
||||
! reading an rhs
|
||||
call read_rhs(rhs_file,aux_b,ictxt)
|
||||
end if
|
||||
|
||||
if (psb_size(aux_b,dim=1)==m_problem) then
|
||||
! if any rhs were present, broadcast the first one
|
||||
write(0,'("Ok, got an rhs ")')
|
||||
b_col_glob =>aux_b(:,1)
|
||||
else
|
||||
write(*,'("Generating an rhs...")')
|
||||
write(*,'(" ")')
|
||||
call psb_realloc(m_problem,1,aux_b,ircode)
|
||||
if (ircode /= 0) then
|
||||
call psb_errpush(4000,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
b_col_glob => aux_b(:,1)
|
||||
do i=1, m_problem
|
||||
b_col_glob(i) = (1.d0,1.d0)
|
||||
enddo
|
||||
endif
|
||||
call psb_bcast(ictxt,b_col_glob(1:m_problem))
|
||||
else
|
||||
call psb_bcast(ictxt,m_problem)
|
||||
call psb_realloc(m_problem,1,aux_b,ircode)
|
||||
if (ircode /= 0) then
|
||||
call psb_errpush(4000,name)
|
||||
goto 9999
|
||||
endif
|
||||
b_col_glob =>aux_b(:,1)
|
||||
call psb_bcast(ictxt,b_col_glob(1:m_problem))
|
||||
end if
|
||||
|
||||
! switch over different partition types
|
||||
if (ipart == 0) then
|
||||
call psb_barrier(ictxt)
|
||||
if (iam==psb_root_) write(*,'("Partition type: block")')
|
||||
allocate(ivg(m_problem),ipv(np))
|
||||
do i=1,m_problem
|
||||
call part_block(i,m_problem,np,ipv,nv)
|
||||
ivg(i) = ipv(1)
|
||||
enddo
|
||||
call psb_matdist(aux_a, a, ivg, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
else if (ipart == 2) then
|
||||
if (iam==psb_root_) then
|
||||
write(*,'("Partition type: graph")')
|
||||
write(*,'(" ")')
|
||||
! write(0,'("Build type: graph")')
|
||||
call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np)
|
||||
endif
|
||||
call psb_barrier(ictxt)
|
||||
call distr_mtpart(psb_root_,ictxt)
|
||||
call getv_mtpart(ivg)
|
||||
call psb_matdist(aux_a, a, ivg, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
else
|
||||
if (iam==psb_root_) write(*,'("Partition type: block")')
|
||||
call psb_matdist(aux_a, a, part_block, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
end if
|
||||
|
||||
call psb_geall(x_col,desc_a,info)
|
||||
x_col(:) =0.0
|
||||
call psb_geasb(x_col,desc_a,info)
|
||||
call psb_geall(r_col,desc_a,info)
|
||||
r_col(:) =0.0
|
||||
call psb_geasb(r_col,desc_a,info)
|
||||
t2 = psb_wtime() - t1
|
||||
|
||||
|
||||
call psb_amx(ictxt, t2)
|
||||
|
||||
if (iam==psb_root_) then
|
||||
write(*,'(" ")')
|
||||
write(*,'("Time to read and partition matrix : ",es10.4)')t2
|
||||
write(*,'(" ")')
|
||||
end if
|
||||
|
||||
!
|
||||
|
||||
call psb_precinit(prec,ptype,info)
|
||||
|
||||
! building the preconditioner
|
||||
t1 = psb_wtime()
|
||||
call psb_precbld(a,desc_a,prec,info)
|
||||
tprec = psb_wtime()-t1
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_precbld')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call psb_amx(ictxt,tprec)
|
||||
|
||||
if(iam==psb_root_) then
|
||||
write(*,'("Preconditioner time: ",es10.4)')tprec
|
||||
write(*,'(" ")')
|
||||
end if
|
||||
|
||||
iparm = 0
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
|
||||
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
|
||||
call psb_barrier(ictxt)
|
||||
t2 = psb_wtime() - t1
|
||||
call psb_amx(ictxt,t2)
|
||||
call psb_geaxpby(cone,b_col,czero,r_col,desc_a,info)
|
||||
call psb_spmm(-cone,a,x_col,cone,r_col,desc_a,info)
|
||||
resmx = psb_genrm2(r_col,desc_a,info)
|
||||
resmxp = psb_geamax(r_col,desc_a,info)
|
||||
|
||||
amatsize = psb_sizeof(a)
|
||||
descsize = psb_sizeof(desc_a)
|
||||
precsize = psb_sizeof(prec)
|
||||
call psb_sum(ictxt,amatsize)
|
||||
call psb_sum(ictxt,descsize)
|
||||
call psb_sum(ictxt,precsize)
|
||||
if (iam==psb_root_) then
|
||||
call psb_prec_descr(6,prec)
|
||||
write(*,'("Matrix: ",a)')mtrx_file
|
||||
write(*,'("Computed solution on ",i8," processors")')np
|
||||
write(*,'("Iterations to convergence: ",i6)')iter
|
||||
write(*,'("Error estimate on exit : ",es10.4)') err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 : ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf : ",es10.4)')resmxp
|
||||
!!$ write(*,*)"Condition number : ",cond
|
||||
write(*,'("Total memory occupation for A: ",i10)')amatsize
|
||||
write(*,'("Total memory occupation for DESC_A: ",i10)')descsize
|
||||
write(*,'("Total memory occupation for PREC: ",i10)')precsize
|
||||
end if
|
||||
|
||||
allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr)
|
||||
if (ierr /= 0) then
|
||||
write(0,*) 'allocation error: no data collection'
|
||||
else
|
||||
call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
|
||||
call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_)
|
||||
if (iam==psb_root_) then
|
||||
write(0,'(" ")')
|
||||
write(0,'("Saving x on file")')
|
||||
write(20,*) 'matrix: ',mtrx_file
|
||||
write(20,*) 'computed solution on ',np,' processors.'
|
||||
write(20,*) 'iterations to convergence: ',iter
|
||||
write(20,*) 'error estimate (infinity norm) on exit:', &
|
||||
& ' ||r||/(||a||||x||+||b||) = ',err
|
||||
write(20,*) 'max residual = ',resmx, resmxp
|
||||
write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)'
|
||||
do i=1,m_problem
|
||||
write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i)
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
998 format(i8,6(1x,g11.5))
|
||||
993 format(i6,4(1x,e12.6))
|
||||
|
||||
|
||||
call psb_gefree(b_col, desc_a,info)
|
||||
call psb_gefree(x_col, desc_a,info)
|
||||
call psb_spfree(a, desc_a,info)
|
||||
call psb_precfree(prec,info)
|
||||
call psb_cdfree(desc_a,info)
|
||||
|
||||
9999 continue
|
||||
if(info /= 0) then
|
||||
call psb_error(ictxt)
|
||||
end if
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
|
||||
end program cf_sample
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
+12
-10
@@ -60,7 +60,7 @@ program df_sample
|
||||
! solver paramters
|
||||
integer :: iter, itmax, ierr, itrace, ircode, ipart,&
|
||||
& methd, istopc, irst,amatsize,precsize,descsize
|
||||
real(psb_dpk_) :: err, eps
|
||||
real(psb_dpk_) :: err, eps,cond
|
||||
|
||||
character(len=5) :: afmt
|
||||
character(len=20) :: name
|
||||
@@ -207,12 +207,13 @@ program df_sample
|
||||
write(*,'("Preconditioner time: ",es10.4)')tprec
|
||||
write(*,'(" ")')
|
||||
end if
|
||||
|
||||
cond = dzero
|
||||
iparm = 0
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
|
||||
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
|
||||
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,&
|
||||
& irst=irst,cond=cond)
|
||||
call psb_barrier(ictxt)
|
||||
t2 = psb_wtime() - t1
|
||||
|
||||
@@ -233,13 +234,14 @@ program df_sample
|
||||
write(*,'("Matrix: ",a)')mtrx_file
|
||||
write(*,'("Computed solution on ",i8," processors")')np
|
||||
write(*,'("Iterations to convergence: ",i6)')iter
|
||||
write(*,'("Error estimate on exit: ",f7.2)')err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 = ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf = ",es10.4)')resmxp
|
||||
write(*,'("Error estimate on exit : ",es10.4)') err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 : ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf : ",es10.4)')resmxp
|
||||
write(*,*)"Condition number : ",cond
|
||||
write(*,'("Total memory occupation for A: ",i10)')amatsize
|
||||
write(*,'("Total memory occupation for DESC_A: ",i10)')descsize
|
||||
write(*,'("Total memory occupation for PREC: ",i10)')precsize
|
||||
|
||||
+102
-3
@@ -30,13 +30,15 @@
|
||||
!!$
|
||||
!!$
|
||||
Module getp
|
||||
public get_parms
|
||||
interface get_parms
|
||||
module procedure get_dparms, get_sparms
|
||||
end interface
|
||||
|
||||
contains
|
||||
!
|
||||
! Get iteration parameters from the command line
|
||||
!
|
||||
subroutine get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,&
|
||||
subroutine get_dparms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,&
|
||||
& afmt,istopc,itmax,itrace,irst,eps)
|
||||
use psb_base_mod
|
||||
integer :: ictxt
|
||||
@@ -131,6 +133,103 @@ contains
|
||||
|
||||
end if
|
||||
|
||||
end subroutine get_parms
|
||||
end subroutine get_dparms
|
||||
|
||||
subroutine get_sparms(ictxt,mtrx_file,rhs_file,kmethd,ptype,ipart,&
|
||||
& afmt,istopc,itmax,itrace,irst,eps)
|
||||
use psb_base_mod
|
||||
integer :: ictxt
|
||||
character(len=40) :: kmethd, mtrx_file, rhs_file, ptype
|
||||
integer :: iret, istopc,itmax,itrace,ipart,irst
|
||||
character(len=40) :: charbuf
|
||||
real(psb_spk_) :: eps
|
||||
character :: afmt*5
|
||||
integer :: np, iam
|
||||
integer :: inparms(40), ip
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
if (iam==0) then
|
||||
! Read Input Parameters
|
||||
read(*,*) ip
|
||||
if (ip >= 5) then
|
||||
read(*,*) mtrx_file
|
||||
read(*,*) rhs_file
|
||||
read(*,*) kmethd
|
||||
read(*,*) ptype
|
||||
read(*,*) afmt
|
||||
|
||||
|
||||
call psb_bcast(ictxt,mtrx_file)
|
||||
call psb_bcast(ictxt,rhs_file)
|
||||
call psb_bcast(ictxt,kmethd)
|
||||
call psb_bcast(ictxt,ptype)
|
||||
call psb_bcast(ictxt,afmt)
|
||||
|
||||
read(*,*) ipart
|
||||
if (ip >= 7) then
|
||||
read(*,*) istopc
|
||||
else
|
||||
istopc=1
|
||||
endif
|
||||
if (ip >= 8) then
|
||||
read(*,*) itmax
|
||||
else
|
||||
itmax=500
|
||||
endif
|
||||
if (ip >= 9) then
|
||||
read(*,*) itrace
|
||||
else
|
||||
itrace=-1
|
||||
endif
|
||||
if (ip >= 10) then
|
||||
read(*,*) irst
|
||||
else
|
||||
irst = 1
|
||||
endif
|
||||
if (ip >= 11) then
|
||||
read(*,*) eps
|
||||
else
|
||||
eps=1.d-6
|
||||
endif
|
||||
inparms(1) = ipart
|
||||
inparms(2) = istopc
|
||||
inparms(3) = itmax
|
||||
inparms(4) = itrace
|
||||
inparms(5) = irst
|
||||
call psb_bcast(ictxt,inparms(1:5))
|
||||
call psb_bcast(ictxt,eps)
|
||||
|
||||
write(*,'("Solving matrix : ",a)') mtrx_file
|
||||
write(*,'("Number of processors : ",i3)') np
|
||||
write(*,'("Data distribution : ",i2)') ipart
|
||||
write(*,'("Iterative method : ",a)') kmethd
|
||||
write(*,'("Preconditioner : ",a)') ptype
|
||||
write(*,'("Restart parameter : ",i2)') irst
|
||||
write(*,'("Storage format : ",a)') afmt(1:3)
|
||||
write(*,'(" ")')
|
||||
else
|
||||
write(0,*) 'Wrong format for input file'
|
||||
call psb_abort(ictxt)
|
||||
stop 1
|
||||
end if
|
||||
else
|
||||
! Receive Parameters
|
||||
call psb_bcast(ictxt,mtrx_file)
|
||||
call psb_bcast(ictxt,rhs_file)
|
||||
call psb_bcast(ictxt,kmethd)
|
||||
call psb_bcast(ictxt,ptype)
|
||||
call psb_bcast(ictxt,afmt)
|
||||
|
||||
call psb_bcast(ictxt,inparms(1:5))
|
||||
ipart = inparms(1)
|
||||
istopc = inparms(2)
|
||||
itmax = inparms(3)
|
||||
itrace = inparms(4)
|
||||
irst = inparms(5)
|
||||
call psb_bcast(ictxt,eps)
|
||||
|
||||
end if
|
||||
|
||||
end subroutine get_sparms
|
||||
|
||||
end module getp
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
11 Number of inputs
|
||||
young1c.mtx waveguide3D.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
|
||||
NONE http://www.cise.ufl.edu/research/sparse/matrices/index.html
|
||||
BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL
|
||||
BJAC Preconditioner NONE DIAG BJAC
|
||||
CSR Storage format CSR COO JAD
|
||||
0 IPART: Partition method 0: BLK 2: graph (with Metis)
|
||||
2 ISTOPC
|
||||
01000 ITMAX
|
||||
01 ITRACE
|
||||
30 IRST (restart for RGMRES and BiCGSTABL)
|
||||
1.d-5 EPS
|
||||
@@ -0,0 +1,12 @@
|
||||
11 Number of inputs
|
||||
thm1000x600.mtx young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
|
||||
NONE http://www.cise.ufl.edu/research/sparse/matrices/index.html
|
||||
BICGSTABL Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL
|
||||
BJAC Preconditioner NONE DIAG BJAC
|
||||
CSR Storage format CSR COO JAD
|
||||
0 IPART: Partition method 0: BLK 2: graph (with Metis)
|
||||
2 ISTOPC
|
||||
01000 ITMAX
|
||||
01 ITRACE
|
||||
04 IRST (restart for RGMRES and BiCGSTABL)
|
||||
1.d-6 EPS
|
||||
@@ -0,0 +1,293 @@
|
||||
!!$
|
||||
!!$ Parallel Sparse BLAS version 2.2
|
||||
!!$ (C) Copyright 2006/2007/2008
|
||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||
!!$
|
||||
!!$ Redistribution and use in source and binary forms, with or without
|
||||
!!$ modification, are permitted provided that the following conditions
|
||||
!!$ are met:
|
||||
!!$ 1. Redistributions of source code must retain the above copyright
|
||||
!!$ notice, this list of conditions and the following disclaimer.
|
||||
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
||||
!!$ notice, this list of conditions, and the following disclaimer in the
|
||||
!!$ documentation and/or other materials provided with the distribution.
|
||||
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
||||
!!$ not be used to endorse or promote products derived from this
|
||||
!!$ software without specific written permission.
|
||||
!!$
|
||||
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
program sf_sample
|
||||
use psb_base_mod
|
||||
use psb_prec_mod
|
||||
use psb_krylov_mod
|
||||
use psb_util_mod
|
||||
use getp
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file
|
||||
|
||||
! sparse matrices
|
||||
type(psb_sspmat_type) :: a, aux_a
|
||||
|
||||
! preconditioner data
|
||||
type(psb_sprec_type) :: prec
|
||||
|
||||
! dense matrices
|
||||
real(psb_spk_), allocatable, target :: aux_b(:,:), d(:)
|
||||
real(psb_spk_), allocatable , save :: b_col(:), x_col(:), r_col(:), &
|
||||
& x_col_glob(:), r_col_glob(:)
|
||||
real(psb_spk_), pointer :: b_col_glob(:)
|
||||
|
||||
! communications data structure
|
||||
type(psb_desc_type):: desc_a
|
||||
|
||||
integer :: ictxt, iam, np
|
||||
|
||||
! solver paramters
|
||||
integer :: iter, itmax, ierr, itrace, ircode, ipart,&
|
||||
& methd, istopc, irst,amatsize,precsize,descsize
|
||||
real(psb_spk_) :: err, eps,cond
|
||||
|
||||
character(len=5) :: afmt
|
||||
character(len=20) :: name
|
||||
integer :: iparm(20)
|
||||
|
||||
! other variables
|
||||
integer :: i,info,j,m_problem
|
||||
integer :: internal, m,ii,nnzero
|
||||
real(psb_spk_) :: t1, t2, tprec, r_amax, b_amax,&
|
||||
&scale,resmx,resmxp
|
||||
integer :: nrhs, nrow, n_row, dim, nv, ne
|
||||
integer, allocatable :: ivg(:), ipv(:)
|
||||
|
||||
|
||||
call psb_init(ictxt)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (iam < 0) then
|
||||
! This should not happen, but just in case
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
endif
|
||||
|
||||
|
||||
name='df_sample'
|
||||
if(psb_get_errstatus() /= 0) goto 9999
|
||||
info=0
|
||||
call psb_set_errverbosity(2)
|
||||
!
|
||||
! get parameters
|
||||
!
|
||||
call get_parms(ictxt,mtrx_file,rhs_file,kmethd,ptype,&
|
||||
& ipart,afmt,istopc,itmax,itrace,irst,eps)
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
! read the input matrix to be processed and (possibly) the rhs
|
||||
nrhs = 1
|
||||
|
||||
if (iam==psb_root_) then
|
||||
call read_mat(mtrx_file, aux_a, ictxt)
|
||||
|
||||
m_problem = aux_a%m
|
||||
call psb_bcast(ictxt,m_problem)
|
||||
|
||||
if(rhs_file /= 'NONE') then
|
||||
! reading an rhs
|
||||
call read_rhs(rhs_file,aux_b,ictxt)
|
||||
end if
|
||||
|
||||
if (psb_size(aux_b,dim=1)==m_problem) then
|
||||
! if any rhs were present, broadcast the first one
|
||||
write(0,'("Ok, got an rhs ")')
|
||||
b_col_glob =>aux_b(:,1)
|
||||
else
|
||||
write(*,'("Generating an rhs...")')
|
||||
write(*,'(" ")')
|
||||
call psb_realloc(m_problem,1,aux_b,ircode)
|
||||
if (ircode /= 0) then
|
||||
call psb_errpush(4000,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
b_col_glob => aux_b(:,1)
|
||||
do i=1, m_problem
|
||||
b_col_glob(i) = 1.d0
|
||||
enddo
|
||||
endif
|
||||
call psb_bcast(ictxt,b_col_glob(1:m_problem))
|
||||
else
|
||||
call psb_bcast(ictxt,m_problem)
|
||||
call psb_realloc(m_problem,1,aux_b,ircode)
|
||||
if (ircode /= 0) then
|
||||
call psb_errpush(4000,name)
|
||||
goto 9999
|
||||
endif
|
||||
b_col_glob =>aux_b(:,1)
|
||||
call psb_bcast(ictxt,b_col_glob(1:m_problem))
|
||||
end if
|
||||
|
||||
! switch over different partition types
|
||||
if (ipart == 0) then
|
||||
call psb_barrier(ictxt)
|
||||
if (iam==psb_root_) write(*,'("Partition type: block")')
|
||||
allocate(ivg(m_problem),ipv(np))
|
||||
do i=1,m_problem
|
||||
call part_block(i,m_problem,np,ipv,nv)
|
||||
ivg(i) = ipv(1)
|
||||
enddo
|
||||
call psb_matdist(aux_a, a, ivg, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
else if (ipart == 2) then
|
||||
if (iam==psb_root_) then
|
||||
write(*,'("Partition type: graph")')
|
||||
write(*,'(" ")')
|
||||
! write(0,'("Build type: graph")')
|
||||
call build_mtpart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np)
|
||||
endif
|
||||
call psb_barrier(ictxt)
|
||||
call distr_mtpart(psb_root_,ictxt)
|
||||
call getv_mtpart(ivg)
|
||||
call psb_matdist(aux_a, a, ivg, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
else
|
||||
if (iam==psb_root_) write(*,'("Partition type: block")')
|
||||
call psb_matdist(aux_a, a, part_block, ictxt, &
|
||||
& desc_a,b_col_glob,b_col,info,fmt=afmt)
|
||||
end if
|
||||
|
||||
call psb_geall(x_col,desc_a,info)
|
||||
x_col(:) =0.0
|
||||
call psb_geasb(x_col,desc_a,info)
|
||||
call psb_geall(r_col,desc_a,info)
|
||||
r_col(:) =0.0
|
||||
call psb_geasb(r_col,desc_a,info)
|
||||
t2 = psb_wtime() - t1
|
||||
|
||||
|
||||
call psb_amx(ictxt, t2)
|
||||
|
||||
if (iam==psb_root_) then
|
||||
write(*,'(" ")')
|
||||
write(*,'("Time to read and partition matrix : ",es10.4)')t2
|
||||
write(*,'(" ")')
|
||||
end if
|
||||
|
||||
!
|
||||
|
||||
call psb_precinit(prec,ptype,info)
|
||||
|
||||
! building the preconditioner
|
||||
t1 = psb_wtime()
|
||||
call psb_precbld(a,desc_a,prec,info)
|
||||
tprec = psb_wtime()-t1
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4010,name,a_err='psb_precbld')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call psb_amx(ictxt, tprec)
|
||||
|
||||
if(iam==psb_root_) then
|
||||
write(*,'("Preconditioner time: ",es10.4)')tprec
|
||||
write(*,'(" ")')
|
||||
end if
|
||||
cond = -sone
|
||||
iparm = 0
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
|
||||
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,&
|
||||
& irst=irst,cond=cond)
|
||||
call psb_barrier(ictxt)
|
||||
t2 = psb_wtime() - t1
|
||||
|
||||
call psb_amx(ictxt,t2)
|
||||
call psb_geaxpby(sone,b_col,szero,r_col,desc_a,info)
|
||||
call psb_spmm(-sone,a,x_col,sone,r_col,desc_a,info)
|
||||
call psb_genrm2s(resmx,r_col,desc_a,info)
|
||||
call psb_geamaxs(resmxp,r_col,desc_a,info)
|
||||
|
||||
amatsize = psb_sizeof(a)
|
||||
descsize = psb_sizeof(desc_a)
|
||||
precsize = psb_sizeof(prec)
|
||||
call psb_sum(ictxt,amatsize)
|
||||
call psb_sum(ictxt,descsize)
|
||||
call psb_sum(ictxt,precsize)
|
||||
if (iam==psb_root_) then
|
||||
call psb_prec_descr(6,prec)
|
||||
write(*,'("Matrix: ",a)')mtrx_file
|
||||
write(*,'("Computed solution on ",i8," processors")')np
|
||||
write(*,'("Iterations to convergence: ",i6)')iter
|
||||
write(*,'("Error estimate on exit : ",es10.4)') err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 : ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf : ",es10.4)')resmxp
|
||||
write(*,*)"Condition number : ",cond
|
||||
write(*,'("Total memory occupation for A: ",i10)')amatsize
|
||||
write(*,'("Total memory occupation for DESC_A: ",i10)')descsize
|
||||
write(*,'("Total memory occupation for PREC: ",i10)')precsize
|
||||
end if
|
||||
|
||||
allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr)
|
||||
if (ierr /= 0) then
|
||||
write(0,*) 'allocation error: no data collection'
|
||||
else
|
||||
call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
|
||||
call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_)
|
||||
if (iam==psb_root_) then
|
||||
write(0,'(" ")')
|
||||
write(0,'("Saving x on file")')
|
||||
write(20,*) 'matrix: ',mtrx_file
|
||||
write(20,*) 'computed solution on ',np,' processors.'
|
||||
write(20,*) 'iterations to convergence: ',iter
|
||||
write(20,*) 'error estimate (infinity norm) on exit:', &
|
||||
& ' ||r||/(||a||||x||+||b||) = ',err
|
||||
write(20,*) 'max residual = ',resmx, resmxp
|
||||
write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)'
|
||||
do i=1,m_problem
|
||||
write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i)
|
||||
enddo
|
||||
end if
|
||||
end if
|
||||
998 format(i8,4(2x,g20.14))
|
||||
993 format(i6,4(1x,e12.6))
|
||||
|
||||
|
||||
call psb_gefree(b_col, desc_a,info)
|
||||
call psb_gefree(x_col, desc_a,info)
|
||||
call psb_spfree(a, desc_a,info)
|
||||
call psb_precfree(prec,info)
|
||||
call psb_cdfree(desc_a,info)
|
||||
|
||||
9999 continue
|
||||
if(info /= 0) then
|
||||
call psb_error(ictxt)
|
||||
end if
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
|
||||
end program sf_sample
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -234,13 +234,14 @@ program zf_sample
|
||||
write(*,'("Matrix: ",a)')mtrx_file
|
||||
write(*,'("Computed solution on ",i8," processors")')np
|
||||
write(*,'("Iterations to convergence: ",i6)')iter
|
||||
write(*,'("Error estimate on exit: ",f7.2)')err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 = ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf = ",es10.4)')resmxp
|
||||
write(*,'("Error estimate on exit : ",es10.4)') err
|
||||
write(*,'("Time to buil prec. : ",es10.4)')tprec
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/(iter)
|
||||
write(*,'("Total time : ",es10.4)')t2+tprec
|
||||
write(*,'("Residual norm 2 : ",es10.4)')resmx
|
||||
write(*,'("Residual norm inf : ",es10.4)')resmxp
|
||||
!!$ write(*,*)"Condition number : ",cond
|
||||
write(*,'("Total memory occupation for A: ",i10)')amatsize
|
||||
write(*,'("Total memory occupation for DESC_A: ",i10)')descsize
|
||||
write(*,'("Total memory occupation for PREC: ",i10)')precsize
|
||||
|
||||
@@ -19,16 +19,16 @@ ppde: ppde.o
|
||||
$(F90LINK) ppde.o -o ppde $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv ppde $(EXEDIR)
|
||||
|
||||
tpde: tpde.o
|
||||
$(F90LINK) tpde.o -pg -o tpde $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv tpde $(EXEDIR)
|
||||
spde: spde.o
|
||||
$(F90LINK) spde.o -o spde $(PSBLAS_LIB) $(LDLIBS)
|
||||
/bin/mv spde $(EXEDIR)
|
||||
|
||||
.f90.o:
|
||||
$(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
|
||||
|
||||
|
||||
clean:
|
||||
/bin/rm -f ppde.o $(EXEDIR)/ppde
|
||||
/bin/rm -f ppde.o spde.o $(EXEDIR)/ppde
|
||||
verycleanlib:
|
||||
(cd ../..; make veryclean)
|
||||
lib:
|
||||
|
||||
@@ -361,12 +361,13 @@ contains
|
||||
end interface ! local variables
|
||||
type(psb_dspmat_type) :: a
|
||||
real(psb_dpk_) :: zt(nbmax),glob_x,glob_y,glob_z
|
||||
integer :: m,n,nnz,glob_row,loc_row
|
||||
integer :: m,n,nnz,glob_row
|
||||
integer :: x,y,z,ia,indx_owner
|
||||
integer :: np, iam
|
||||
integer :: element
|
||||
integer, allocatable :: irow(:),icol(:)
|
||||
real(psb_dpk_), allocatable :: val(:)
|
||||
integer, allocatable :: prv(:)
|
||||
! deltah dimension of each grid cell
|
||||
! deltat discretization time
|
||||
real(psb_dpk_) :: deltah
|
||||
|
||||
@@ -2,7 +2,7 @@
|
||||
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES
|
||||
BJAC Preconditioner NONE DIAG BJAC
|
||||
CSR Storage format for matrix A: CSR COO JAD
|
||||
60 Domain size (acutal system is this**3)
|
||||
100 Domain size (acutal system is this**3)
|
||||
1 Stopping criterion
|
||||
80 MAXIT
|
||||
-1 ITRACE
|
||||
|
||||
@@ -0,0 +1,670 @@
|
||||
!!$
|
||||
!!$ Parallel Sparse BLAS version 2.2
|
||||
!!$ (C) Copyright 2006/2007/2008
|
||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||
!!$
|
||||
!!$ Redistribution and use in source and binary forms, with or without
|
||||
!!$ modification, are permitted provided that the following conditions
|
||||
!!$ are met:
|
||||
!!$ 1. Redistributions of source code must retain the above copyright
|
||||
!!$ notice, this list of conditions and the following disclaimer.
|
||||
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
||||
!!$ notice, this list of conditions, and the following disclaimer in the
|
||||
!!$ documentation and/or other materials provided with the distribution.
|
||||
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
||||
!!$ not be used to endorse or promote products derived from this
|
||||
!!$ software without specific written permission.
|
||||
!!$
|
||||
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
! File: ppde.f90
|
||||
!
|
||||
! Program: ppde
|
||||
! This sample program shows how to build and solve a sparse linear
|
||||
!
|
||||
! The program solves a linear system based on the partial differential
|
||||
! equation
|
||||
!
|
||||
!
|
||||
!
|
||||
! The equation generated is
|
||||
!
|
||||
! b1 d d (u) b2 d d (u) a1 d (u)) a2 d (u)))
|
||||
! - ------ - ------ + ----- + ------ + a3 u = 0
|
||||
! dx dx dy dy dx dy
|
||||
!
|
||||
!
|
||||
! with Dirichlet boundary conditions on the unit cube
|
||||
!
|
||||
! 0<=x,y,z<=1
|
||||
!
|
||||
! The equation is discretized with finite differences and uniform stepsize;
|
||||
! the resulting discrete equation is
|
||||
!
|
||||
! ( u(x,y,z)(2b1+2b2+a1+a2)+u(x-1,y)(-b1-a1)+u(x,y-1)(-b2-a2)+
|
||||
! -u(x+1,y)b1-u(x,y+1)b2)*(1/h**2)
|
||||
!
|
||||
! Example taken from: C.T.Kelley
|
||||
! Iterative Methods for Linear and Nonlinear Equations
|
||||
! SIAM 1995
|
||||
!
|
||||
!
|
||||
! In this sample program the index space of the discretized
|
||||
! computational domain is first numbered sequentially in a standard way,
|
||||
! then the corresponding vector is distributed according to a BLOCK
|
||||
! data distribution.
|
||||
!
|
||||
! Boundary conditions are set in a very simple way, by adding
|
||||
! equations of the form
|
||||
!
|
||||
! u(x,y) = rhs(x,y)
|
||||
!
|
||||
program ppde
|
||||
use psb_base_mod
|
||||
use psb_prec_mod
|
||||
use psb_krylov_mod
|
||||
use psb_util_mod
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
character(len=20) :: kmethd, ptype
|
||||
character(len=5) :: afmt
|
||||
integer :: idim
|
||||
|
||||
! miscellaneous
|
||||
real(psb_spk_), parameter :: one = 1.d0
|
||||
real(psb_spk_) :: t1, t2, tprec
|
||||
|
||||
! sparse matrix and preconditioner
|
||||
type(psb_sspmat_type) :: a
|
||||
type(psb_sprec_type) :: prec
|
||||
! descriptor
|
||||
type(psb_desc_type) :: desc_a
|
||||
! dense matrices
|
||||
real(psb_spk_), allocatable :: b(:), x(:)
|
||||
! blacs parameters
|
||||
integer :: ictxt, iam, np
|
||||
|
||||
! solver parameters
|
||||
integer :: iter, itmax,itrace, istopc, irst
|
||||
real(psb_spk_) :: err, eps
|
||||
|
||||
! other variables
|
||||
integer :: info
|
||||
character(len=20) :: name,ch_err
|
||||
|
||||
info=0
|
||||
|
||||
|
||||
call psb_init(ictxt)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (iam < 0) then
|
||||
! This should not happen, but just in case
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
endif
|
||||
if(psb_get_errstatus() /= 0) goto 9999
|
||||
name='pde90'
|
||||
call psb_set_errverbosity(2)
|
||||
|
||||
!
|
||||
! get parameters
|
||||
!
|
||||
call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst)
|
||||
|
||||
!
|
||||
! allocate and fill in the coefficient matrix, rhs and initial guess
|
||||
!
|
||||
call psb_cd_set_large_threshold(128)
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call create_matrix(idim,a,b,x,desc_a,part_block,ictxt,afmt,info)
|
||||
t2 = psb_wtime() - t1
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='create_matrix'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_amx(ictxt,t2)
|
||||
if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es10.4)')t2
|
||||
if (iam == psb_root_) write(*,'(" ")')
|
||||
!
|
||||
! prepare the preconditioner.
|
||||
!
|
||||
if(iam == psb_root_) write(0,'("Setting preconditioner to : ",a)')ptype
|
||||
call psb_precinit(prec,ptype,info)
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
call psb_precbld(a,desc_a,prec,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='psb_precbld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
tprec = psb_wtime()-t1
|
||||
|
||||
call psb_amx(ictxt,tprec)
|
||||
|
||||
if (iam == psb_root_) write(*,'("Preconditioner time : ",es10.4)')tprec
|
||||
if (iam == psb_root_) write(*,'(" ")')
|
||||
|
||||
!
|
||||
! iterative method parameters
|
||||
!
|
||||
if(iam == psb_root_) write(*,'("Calling iterative method ",a)')kmethd
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
eps = 1.d-9
|
||||
call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,&
|
||||
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
|
||||
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='solver routine'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t2 = psb_wtime() - t1
|
||||
call psb_amx(ictxt,t2)
|
||||
|
||||
if (iam == psb_root_) then
|
||||
write(*,'(" ")')
|
||||
write(*,'("Time to solve matrix : ",es10.4)')t2
|
||||
write(*,'("Time per iteration : ",es10.4)')t2/iter
|
||||
write(*,'("Number of iterations : ",i0)')iter
|
||||
write(*,'("Error estimate on exit : ",es10.4)')err
|
||||
write(*,'("Info on exit : ",i0)')info
|
||||
end if
|
||||
|
||||
!
|
||||
! cleanup storage and exit
|
||||
!
|
||||
call psb_gefree(b,desc_a,info)
|
||||
call psb_gefree(x,desc_a,info)
|
||||
call psb_spfree(a,desc_a,info)
|
||||
!!$ call psb_precfree(prec,info)
|
||||
call psb_cdfree(desc_a,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='free routine'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
9999 continue
|
||||
if(info /= 0) then
|
||||
call psb_error(ictxt)
|
||||
end if
|
||||
call psb_exit(ictxt)
|
||||
stop
|
||||
|
||||
contains
|
||||
!
|
||||
! get iteration parameters from the command line
|
||||
!
|
||||
subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst)
|
||||
integer :: ictxt
|
||||
character(len=*) :: kmethd, ptype, afmt
|
||||
integer :: idim, istopc,itmax,itrace,irst
|
||||
integer :: np, iam
|
||||
integer :: intbuf(10), ip
|
||||
|
||||
call psb_info(ictxt, iam, np)
|
||||
|
||||
if (iam==0) then
|
||||
read(*,*) ip
|
||||
if (ip >= 3) then
|
||||
read(*,*) kmethd
|
||||
read(*,*) ptype
|
||||
read(*,*) afmt
|
||||
|
||||
! broadcast parameters to all processors
|
||||
call psb_bcast(ictxt,kmethd)
|
||||
call psb_bcast(ictxt,afmt)
|
||||
call psb_bcast(ictxt,ptype)
|
||||
|
||||
|
||||
read(*,*) idim
|
||||
if (ip >= 4) then
|
||||
read(*,*) istopc
|
||||
else
|
||||
istopc=1
|
||||
endif
|
||||
if (ip >= 5) then
|
||||
read(*,*) itmax
|
||||
else
|
||||
itmax=500
|
||||
endif
|
||||
if (ip >= 6) then
|
||||
read(*,*) itrace
|
||||
else
|
||||
itrace=-1
|
||||
endif
|
||||
if (ip >= 7) then
|
||||
read(*,*) irst
|
||||
else
|
||||
irst=1
|
||||
endif
|
||||
! broadcast parameters to all processors
|
||||
|
||||
intbuf(1) = idim
|
||||
intbuf(2) = istopc
|
||||
intbuf(3) = itmax
|
||||
intbuf(4) = itrace
|
||||
intbuf(5) = irst
|
||||
call psb_bcast(ictxt,intbuf(1:5))
|
||||
|
||||
write(*,'("Solving matrix : ell1")')
|
||||
write(*,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim
|
||||
write(*,'("Number of processors : ",i0)')np
|
||||
write(*,'("Data distribution : BLOCK")')
|
||||
write(*,'("Preconditioner : ",a)') ptype
|
||||
write(*,'("Iterative method : ",a)') kmethd
|
||||
write(*,'(" ")')
|
||||
else
|
||||
! wrong number of parameter, print an error message and exit
|
||||
call pr_usage(0)
|
||||
call psb_abort(ictxt)
|
||||
stop 1
|
||||
endif
|
||||
else
|
||||
call psb_bcast(ictxt,kmethd)
|
||||
call psb_bcast(ictxt,afmt)
|
||||
call psb_bcast(ictxt,ptype)
|
||||
call psb_bcast(ictxt,intbuf(1:5))
|
||||
idim = intbuf(1)
|
||||
istopc = intbuf(2)
|
||||
itmax = intbuf(3)
|
||||
itrace = intbuf(4)
|
||||
irst = intbuf(5)
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine get_parms
|
||||
!
|
||||
! print an error message
|
||||
!
|
||||
subroutine pr_usage(iout)
|
||||
integer :: iout
|
||||
write(iout,*)'incorrect parameter(s) found'
|
||||
write(iout,*)' usage: pde90 methd prec dim &
|
||||
&[istop itmax itrace]'
|
||||
write(iout,*)' where:'
|
||||
write(iout,*)' methd: cgstab cgs rgmres bicgstabl'
|
||||
write(iout,*)' prec : bjac diag none'
|
||||
write(iout,*)' dim number of points along each axis'
|
||||
write(iout,*)' the size of the resulting linear '
|
||||
write(iout,*)' system is dim**3'
|
||||
write(iout,*)' istop stopping criterion 1, 2 '
|
||||
write(iout,*)' itmax maximum number of iterations [500] '
|
||||
write(iout,*)' itrace <=0 (no tracing, default) or '
|
||||
write(iout,*)' >= 1 do tracing every itrace'
|
||||
write(iout,*)' iterations '
|
||||
end subroutine pr_usage
|
||||
|
||||
!
|
||||
! subroutine to allocate and fill in the coefficient matrix and
|
||||
! the rhs.
|
||||
!
|
||||
subroutine create_matrix(idim,a,b,xv,desc_a,parts,ictxt,afmt,info)
|
||||
!
|
||||
! discretize the partial diferential equation
|
||||
!
|
||||
! b1 dd(u) b2 dd(u) b3 dd(u) a1 d(u) a2 d(u) a3 d(u)
|
||||
! - ------ - ------ - ------ - ----- - ------ - ------ + a4 u
|
||||
! dxdx dydy dzdz dx dy dz
|
||||
!
|
||||
! = 0
|
||||
!
|
||||
! boundary condition: dirichlet
|
||||
! 0< x,y,z<1
|
||||
!
|
||||
! u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+
|
||||
! + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3
|
||||
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
integer :: idim
|
||||
integer, parameter :: nbmax=10
|
||||
real(psb_spk_), allocatable :: b(:),xv(:)
|
||||
type(psb_desc_type) :: desc_a
|
||||
integer :: ictxt, info
|
||||
character :: afmt*5
|
||||
interface
|
||||
! .....user passed subroutine.....
|
||||
subroutine parts(global_indx,n,np,pv,nv)
|
||||
implicit none
|
||||
integer, intent(in) :: global_indx, n, np
|
||||
integer, intent(out) :: nv
|
||||
integer, intent(out) :: pv(*)
|
||||
end subroutine parts
|
||||
end interface ! local variables
|
||||
type(psb_sspmat_type) :: a
|
||||
real(psb_spk_) :: zt(nbmax),glob_x,glob_y,glob_z
|
||||
integer :: m,n,nnz,glob_row
|
||||
integer :: x,y,z,ia,indx_owner
|
||||
integer :: np, iam
|
||||
integer :: element
|
||||
integer :: nv, inv
|
||||
integer, allocatable :: irow(:),icol(:)
|
||||
real(psb_spk_), allocatable :: val(:)
|
||||
integer, allocatable :: prv(:)
|
||||
! deltah dimension of each grid cell
|
||||
! deltat discretization time
|
||||
real(psb_spk_) :: deltah
|
||||
real(psb_spk_),parameter :: rhs=0.d0,one=1.d0,zero=0.d0
|
||||
real(psb_spk_) :: t1, t2, t3, tins, tasb
|
||||
real(psb_spk_) :: a1, a2, a3, a4, b1, b2, b3
|
||||
external :: a1, a2, a3, a4, b1, b2, b3
|
||||
integer :: err_act
|
||||
! common area
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
info = 0
|
||||
name = 'create_matrix'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
call psb_info(ictxt, iam, np)
|
||||
|
||||
deltah = 1.d0/(idim-1)
|
||||
|
||||
! initialize array descriptor and sparse matrix storage. provide an
|
||||
! estimate of the number of non zeroes
|
||||
|
||||
m = idim*idim*idim
|
||||
n = m
|
||||
nnz = ((n*9)/(np))
|
||||
if(iam == psb_root_) write(0,'("Generating Matrix (size=",i0x,")...")')n
|
||||
|
||||
call psb_cdall(ictxt,desc_a,info,mg=n,parts=parts)
|
||||
if (info == 0) call psb_spall(a,desc_a,info,nnz=nnz)
|
||||
! define rhs from boundary conditions; also build initial guess
|
||||
if (info == 0) call psb_geall(b,desc_a,info)
|
||||
if (info == 0) call psb_geall(xv,desc_a,info)
|
||||
if (info /= 0) then
|
||||
info=4010
|
||||
ch_err='allocation rout.'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! we build an auxiliary matrix consisting of one row at a
|
||||
! time; just a small matrix. might be extended to generate
|
||||
! a bunch of rows per call.
|
||||
!
|
||||
allocate(val(20*nbmax),irow(20*nbmax),&
|
||||
&icol(20*nbmax),prv(np),stat=info)
|
||||
if (info /= 0 ) then
|
||||
info=4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
tins = 0.d0
|
||||
call psb_barrier(ictxt)
|
||||
t1 = psb_wtime()
|
||||
|
||||
! loop over rows belonging to current process in a block
|
||||
! distribution.
|
||||
|
||||
! icol(1)=1
|
||||
do glob_row = 1, n
|
||||
call parts(glob_row,n,np,prv,nv)
|
||||
do inv = 1, nv
|
||||
indx_owner = prv(inv)
|
||||
if (indx_owner == iam) then
|
||||
! local matrix pointer
|
||||
element=1
|
||||
! compute gridpoint coordinates
|
||||
if (mod(glob_row,(idim*idim)) == 0) then
|
||||
x = glob_row/(idim*idim)
|
||||
else
|
||||
x = glob_row/(idim*idim)+1
|
||||
endif
|
||||
if (mod((glob_row-(x-1)*idim*idim),idim) == 0) then
|
||||
y = (glob_row-(x-1)*idim*idim)/idim
|
||||
else
|
||||
y = (glob_row-(x-1)*idim*idim)/idim+1
|
||||
endif
|
||||
z = glob_row-(x-1)*idim*idim-(y-1)*idim
|
||||
! glob_x, glob_y, glob_x coordinates
|
||||
glob_x=x*deltah
|
||||
glob_y=y*deltah
|
||||
glob_z=z*deltah
|
||||
|
||||
! check on boundary points
|
||||
zt(1) = 0.d0
|
||||
! internal point: build discretization
|
||||
!
|
||||
! term depending on (x-1,y,z)
|
||||
!
|
||||
if (x==1) then
|
||||
val(element)=-b1(glob_x,glob_y,glob_z)&
|
||||
& -a1(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
zt(1) = exp(-glob_y**2-glob_z**2)*(-val(element))
|
||||
else
|
||||
val(element)=-b1(glob_x,glob_y,glob_z)&
|
||||
& -a1(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-2)*idim*idim+(y-1)*idim+(z)
|
||||
element=element+1
|
||||
endif
|
||||
! term depending on (x,y-1,z)
|
||||
if (y==1) then
|
||||
val(element)=-b2(glob_x,glob_y,glob_z)&
|
||||
& -a2(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
|
||||
else
|
||||
val(element)=-b2(glob_x,glob_y,glob_z)&
|
||||
& -a2(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-1)*idim*idim+(y-2)*idim+(z)
|
||||
element=element+1
|
||||
endif
|
||||
! term depending on (x,y,z-1)
|
||||
if (z==1) then
|
||||
val(element)=-b3(glob_x,glob_y,glob_z)&
|
||||
& -a3(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
|
||||
else
|
||||
val(element)=-b3(glob_x,glob_y,glob_z)&
|
||||
& -a3(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z-1)
|
||||
element=element+1
|
||||
endif
|
||||
! term depending on (x,y,z)
|
||||
val(element)=2*b1(glob_x,glob_y,glob_z)&
|
||||
& +2*b2(glob_x,glob_y,glob_z)&
|
||||
& +2*b3(glob_x,glob_y,glob_z)&
|
||||
& +a1(glob_x,glob_y,glob_z)&
|
||||
& +a2(glob_x,glob_y,glob_z)&
|
||||
& +a3(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z)
|
||||
element=element+1
|
||||
! term depending on (x,y,z+1)
|
||||
if (z==idim) then
|
||||
val(element)=-b1(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
|
||||
else
|
||||
val(element)=-b1(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-1)*idim*idim+(y-1)*idim+(z+1)
|
||||
element=element+1
|
||||
endif
|
||||
! term depending on (x,y+1,z)
|
||||
if (y==idim) then
|
||||
val(element)=-b2(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
zt(1) = exp(-glob_y**2-glob_z**2)*exp(-glob_x)*(-val(element))
|
||||
else
|
||||
val(element)=-b2(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x-1)*idim*idim+(y)*idim+(z)
|
||||
element=element+1
|
||||
endif
|
||||
! term depending on (x+1,y,z)
|
||||
if (x<idim) then
|
||||
val(element)=-b3(glob_x,glob_y,glob_z)
|
||||
val(element) = val(element)/(deltah*&
|
||||
& deltah)
|
||||
icol(element)=(x)*idim*idim+(y-1)*idim+(z)
|
||||
element=element+1
|
||||
endif
|
||||
irow(1:element-1)=glob_row
|
||||
ia=glob_row
|
||||
|
||||
t3 = psb_wtime()
|
||||
call psb_spins(element-1,irow,icol,val,a,desc_a,info)
|
||||
if(info /= 0) exit
|
||||
tins = tins + (psb_wtime()-t3)
|
||||
call psb_geins(1,(/ia/),zt(1:1),b,desc_a,info)
|
||||
if(info /= 0) exit
|
||||
zt(1)=0.d0
|
||||
call psb_geins(1,(/ia/),zt(1:1),xv,desc_a,info)
|
||||
if(info /= 0) exit
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
call psb_barrier(ictxt)
|
||||
t2 = psb_wtime()-t1
|
||||
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='insert rout.'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
deallocate(val,irow,icol)
|
||||
|
||||
t1 = psb_wtime()
|
||||
call psb_cdasb(desc_a,info)
|
||||
call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
|
||||
call psb_barrier(ictxt)
|
||||
tasb = psb_wtime()-t1
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='asb rout.'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_amx(ictxt,t2)
|
||||
call psb_amx(ictxt,tins)
|
||||
call psb_amx(ictxt,tasb)
|
||||
|
||||
if(iam == psb_root_) then
|
||||
write(*,'("The matrix has been generated and assembled in ",a3," format.")')&
|
||||
& a%fida(1:3)
|
||||
write(*,'("-pspins time : ",es10.4)')tins
|
||||
write(*,'("-insert time : ",es10.4)')t2
|
||||
write(*,'("-assembly time : ",es10.4)')tasb
|
||||
end if
|
||||
|
||||
call psb_geasb(b,desc_a,info)
|
||||
call psb_geasb(xv,desc_a,info)
|
||||
if(info /= 0) then
|
||||
info=4010
|
||||
ch_err='asb rout.'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error(ictxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
end subroutine create_matrix
|
||||
end program ppde
|
||||
!
|
||||
! functions parametrizing the differential equation
|
||||
!
|
||||
function a1(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: a1
|
||||
real(psb_spk_) :: x,y,z
|
||||
a1=1.e0
|
||||
end function a1
|
||||
function a2(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: a2
|
||||
real(psb_spk_) :: x,y,z
|
||||
a2=2.d1*y
|
||||
end function a2
|
||||
function a3(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: a3
|
||||
real(psb_spk_) :: x,y,z
|
||||
a3=1.e0
|
||||
end function a3
|
||||
function a4(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: a4
|
||||
real(psb_spk_) :: x,y,z
|
||||
a4=1.e0
|
||||
end function a4
|
||||
function b1(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: b1
|
||||
real(psb_spk_) :: x,y,z
|
||||
b1=1.e0
|
||||
end function b1
|
||||
function b2(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: b2
|
||||
real(psb_spk_) :: x,y,z
|
||||
b2=1.e0
|
||||
end function b2
|
||||
function b3(x,y,z)
|
||||
use psb_base_mod
|
||||
real(psb_spk_) :: b3
|
||||
real(psb_spk_) :: x,y,z
|
||||
b3=1.e0
|
||||
end function b3
|
||||
|
||||
|
||||
Reference in New Issue
Block a user