fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
Alfredo Buttari
2005-09-09 08:24:00 +00:00
parent 7051d94726
commit bea96560d1
59 changed files with 800 additions and 568 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Make.inc
+8 -8
View File
@@ -9,9 +9,9 @@ F90=ifort
FC=ifort
CC=icc
F77=$(FC)
F90COPT=-g -CB -no_cpprt
FCOPT=-g -CB -no_cpprt
CCOPT=-g -CB -no_cpprt
F90COPT= -check arg_temp_created
FCOPT=-check arg_temp_created
CCOPT=
####################### Section 2 #######################
# Define your linker and linker flags here #
@@ -64,15 +64,15 @@ MODS=$(LIBDIR)/psb_tools_const$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/
$(.mod).o:
.f.o:
$(FC) $(FCOPT) -I $(INCDIRS) -c $<
$(FC) $(FCOPT) $(INCDIRS) -c $<
.c.o:
$(CC) $(CCOPT) -I $(INCDIRS) $(CDEFINES) -c $<
$(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $<
.f$(.mod):
$(F90) $(FCOPT) -I $(INCDIRS) -c $<
$(F90) $(FCOPT) $(INCDIRS) -c $<
.f90$(.mod):
$(F90) $(F90COPT) -I $(INCDIRS) -c $<
$(F90) $(F90COPT) $(INCDIRS) -c $<
.f90.o:
$(F90) $(F90COPT) -I $(INCDIRS) -c $<
$(F90) $(F90COPT) $(INCDIRS) -c $<
Makefile
+3 -1
View File
@@ -1,10 +1,12 @@
include Make.inc
lib:
library:
( [ -d lib ] || mkdir lib)
(cd src; make lib)
clean:
(cd src; make clean)
veryclean:
(cd src; make veryclean)
(cd lib; /bin/rm -f *.a *$(.mod) V*.inc *.pc *.pcl)
src/comm/Makefile
+1 -1
View File
@@ -4,7 +4,7 @@ OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \
psb_ihalo.o
MPFOBJS = psb_dscatter.o
INCDIRS = ../../lib
INCDIRS = -I ../../lib -I .
lib: mpfobjs $(OBJS)
src/internals/Makefile
+1 -1
View File
@@ -8,7 +8,7 @@ COBJS = avltree.o
MPFOBJS = psi_dswapdata.o psi_dswaptran.o psi_iswapdata.o \
psi_iswaptran.o psi_extrct_dl.o psi_desc_index.o
INCDIRS = ../../lib .
INCDIRS = -I ../../lib -I .
lib: mpfobjs $(FOBJS) $(COBJS)
src/internals/psi_extrct_dl.f
+7 -7
View File
@@ -229,9 +229,9 @@ c$$$ + i, i, -ione ,-ione,-ione)
else
if (me.eq.root) then
if (me.eq.psb_root_) then
do proc=0,np-1
if (proc.ne.root) then
if (proc.ne.psb_root_) then
if (debug) write(0,*) 'receiving from: ',proc
c ...receive from proc length of its dependence list....
call igerv2d(icontxt,1,1,length_dl(proc),1,
@@ -243,14 +243,14 @@ c ...receive from proc its dependence list....
endif
enddo
else if (me.ne.root) then
else if (me.ne.psb_root_) then
c ...send to root dependence list length.....
if (debug) write(0,*) 'sending to: ',me,root
call igesd2d(icontxt,1,1,length_dl(me),1,root,mycol)
if (debug) write(0,*) 'sending to: ',me,root
if (debug) write(0,*) 'sending to: ',me,psb_root_
call igesd2d(icontxt,1,1,length_dl(me),1,psb_root_,mycol)
if (debug) write(0,*) 'sending to: ',me,psb_root_
c ...send to root dependence list....
call igesd2d(icontxt,length_dl(me),1,dep_list(1,me),
+ length_dl(me),root,mycol)
+ length_dl(me),psb_root_,mycol)
endif
end if
src/modules/Makefile
+2 -2
View File
@@ -1,7 +1,7 @@
include ../../Make.inc
MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
psb_desc_type.o \
psb_desc_type.o psb_spsb_mod.o\
psb_blacs_mod.o psb_serial_mod.o psb_tools_mod.o \
psb_prec_type.o psb_error_mod.o psb_prec_mod.o \
psb_methd_mod.o psb_const_mod.o \
@@ -9,7 +9,7 @@ MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
OBJS = error.o parts.o
INCDIRS = ../../lib
INCDIRS = -I ../../lib
psb_realloc_mod.o : psb_error_mod.o
psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o
src/modules/psb_const.fh
+38 -23
View File
@@ -1,8 +1,8 @@
integer, parameter :: psb_nohalo_=0, psb_halo_=4
integer, parameter :: psb_none_=0,psb_sum_=1
integer, parameter :: psb_avg_=2,psb_square_root_=3
integer, parameter :: psb_swap_send_=1,psb_swap_recv_=2
integer, parameter :: psb_swap_sync_=4,psb_swap_mpi_=8
integer, parameter :: psb_nohalo_=0, psb_halo_=4
integer, parameter :: psb_none_=0, psb_sum_=1
integer, parameter :: psb_avg_=2, psb_square_root_=3
integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2
integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8
integer, parameter :: psb_deadlock_check_=0
integer, parameter :: psb_local_mtrx_check_=1
integer, parameter :: psb_local_comm_check_=2
@@ -11,28 +11,43 @@
integer, parameter :: psb_order_communication_=5
integer, parameter :: psb_change_represent_=6
integer, parameter :: psb_loc_to_glob_check_=7
integer, parameter :: psb_convert_halo_=1
integer, parameter :: psb_convert_ovrlap_=2
integer, parameter :: psb_act_ret_=0
integer, parameter :: psb_act_abort_=1, no_err_=0
integer, parameter :: psb_dec_type_=1,psb_m_=2,psb_n_=3
integer, parameter :: psb_n_row_=4,psb_n_col_=5,psb_ctxt_=6
integer, parameter :: psb_convert_halo_=1, psb_convert_ovrlap_=2
integer, parameter :: psb_act_ret_=0, psb_act_abort_=1, no_err_=0
integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3
integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6
integer, parameter :: psb_loc_to_glob_=7
integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=10
integer, parameter :: psb_desc_asb_=3099
integer, parameter :: psb_desc_bld_=psb_desc_asb_+1
integer, parameter :: psb_desc_repl_=3199
integer, parameter :: psb_desc_upd_=psb_desc_bld_+1
integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1
integer, parameter :: psb_upd_glb_=998,psb_upd_loc_=997
integer, parameter :: psb_proc_id_=0,psb_n_elem_recv_=1
integer, parameter :: psb_elem_recv_=2,psb_n_elem_send_=2
integer, parameter :: psb_elem_send_=3,psb_n_ovrlp_elem_=1
integer, parameter :: psb_ovrlp_elem_to_=2,psb_ovrlp_elem_=0
integer, parameter :: psb_nnz_=1, psb_n_dom_ovr_=1
integer, parameter :: psb_no_comm_=-1, psb_nzsizereq_=3
integer, parameter :: ione=1, done=1.d0,izero=0, dzero=0.d0
integer, parameter :: itwo=2, ithree=3,root=0, act_abort=1
integer, parameter :: psb_nztotreq_=1,psb_nzrowreq_=2
character, parameter :: psb_all_='A',psb_topdef_=' '
integer, parameter :: psb_upd_glb_=998, psb_upd_loc_=997
integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1
integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2
integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1
integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0
integer, parameter :: psb_n_dom_ovr_=1
integer, parameter :: psb_nnz_=1
integer, parameter :: psb_no_comm_=-1
integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0
integer, parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0
integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2
integer, parameter :: psb_nzsizereq_=3
integer, parameter :: psb_del_bnd_=6, psb_srtd_=7
integer, parameter :: psb_state_=8, psb_upd_=9
integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10
integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer, parameter :: psb_iflag_=2, psb_ichk_=3
integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
integer, parameter :: psb_perm_update_=98765,psb_isrtdcoo_=98764
integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
integer, parameter :: psb_dbleint_=2
integer, parameter :: act_ret=0, act_abort=1, no_err=0
real(kind(1.d0)), parameter :: psb_colrow_=0.33, psb_percent_=0.7
character, parameter :: psb_all_='A', psb_topdef_=' '
character(len=5) :: psb_fidef_='CSR'
src/modules/psb_const_mod.f90
+9 -2
View File
@@ -24,7 +24,7 @@ module psb_const_mod
integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0, psb_n_dom_ovr_=1
integer, parameter :: psb_nnz_=1
integer, parameter :: psb_no_comm_=-1
integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0
integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0,mone=-1
integer, parameter :: itwo=2, ithree=3, psb_root_=0
integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2, psb_nzsizereq_=3
integer, parameter :: psb_del_bnd_=6, psb_srtd_=7
@@ -32,10 +32,17 @@ module psb_const_mod
integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10
integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer, parameter :: psb_iflag_=2, psb_ichk_=3
integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
integer, parameter :: psb_perm_update_=98765, psb_isrtdcoo_=98764
integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
integer, parameter :: psb_dbleint_=2
real(kind(1.d0)), parameter :: psb_colrow_=0.33
real(kind(1.d0)), parameter :: psb_colrow_=0.33, psb_percent_=0.7
character, parameter :: psb_all_='A', psb_topdef_=' '
character(len=5) :: psb_fidef_='CSR'
src/psblas/psb_ddot.f90
+69 -65
View File
@@ -19,6 +19,7 @@
!
function psb_ddot(x, y,desc_a, info, jx, jy)
use psb_descriptor_type
! use psb_spsb_mod
use psb_error_mod
implicit none
@@ -26,23 +27,24 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
type(psb_desc_type), intent(in) :: desc_a
integer, intent(in), optional :: jx, jy
integer, intent(out) :: info
real(kind(1.D0)) :: f90_psddot
real(kind(1.D0)) :: psb_ddot
! locals
integer :: int_err(5), icontxt, nprow, npcol, me, mycol,&
& err_act, n, iix, jjx, temp(2)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.d0)),pointer :: tmpx(:)
real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot
character(len=20) :: name, ch_err
name='psb_ddot'
info=0
call psb_erractionsave(err_act)
icontxt=desc_data(psb_ctxt_)
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then
info = 2010
call psb_errpush(info,name)
@@ -74,11 +76,11 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
goto 9999
end if
m = desc_a%matrix_data(m_)
m = desc_a%matrix_data(psb_m_)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy)
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect'
@@ -94,29 +96,29 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
if(m.ne.0) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then
dot = ddot(desc_a%matrix_data(psb_n_row_),&
dot_local = ddot(desc_a%matrix_data(psb_n_row_),&
& x(iix,jjx),ione,y(iiy,jjy),ione)
! adjust dot because overlapped elements are computed more than once
! adjust dot_local because overlapped elements are computed more than once
i=1
do while (desc_a%ovrlap_elem(i).ne.-ione)
dot = dot -&
dot_local = dot_local -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& x(iix+desc_a%ovrlap_elem(i)-1,jjx)*
& x(iix+desc_a%ovrlap_elem(i)-1,jjx)*&
& y(iiy+desc_a%ovrlap_elem(i)-1,jjy)
i = i+2
end do
else
dot=0.d0
dot_local=0.d0
end if
else
dot=0.d0
dot_local=0.d0
end if
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,&
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
psb_ddot = dot
psb_ddot = dot_local
call psb_erractionrestore(err_act)
return
@@ -156,20 +158,21 @@ function psb_ddotv(x, y,desc_a, info)
real(kind(1.D0)) :: psb_ddotv
! locals
integer :: int_err(5), icontxt, nprow, npcol, me, mycol,&
& err_act, n, iix, jjx, temp(2)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.d0)),pointer :: tmpx(:)
real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot
character(len=20) :: name, ch_err
name='psb_ddot'
info=0
call psb_erractionsave(err_act)
icontxt=desc_data(psb_ctxt_)
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then
info = 2010
call psb_errpush(info,name)
@@ -183,11 +186,11 @@ function psb_ddotv(x, y,desc_a, info)
ix = ione
iy = ione
m = desc_a%matrix_data(m_)
m = desc_a%matrix_data(psb_m_)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy)
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect'
@@ -203,29 +206,29 @@ function psb_ddotv(x, y,desc_a, info)
if(m.ne.0) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then
dot = ddot(desc_a%matrix_data(psb_n_row_),&
dot_local = ddot(desc_a%matrix_data(psb_n_row_),&
& x,ione,y,ione)
! adjust dot because overlapped elements are computed more than once
! adjust dot_local because overlapped elements are computed more than once
i=1
do while (desc_a%ovrlap_elem(i).ne.-ione)
dot = dot -&
dot_local = dot_local -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& x(desc_a%ovrlap_elem(i))*
& x(desc_a%ovrlap_elem(i))*&
& y(desc_a%ovrlap_elem(i))
i = i+2
end do
else
dot=0.d0
dot_local=0.d0
end if
else
dot=0.d0
dot_local=0.d0
end if
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,&
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
psb_ddotv = dot
psb_ddotv = dot_local
call psb_erractionrestore(err_act)
return
@@ -265,20 +268,21 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
integer, intent(out) :: info
! locals
integer :: int_err(5), icontxt, nprow, npcol, me, mycol,&
& err_act, n, iix, jjx, temp(2)
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.d0)),pointer :: tmpx(:)
real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot
character(len=20) :: name, ch_err
name='psb_ddot'
info=0
call psb_erractionsave(err_act)
icontxt=desc_data(psb_ctxt_)
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then
info = 2010
call psb_errpush(info,name)
@@ -292,11 +296,11 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
ix = ione
iy = ione
m = desc_a%matrix_data(m_)
m = desc_a%matrix_data(psb_m_)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy)
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect'
@@ -312,29 +316,29 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
if(m.ne.0) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then
dot = ddot(desc_a%matrix_data(psb_n_row_),&
dot_local = ddot(desc_a%matrix_data(psb_n_row_),&
& x,ione,y,ione)
! adjust dot because overlapped elements are computed more than once
! adjust dot_local because overlapped elements are computed more than once
i=1
do while (desc_a%ovrlap_elem(i).ne.-ione)
dot = dot -&
dot_local = dot_local -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& x(desc_a%ovrlap_elem(i))*
& x(desc_a%ovrlap_elem(i))*&
& y(desc_a%ovrlap_elem(i))
i = i+2
end do
else
dot=0.d0
dot_local=0.d0
end if
else
dot=0.d0
dot_local=0.d0
end if
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,&
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
res = dot
res = dot_local
call psb_erractionrestore(err_act)
return
@@ -347,7 +351,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
return
end if
return
end function psb_ddotvs
end subroutine psb_ddotvs
@@ -379,20 +383,20 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
integer, intent(out) :: info
! locals
integer :: int_err(5), icontxt, nprow, npcol, me, mycol,&
& err_act, n, iix, jjx, temp(2)
real(kind(1.d0)),pointer :: dot(:)
real(kind(1.D0)) :: dot_local
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.d0)),pointer :: dot_local(:)
real(kind(1.d0)) :: ddot
character(len=20) :: name, ch_err
name='psb_dmdots'
info=0
call psb_erractionsave(err_act)
icontxt=desc_data(psb_ctxt_)
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then
info = 2010
call psb_errpush(info,name)
@@ -407,11 +411,11 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
ix = ione
iy = ione
m = desc_a%matrix_data(m_)
m = desc_a%matrix_data(psb_m_)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy)
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect'
@@ -426,35 +430,35 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
end if
k = min(size(x,2),size(y,2))
allocate(dot(k))
allocate(dot_local(k))
if(m.ne.0) then
if(desc_a%matrix_data(psb_n_row_).gt.0) then
do j=1,k
dot(j) = ddot(desc_a%matrix_data(psb_n_row_),&
dot_local(j) = ddot(desc_a%matrix_data(psb_n_row_),&
& x(iix,jjx+j-1),ione,y(iiy,jjy+j-1),ione)
! adjust dot because overlapped elements are computed more than once
! adjust dot_local because overlapped elements are computed more than once
i=1
do while (desc_a%ovrlap_elem(i).ne.-ione)
dot(j) = dot(j) -&
dot_local(j) = dot_local(j) -&
& (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*&
& x(iix+desc_a%ovrlap_elem(i)-1,jjx+j-1)*
& x(iix+desc_a%ovrlap_elem(i)-1,jjx+j-1)*&
& y(iiy+desc_a%ovrlap_elem(i)-1,jjy+j-1)
i = i+2
end do
end do
else
dot(:)=0.d0
dot_local(:)=0.d0
end if
else
dot(:)=0.d0
dot_local(:)=0.d0
end if
! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,&
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
res(1:k) = dot(1:k)
res(1:k) = dot_local(1:k)
call psb_erractionrestore(err_act)
return
src/serial/Makefile
+35 -20
View File
@@ -1,30 +1,45 @@
include ../../Make.inc
#FCOPT= $(FCOPT)
F90_PSDOBJS= dcsdp90.o dcssm90.o dcssm90v.o dfixcoo.o dipcoo2csr.o dipcsr2coo.o\
dcsprt90.o dspgtdiag.o dspinfo.o dspgtrow.o dspscal.o imsr.o imsrx.o \
dsymbmm90.o dnumbmm90.o drwextd.o dtransp90.o smmp.o dcsmm90.o dcsmv90.o\
dcsrws90.o psdneigh.o psbdcoins.o string_impl.o dcsnmi90.o
FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \
psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \
psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \
psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtrow.o \
psb_dspinfo.o psb_dspscal.o psb_dsymbmm.o psb_dtransp.o \
string_impl.o
LIBDIR= ../../lib
INCLUDES=-I$(LIBDIR) -I..
LIBNAME=$(LIBDIR)/$(F90LIB)
HERE=.
INCDIRS = -I ../../lib -I .
INCDIRS=-I. -I.. -I$(LIBDIR)
lib: auxd cood csrd jadd f77d dpd lib1
lib: $(F90_PSDOBJS)
ar -cur $(LIBNAME) $(F90_PSDOBJS)
ranlib $(LIBNAME)
#$(F90_PSDOBJS): $(MODS)
lib1: $(FOBJS)
.f.o:
$(F90) $(FCOPT) $(INCDIRS) -c $<
veryclean: clean
/bin/rm -f $(LIBNAME)
auxd:
(cd aux; make lib)
clean:
/bin/rm -f $(F90_PSDOBJS) $(LOCAL_MODS)
cood:
(cd coo; make lib)
csrd:
(cd csr; make lib)
jadd:
(cd jad; make lib)
dpd:
(cd dp; make lib)
f77d:
(cd f77; make lib)
clean:
/bin/rm -f $(FOBJS)
(cd aux; make clean)
(cd coo; make clean)
(cd csr; make clean)
(cd jad; make clean)
(cd dp; make clean)
(cd f77; make clean)
src/serial/aux/Makefile
+6 -19
View File
@@ -1,15 +1,10 @@
include ../../../../Make.inc
include ../../../Make.inc
#
# The object files
#
FOBJS = daxpby.o getrepflag.o geterr.o \
isr.o isrx.o lsame.o \
setrepflag.o seterr.o sperror.o \
write_message.o mrgsrt.o xerbla.o \
xsperr.o zaxpby.o zseterr.o \
zsperror.o zwrite_message.o \
zxsperr.o zsetrepflag.o isaperm.o ibsrch.o
FOBJS = isr.o isrx.o lsame.o \
mrgsrt.o isaperm.o ibsrch.o
OBJS=$(FOBJS)
@@ -20,8 +15,7 @@ OBJS=$(FOBJS)
#LIBDIR=../../../LIB
#LIBNAME=libsparker.a
LIBFILE=$(LIBDIR)/$(LIBNAME)
SPARKERDIR=..
INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
INCDIRS=-I. -I$(LIBDIR)
#
# No change should be needed below
@@ -30,15 +24,8 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
default: lib
lib: $(OBJS)
$(AR) $(LIBFILE) $(OBJS)
$(RANLIB) $(LIBFILE)
$(FOBJS): $(SPARKERDIR)/sparker.fh
clean:
/bin/rm -f $(OBJS)
clean: cleanobjs
veryclean: cleanobjs
cleanobjs:
/bin/rm -f $(OBJS)
src/serial/coo/Makefile
+2 -9
View File
@@ -1,13 +1,10 @@
include ../../../../Make.inc
include ../../../Make.inc
#
# The object files
#
FOBJS = dcooprt.o dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o
#FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dsrmv.o dsrsv.o dcrnrmi.o dcrrs.o \
# dcrupdate.o dcooprt.o
FOBJS = dcooprt.o dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o\
zcoonrmi.o zcoomm.o zcoomv.o zcoosm.o zcoosv.o zcooprt.o
#zcsrck.o zcrnrmi.o zcsrmm.o zsrmv.o zcsrsm.o zsrsv.o
@@ -30,10 +27,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
default: lib
lib: $(OBJS)
$(AR) $(LIBFILE) $(OBJS)
$(RANLIB) $(LIBFILE)
$(OBJS): $(SPARKERDIR)/sparker.fh
clean: cleanobjs
src/serial/csr/Makefile
+3 -11
View File
@@ -1,4 +1,4 @@
include ../../../../Make.inc
include ../../../Make.inc
#
# The object files
@@ -6,19 +6,16 @@ include ../../../../Make.inc
FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \
dcrcrupd.o dcocrupd.o dcsrprt.o dcsrmv4.o dcsrmv2.o dcsrmv3.o\
zcsrck.o zcrnrmi.o zcsrmm.o zsrmv.o zcsrsm.o zsrsv.o \
zcrcrupd.o zcocrupd.o zcsrprt.o
OBJS=$(FOBJS)
#
# Where the library should go, and how it is called.
# Note that we are regenerating most of libsparker.a on the fly.
#LIBDIR=../../LIB
LIBDIR=../../../lib
#LIBNAME=libsparker.a
LIBFILE=$(LIBDIR)/$(LIBNAME)
SPARKERDIR=..
INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
INCDIRS=-I. -I$(LIBDIR)
#
# No change should be needed below
@@ -28,11 +25,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
default: lib
lib: $(OBJS)
$(AR) $(LIBFILE) $(OBJS)
$(RANLIB) $(LIBFILE)
$(OBJS): $(SPARKERDIR)/sparker.fh
clean: cleanobjs
src/serial/csr/dcocrupd.f
+5 -5
View File
@@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value;
C Flag = 2: sum block value to elements;
C
IMPLICIT NONE
include 'sparker.fh'
include 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER IA, JA, IH, JH, M, N,
+ IERROR, FLAG, LIWORK
@@ -27,18 +27,18 @@ C .. Local scalars ..
C .. Local arrays ..
IERROR = 0
c$$$ write(0,*) 'dcocrupd ',infoa(upd_),ibits(infoa(upd_),2,1)
IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN
IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN
C
C Smart update capability
C
IP1 = INFOA(UPD_PNT_)
NNZ = IA2(IP1+NNZ_)
IP1 = INFOA(PSB_UPD_PNT_)
NNZ = IA2(IP1+PSB_NNZ_)
NNZI = INFOH(1)
DO J = 1, NNZI
NNZ = NNZ + 1
A(NNZ) = H(J)
ENDDO
IA2(IP1+NNZ_) = NNZ
IA2(IP1+PSB_NNZ_) = NNZ
ELSE
IERROR = 2
ENDIF
src/serial/csr/dcrcrupd.f
+5 -5
View File
@@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value;
C Flag = 2: sum block value to elements;
C
IMPLICIT NONE
include 'sparker.fh'
include 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER IA, JA, IH, JH, M, N,
+ IERROR, FLAG, LIWORK
@@ -28,12 +28,12 @@ C .. Local scalars ..
C .. Local arrays ..
IERROR = 0
c$$$ write(0,*) 'dcrcrupd ',infoa(upd_),ibits(infoa(upd_),2,1)
IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN
IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN
C
C Smart update capability
C
IP1 = INFOA(UPD_PNT_)
NNZ = IA2(IP1+NNZ_)
IP1 = INFOA(PSB_UPD_PNT_)
NNZ = IA2(IP1+PSB_NNZ_)
DO I = 1, M
XBLCK = IH + I - 1
DO J = IH2(XBLCK),IH2(XBLCK+1) - 1
@@ -41,7 +41,7 @@ C
A(NNZ) = H(J)
ENDDO
ENDDO
IA2(IP1+NNZ_) = NNZ
IA2(IP1+PSB_NNZ_) = NNZ
ELSE
IF (FLAG.EQ.0) THEN
DO I = 1, M
src/serial/dp/Makefile
+5 -11
View File
@@ -1,13 +1,12 @@
include ../../../../Make.inc
include ../../../Make.inc
#
# The object files
#
FOBJS = dcrcr.o dcrdi.o dcrel.o dcrjd.o dgblock.o partition.o \
dgindex.o djadrp.o djadrp1.o dcsrrp.o dcsrp1.o check_dim.o \
Max_nnzero.o dcoco.o dcocr.o dcrco.o dcrinco.o djdcox.o djdco.o dvtfg.o dgind_tri.o \
gen_block.o dcoinco.o reordvn.o zreordvn.o\
zcrcr.o zcsrrp.o zcsrp1.o zgindex.o zgind_tri.o zcocr.o zcrinco.o zcoco.o
Max_nnzero.o dcoco.o dcocr.o dcrco.o djdcox.o djdco.o dvtfg.o dgind_tri.o \
gen_block.o reordvn.o
#
# dgind_tri.o
@@ -19,11 +18,10 @@ OBJS=$(FOBJS)
#
# Where the library should go, and how it is called.
# Note that we are regenerating most of libsparker.a on the fly.
#LIBDIR=../../LIB
LIBDIR=../../../lib
#LIBNAME=libsparker.a
LIBFILE=$(LIBDIR)/$(LIBNAME)
SPARKERDIR=..
INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
INCDIRS=-I. -I$(LIBDIR)
#
# No change should be needed below
@@ -31,10 +29,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
lib: $(FOBJS)
$(AR) $(LIBFILE) $(OBJS)
$(RANLIB) $(LIBFILE)
$(FOBJS): $(SPARKERDIR)/sparker.fh
clean: cleanobjs
src/serial/dp/check_dim.f
+4 -4
View File
@@ -2,14 +2,14 @@
+ NZ, LARN, LIAN1, LIAN2, IERRV)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
INTEGER M,N,NG,LARN,LIAN1,LIAN2, NZ
C .. Array Arguments ..
INTEGER IA(3,*), RES(*), IA2(*), IERRV(*)
INTEGER IA(3,*), IA2(*), IERRV(*)
C Local scalars
INTEGER NNZ, BLOCK, DIM_BLOCK, LIMIT
@@ -21,11 +21,11 @@ C Local scalars
NNZ = NZ
LIMIT = INT(DIM_BLOCK*PERCENT)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
DO BLOCK = 1, NG
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PERCENT)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
NNZ = NNZ+(DIM_BLOCK-LIMIT)*MAX_NZ
END DO
src/serial/dp/dcoco.f
+202 -202
View File
@@ -1,250 +1,250 @@
C Covert matrix from COO format to COO Format
C
SUBROUTINE DCOCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO,
* P1,DESCRN,ARN,IA1N,IA2N,INFON,P2,LARN,LIA1N,
* LIA2N,AUX,LAUX,IERROR)
c covert matrix from COO format to COO format
c
subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info,
* p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n,
* lia2n,aux,laux,ierror)
IMPLICIT NONE
INCLUDE 'sparker.fh'
implicit none
include 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER LARN, LAUX, LIA1N, LIA2N,
+ M, N, IERROR
CHARACTER TRANS,UNITD
C .. Array Arguments ..
DOUBLE PRECISION AR(*), ARN(*), D(*)
INTEGER AUX(0:LAUX-1)
INTEGER IA1(*), IA2(*), INFO(*), IA1N(*), IA2N(*),
* INFON(*), P1(*), P2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER IPX, IP1, IP2, CHECK_FLAG
INTEGER NNZ, K, I, J, NZL, IRET
INTEGER ELEM_IN, ELEM_OUT
LOGICAL SCALE
INTEGER MAX_NNZERO
c .. scalar arguments ..
integer larn, laux, lia1n, lia2n,
+ m, n, ierror
character trans,unitd
c .. array arguments ..
double precision ar(*), arn(*), d(*)
integer aux(0:laux-1)
integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*),
* infon(*), p1(*), p2(*)
character descra*11, descrn*11
c .. local scalars ..
integer ipx, ip1, ip2, check_flag, err_act
integer nnz, k, i, j, nzl, iret
integer elem_in, elem_out
logical scale
integer max_nnzero
logical debug
parameter (debug=.false.)
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5)
C
C ...Common variables...
C This flag describe the action to do
c .. local arrays ..
character*20 name
integer int_val(5)
c
c ...common variables...
c this flag describe the action to do
C .. External Subroutines ..
EXTERNAL MAX_NNZERO
C .. Executable Statements ..
C
c .. external subroutines ..
external max_nnzero
c .. executable statements ..
c
NAME = 'DCOCO\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
name = 'dcoco\0'
ierror = 0
call fcpsb_erractionsave(err_act)
CHECK_FLAG=IBITS(info(upd_),1,2)
IF (TRANS.EQ.'N') THEN
SCALE = (UNITD.EQ.'L') ! meaningless
P1(1) = 0
P2(1) = 0
check_flag=ibits(info(psb_upd_),1,2)
if (trans.eq.'N') then
scale = (unitd.eq.'L') ! meaningless
p1(1) = 0
p2(1) = 0
NNZ = INFO(nnz_)
nnz = info(psb_nnz_)
if (debug) then
write(*,*) 'On entry to DCOCO: NNZ LAUX ',
write(*,*) 'on entry to dcoco: nnz laux ',
+ nnz,laux,larn,lia1n,lia2n
endif
IF (LAUX.LT.NNZ+2) THEN
IERROR = 60
INT_VAL(1) = 22
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LARN.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 18
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA1N.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 19
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA2N.LT.M+1) THEN
IERROR = 60
INT_VAL(1) = 20
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ENDIF
if (laux.lt.nnz+2) then
ierror = 60
int_val(1) = 22
int_val(2) = nnz+2
int_val(3) = laux
else if (larn.lt.nnz) then
ierror = 60
int_val(1) = 18
int_val(2) = nnz+2
int_val(3) = laux
else if (lia1n.lt.nnz) then
ierror = 60
int_val(1) = 19
int_val(2) = nnz+2
int_val(3) = laux
else if (lia2n.lt.m+1) then
ierror = 60
int_val(1) = 20
int_val(2) = nnz+2
int_val(3) = laux
endif
C
C Error handling
C
IF(IERROR.NE.0) THEN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
c
c error handling
c
if(ierror.ne.0) then
call fcpsb_errpush(ierror,name,int_val)
goto 9999
end if
IF (DESCRA(1:1).EQ.'G') THEN
C
C Sort COO data structure
C
if (debug) write(*,*)'First sort',nnz
if (descra(1:1).eq.'G') then
c
c sort COO data structure
c
if (debug) write(*,*)'first sort',nnz
do k=1, nnz
arn(k) = ar(k)
ia1n(k) = ia1(k)
ia2n(k) = ia2(k)
enddo
if (debug) write(*,*)'Second sort'
if (debug) write(*,*)'second sort'
if ((lia2n.ge.(2*nnz+ireg_flgs+1))
if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then
C
C Prepare for smart regeneration
c
c prepare for smart regeneration
c
ipx = nnz+3
do i=1, nnz
aux(ipx+i-1) = i
enddo
ip1 = nnz+2
infon(upd_pnt_) = ip1
ip2 = ip1+ireg_flgs
ia2n(ip1+ip2_) = ip2
ia2n(ip1+iflag_) = check_flag
ia2n(ip1+nnzt_) = nnz
ia2n(ip1+nnz_) = 0
ia2n(ip1+ichk_) = nnz+check_flag
if (debug) write(0,*) 'Build check :',ia2n(ip1+nnzt_)
ip1 = nnz+2
infon(psb_upd_pnt_) = ip1
ip2 = ip1+psb_ireg_flgs_
ia2n(ip1+psb_ip2_) = ip2
ia2n(ip1+psb_iflag_) = check_flag
ia2n(ip1+psb_nnzt_) = nnz
ia2n(ip1+psb_nnz_) = 0
ia2n(ip1+psb_ichk_) = nnz+check_flag
if (debug) write(0,*) 'build check :',ia2n(ip1+psb_nnzt_)
C .... Order with key IA1N ...
CALL MRGSRT(NNZ,IA1N,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN3(NNZ,ARN,IA1N,IA2N,AUX(IPX),AUX)
C .... Order with key IA2N ...
c .... order with key ia1n ...
call mrgsrt(nnz,ia1n,aux,iret)
if (iret.eq.0) call reordvn3(nnz,arn,ia1n,ia2n,aux(ipx),aux)
c .... order with key ia2n ...
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
+ (J.LE.NNZ))
J = J+1
ENDDO
NZL = J - I
CALL MRGSRT(NZL,IA2N(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN3(NZL,ARN(I),IA1N(I),IA2N(I),
+ AUX(IPX+I-1),AUX)
I = J
ENDDO
i = 1
j = i
do while (i.le.nnz)
do while ((ia1n(j).eq.ia1n(i)).and.
+ (j.le.nnz))
j = j+1
enddo
nzl = j - i
call mrgsrt(nzl,ia2n(i),aux,iret)
if (iret.eq.0) call reordvn3(nzl,arn(i),ia1n(i),ia2n(i),
+ aux(ipx+i-1),aux)
i = j
enddo
ia2n(ip2+aux(ipx+1-1)-1) = 1
C ... Construct final COO Representation...
ELEM_OUT = 1
C ... Insert remaining element ...
DO ELEM_IN = 2, NNZ
IF ((IA1N(ELEM_IN).EQ.IA1N(ELEM_OUT)).AND.
+ (IA2N(ELEM_IN).EQ.IA2N(ELEM_OUT))) THEN
IF (CHECK_FLAG.EQ.1) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN
C ... Insert only the first duplicated element ...
c ... construct final COO representation...
elem_out = 1
c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.2) then
c ... insert only the first duplicated element ...
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
ELSE IF (CHECK_FLAG.EQ.3) THEN
C ... Sum the duplicated element ...
ARN(ELEM_OUT) = ARN(ELEM_OUT) + ARN(ELEM_IN)
else if (check_flag.eq.3) then
c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
END IF
ELSE
ELEM_OUT = ELEM_OUT + 1
ARN(ELEM_OUT) = ARN(ELEM_IN)
end if
else
elem_out = elem_out + 1
arn(elem_out) = arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
IA1N(ELEM_OUT) = IA1N(ELEM_IN)
IA2N(ELEM_OUT) = IA2N(ELEM_IN)
ENDIF
ENDDO
ia1n(elem_out) = ia1n(elem_in)
ia2n(elem_out) = ia2n(elem_in)
endif
enddo
ELSE
else
C .... Order with key IA1N ...
CALL MRGSRT(NNZ,IA1N,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX)
C .... Order with key IA2N ...
c .... order with key ia1n ...
call mrgsrt(nnz,ia1n,aux,iret)
if (iret.eq.0) call reordvn(nnz,arn,ia1n,ia2n,aux)
c .... order with key ia2n ...
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
+ (J.LE.NNZ))
J = J+1
ENDDO
NZL = J - I
CALL MRGSRT(NZL,IA2N(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I),
+ AUX)
I = J
ENDDO
C ... Construct final COO Representation...
ELEM_OUT = 1
C ... Insert remaining element ...
DO ELEM_IN = 2, NNZ
IF ((IA1N(ELEM_IN).EQ.IA1N(ELEM_OUT)).AND.
+ (IA2N(ELEM_IN).EQ.IA2N(ELEM_OUT))) THEN
IF (CHECK_FLAG.EQ.1) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.2) THEN
C ... Insert only the first duplicated element ...
ELSE IF (CHECK_FLAG.EQ.3) THEN
C ... Sum the duplicated element ...
ARN(ELEM_OUT) = ARN(ELEM_OUT) + ARN(ELEM_IN)
END IF
ELSE
ELEM_OUT = ELEM_OUT + 1
ARN(ELEM_OUT) = ARN(ELEM_IN)
IA1N(ELEM_OUT) = IA1N(ELEM_IN)
IA2N(ELEM_OUT) = IA2N(ELEM_IN)
ENDIF
ENDDO
ENDIF
INFON(nnz_) = ELEM_OUT
infon(srtd_) = isrtdcoo
i = 1
j = i
do while (i.le.nnz)
do while ((ia1n(j).eq.ia1n(i)).and.
+ (j.le.nnz))
j = j+1
enddo
nzl = j - i
call mrgsrt(nzl,ia2n(i),aux,iret)
if (iret.eq.0) call reordvn(nzl,arn(i),ia1n(i),ia2n(i),
+ aux)
i = j
enddo
c ... construct final COO representation...
elem_out = 1
c ... insert remaining element ...
do elem_in = 2, nnz
if ((ia1n(elem_in).eq.ia1n(elem_out)).and.
+ (ia2n(elem_in).eq.ia2n(elem_out))) then
if (check_flag.eq.1) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.2) then
c ... insert only the first duplicated element ...
else if (check_flag.eq.3) then
c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in)
end if
else
elem_out = elem_out + 1
arn(elem_out) = arn(elem_in)
ia1n(elem_out) = ia1n(elem_in)
ia2n(elem_out) = ia2n(elem_in)
endif
enddo
endif
infon(psb_nnz_) = elem_out
infon(psb_srtd_) = psb_isrtdcoo_
if (debug) write(*,*)'Done Rebuild COO',infon(1)
if (debug) write(*,*)'done rebuild COO',infon(1)
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
DO 20 K = 1, M
P2(K) = K
20 CONTINUE
do 20 k = 1, m
p2(k) = k
20 continue
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
END IF
C
ELSE IF (TRANS.NE.'N') THEN
C
C TO DO
C
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
end if
c
else if (trans.ne.'N') then
c
c to do
c
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
END IF
end if
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
RETURN
call fcpsb_erractionrestore(err_act)
return
9999 CONTINUE
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
9999 continue
call fcpsb_erractionrestore(err_act)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
ENDIF
if ( err_act .ne. 0 ) then
call fcpsb_serror()
return
endif
RETURN
END
return
end
src/serial/dp/dcocr.f
+16 -20
View File
@@ -6,7 +6,7 @@ C
* LIAN2,AUX,LAUX,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
@@ -21,7 +21,7 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER NNZ, K, ROW, I, J, NZL, IRET
integer ipx, ip1, ip2, CHECK_FLAG
integer ipx, ip1, ip2, CHECK_FLAG, err_act
INTEGER ELEM, ELEM_CSR
LOGICAL SCALE
INTEGER MAX_NNZERO
@@ -43,10 +43,10 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
CHECK_FLAG=IBITS(INFO(UPD_),1,2)
CHECK_FLAG=IBITS(INFO(PSB_UPD_),1,2)
c$$$ write(0,*) 'DCOCR FLAG ',info(upd_),check_flag
IF (TRANS.EQ.'N') THEN
IERRV(1) = 0
SCALE = (UNITD.EQ.'L') ! meaningless
P1(1) = 0
P2(1) = 0
@@ -66,12 +66,12 @@ c$$$ write(0,*) 'DCOCR FLAG ',info(upd_),check_flag
INT_VAL(1) = 18
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA1N.LT.NNZ) THEN
ELSE IF (LIAN1.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 19
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA2N.LT.M+1) THEN
ELSE IF (LIAN2.LT.M+1) THEN
IERROR = 60
INT_VAL(1) = 20
INT_VAL(2) = NNZ+2
@@ -96,7 +96,7 @@ c$$$ do k=1,nnz
c$$$ write(*,*) k,ia(k),ja(k),ar(k)
c$$$ enddo
c$$$ endif
if ((lian2.ge.((m+1)+nnz+ireg_flgs+1))
if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then
C
C Prepare for smart regeneration
@@ -106,19 +106,19 @@ c
do i=1, nnz
aux(ipx+i-1) = i
enddo
ip1 = m+2
infon(upd_pnt_) = ip1
ip2 = ip1+ireg_flgs
ian2(ip1+ip2_) = ip2
ian2(ip1+iflag_) = check_flag
ian2(ip1+nnzt_) = nnz
ian2(ip1+nnz_) = 0
ian2(ip1+ichk_) = nnz+check_flag
ip1 = m+2
infon(psb_upd_pnt_) = ip1
ip2 = ip1+psb_ireg_flgs_
ian2(ip1+psb_ip2_) = ip2
ian2(ip1+psb_iflag_) = check_flag
ian2(ip1+psb_nnzt_) = nnz
ian2(ip1+psb_nnz_) = 0
ian2(ip1+psb_ichk_) = nnz+check_flag
c$$$ write(0,*)'DCOCR m,ip1,ip2,nnz',m,
c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_)
if (debug) write(0,*) 'Build check :',ian2(ip1+nnzt_)
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_)
C .... Order with key IA ...
CALL MRGSRT(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
@@ -152,10 +152,6 @@ c$$$ + (J.LE.NNZ))
I = J
ENDDO
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
src/serial/dp/dcoinco.f
+1 -1
View File
@@ -3,7 +3,7 @@
+ DESCRH,H,IH1,IH2,INFOH,IH,JH,WORK,LWORK,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER LWORK, M, N, IERROR
INTEGER LATOT,LIA1TOT,LIA2TOT,IA,JA,IH,JH
src/serial/dp/dcrco.f
+2 -2
View File
@@ -3,7 +3,7 @@
* LIAN2,AUX,LAUX,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
@@ -16,7 +16,7 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER NNZ, K, ROW, J
INTEGER ELEM
INTEGER ELEM, ERR_ACT
LOGICAL SCALE
INTEGER MAX_NNZERO
c .. Local Arrays ..
src/serial/dp/dcrcr.f
+1 -1
View File
@@ -144,7 +144,7 @@ C .. Array Arguments ..
* INFOA(*), INFON(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER I, J
INTEGER I, J, ERR_ACT
LOGICAL EXIT
c .. Local Arrays ..
CHARACTER*20 NAME
src/serial/dp/dcrinco.f
+1 -1
View File
@@ -2,7 +2,7 @@
+ INFOA,IA,JA,LATOT,LIA1TOT,LIA2TOT,
+ DESCRH,H,IH1,IH2,INFOH,IH,JH,WORK,LWORK,IERRV)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER LWORK, M, N
INTEGER LATOT,LIA1TOT,LIA2TOT,IA,JA,IH,JH
src/serial/dp/dcrjd.f
+6 -6
View File
@@ -30,7 +30,7 @@ C ARN,IAN1
C IAN2,INFON, IP1, IP2
C
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
@@ -44,7 +44,7 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER IOFF, ISTROW, NJA, NZ, PIA,
+ PJA, PNG, K, MAX_NG, NG, IERROR, LJA, ERR_ACT
+ PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT
LOGICAL SCALE
logical debug
parameter (debug=.false.)
@@ -52,7 +52,7 @@ C .. Local Scalars ..
INTEGER MAX_NNZERO
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5), IERRV(*)
INTEGER INT_VAL(5), IERRV(5)
C .. External Subroutines ..
EXTERNAL DVTFG
@@ -89,15 +89,15 @@ C
C
C CHECK ON DIMENSION OF IAN2 AND AUX
C
MAX_NG = M/MINJDROWS+1
MAX_NG = M/PSB_MINJDROWS_+1
IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN
C ... If I haven't sufficent memory to compute NG in IAN2 ...
IF (M+1+3*(MAX_NG+1)/DBLEINT_+1.GT.LAUX) THEN
IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN
C ... If I haven't sufficent memory to compute NG in AUX ...
IERROR = 60
INT_VAL(1) = 22
INT_VAL(2) = M+1+3*(MAX_NG+1)/DBLEINT_+1
INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1
INT_VAL(3) = LAUX
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
src/serial/dp/dcsrp1.f
+6 -6
View File
@@ -87,7 +87,7 @@ C
SUBROUTINE DCSRP1(TRANS,M,N,DESCRA,JA,IA,
+ P,WORK,IWORK,LWORK,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER LWORK,M, N, IERROR
CHARACTER TRANS
@@ -96,7 +96,7 @@ C .. Array Arguments ..
INTEGER JA(*), IA(*), P(*), IWORK(*)
CHARACTER DESCRA*11
C .. Local Scalars ..
INTEGER I, J
INTEGER I, J, ERR_ACT
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5)
@@ -122,9 +122,9 @@ C LWORK refers here to INTEGER IWORK (alias for WORK)
C
IF(LWORK.LT.M) THEN
IERROR = 60
INT_VAL(1) = 18
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
INT_VAL(1) = 10
INT_VAL(2) = M
INT_VAL(3) = LWORK
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
@@ -145,7 +145,7 @@ C
C
C WORK(1) refers here to a value for a DOUBLE PRECISION WORK
C
WORK(1) = DBLE((M+1)/DBLEINT_)
WORK(1) = DBLE((M+1)/PSB_DBLEINT_)
ENDIF
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
src/serial/dp/dcsrrp.f
+2
View File
@@ -99,6 +99,8 @@ C .. Array Arguments ..
DOUBLE PRECISION WORK(*)
INTEGER JA(*), IA(*), P(*)
CHARACTER DESCRA*11
C .. Local Scalars ..
INTEGER ERR_ACT
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5)
src/serial/dp/dgind_tri.f
+3 -3
View File
@@ -2,7 +2,7 @@
+ LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C ... Scalar arguments ...
@@ -16,7 +16,7 @@ C ... Array arguments ...
C .... Local scalars ...
INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA,
+ DIM_BLOCK, LIMIT
+ DIM_BLOCK, LIMIT, ERR_ACT
LOGICAL CSR
c .. Local Arrays ..
CHARACTER*20 NAME
@@ -49,7 +49,7 @@ C .... Invert Permutation Matrix...
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PERCENT)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
src/serial/dp/dgindex.f
+18 -17
View File
@@ -2,7 +2,7 @@
+ LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C ... Scalar arguments ...
INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA,
@@ -16,7 +16,8 @@ C ... Array arguments ...
C .... Local scalars ...
INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1,
+ IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG
+ IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
+ ERR_ACT
LOGICAL CSR
c .. Local Arrays ..
CHARACTER*20 NAME
@@ -28,7 +29,7 @@ c .. Local Arrays ..
POINT_AR = 1
POINT_JA = 0
CHECK_FLAG=IBITS(INFON(UPD_),1,2)
CHECK_FLAG=IBITS(INFON(PSB_UPD_),1,2)
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
@@ -56,18 +57,18 @@ C Prepare for smart regeneration
C
IPW = M + 2
IP1 = (LKA-IREG_FLGS-2)/2
IP2 = IP1+IREG_FLGS
IP1 = (LKA-PSB_IREG_FLGS_-2)/2
IP2 = IP1+PSB_IREG_FLGS_
IPC = IP2 + NNZ + 1
KA(IP1 + IPC_) = IPC
KA(IP1+IP2_) = IP2
INFON(UPD_PNT_) = IP1
KA(IP1+IFLAG_) = CHECK_FLAG
KA(IP1+NNZT_) = NNZ
KA(IP1+NNZ_) = 0
KA(IP1+ICHK_) = NNZ+CHECK_FLAG
KA(IP1 + PSB_IPC_) = IPC
KA(IP1+PSB_IP2_) = IP2
INFON(PSB_UPD_PNT_) = IP1
KA(IP1+PSB_IFLAG_) = CHECK_FLAG
KA(IP1+PSB_NNZT_) = NNZ
KA(IP1+PSB_NNZ_) = 0
KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG
I = M+2
IPX = IA2(I+IP2_)
IPX = IA2(I+PSB_IP2_)
C Invert permutation for smart regeneration
@@ -81,12 +82,12 @@ C Construct JAD matrix...
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block
if (dim_block .gt. maxjdrows) then
if (dim_block .gt. PSB_MAXJDROWS_) then
write(0,*) 'Wrong value for dim_block',block,
+ IA(1,BLOCK+1),IA(1,BLOCK)
return
endif
LIMIT = INT(DIM_BLOCK*PERCENT)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
@@ -244,7 +245,7 @@ c$$$ c write(*,*)'inizio a ciclare sui blocchi'
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PERCENT)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
@@ -386,7 +387,7 @@ C ... For each nnzero elements belonging to current row ...
ENDIF
IA(2,N_BLOCKS+1) = POINT_JA
KA(IP1 + ZERO_) = COUNT
KA(IP1 + PSB_ZERO_) = COUNT
IF(POINT_AR.GE.IP1) THEN
SIZE_REQ=NNZ+COUNT
src/serial/dp/djadrp.f
+1 -1
View File
@@ -95,7 +95,7 @@ C .. Array Arguments ..
INTEGER JA(*), IA(*), P(*)
CHARACTER DESCRA*11
C .. Local Scalars ..
INTEGER PIA, PJA, PNG, IOFF
INTEGER PIA, PJA, PNG, IOFF, ERR_ACT
C .. Intrinsic Functions ..
INTRINSIC DBLE
c .. Local Arrays ..
src/serial/dp/djadrp1.f
+1 -1
View File
@@ -80,7 +80,7 @@ C .. Array Arguments ..
INTEGER KA(*), JA(*), IA(3,*), P(*), IWORK(LWORK)
CHARACTER DESCRA*11
C .. Local Scalars ..
INTEGER I, K, IPG
INTEGER I, K, IPG, ERR_ACT
C .. Intrinsic Functions ..
INTRINSIC DBLE
LOGICAL DEBUG
src/serial/dp/djdco.f
+2 -2
View File
@@ -2,7 +2,7 @@
* IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N,
* LIA2N,AUX,LAUX,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
INTEGER LARN, LAUX, LIA1N, LIA2N, M, N, IERROR
@@ -14,7 +14,7 @@ C .. Array Arguments ..
* IA2N(*), INFON(*), IP1(*), IP2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER PIA, PJA, PNG
INTEGER PIA, PJA, PNG, ERR_ACT
logical debug
parameter (debug=.false.)
c .. Local Arrays ..
src/serial/dp/djdcox.f
+2 -2
View File
@@ -7,7 +7,7 @@ C
* LIA2N,AUX,LAUX,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C
C .. Scalar Arguments ..
@@ -21,7 +21,7 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER IPX, IPG, NNZ, K, ROW,
* I, J, NZL, IRET
* I, J, NZL, IRET, ERR_ACT
LOGICAL SCALE
logical debug
parameter (debug=.false.)
src/serial/dp/gen_block.f
+4 -4
View File
@@ -1,7 +1,7 @@
SUBROUTINE GEN_BLOCK(M,NG,IA,AUX)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
INTEGER M, NG
INTEGER IA(3,*), AUX(*)
@@ -13,9 +13,9 @@
AUX(1) = 1
DO WHILE(.TRUE.)
IF (N_ROWS.GT.MAXJDROWS) THEN
AUX(BLOCK) = AUX(BLOCK-1)+MAXJDROWS
N_ROWS = N_ROWS-MAXJDROWS
IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN
AUX(BLOCK) = AUX(BLOCK-1)+PSB_MAXJDROWS_
N_ROWS = N_ROWS-PSB_MAXJDROWS_
BLOCK = BLOCK+1
ELSE IF (N_ROWS.GT.0) THEN
AUX(BLOCK) = AUX(BLOCK-1)+N_ROWS
src/serial/dp/partition.f
+5 -5
View File
@@ -1,7 +1,7 @@
SUBROUTINE PARTITION(M, WORK, IA, N_BLOCK)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C ...Scalar arguments...
@@ -24,11 +24,11 @@ C ...Local scalars...
IA(1,1) = 1
DO WHILE(.TRUE.)
IF (N_ROWS.GT.MAXJDROWS) THEN
IA(1,BLOCK) = IA(1,BLOCK-1)+MAXJDROWS
N_ROWS = N_ROWS-MAXJDROWS
IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN
IA(1,BLOCK) = IA(1,BLOCK-1)+PSB_MAXJDROWS_
N_ROWS = N_ROWS-PSB_MAXJDROWS_
BLOCK = BLOCK+1
ELSE IF (N_ROWS.GE.MINJDROWS) THEN
ELSE IF (N_ROWS.GE.PSB_MINJDROWS_) THEN
IA(1,BLOCK) = IA(1,BLOCK-1)+N_ROWS
N_ROWS = 0
BLOCK = BLOCK+1
src/serial/f77/dcsmm.f
+7 -9
View File
@@ -161,6 +161,8 @@ C
SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2,
& INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
IMPLICIT NONE
INCLUDE 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER M,N,K,LDB,LDC,LWORK, IERROR
CHARACTER TRANS
@@ -170,17 +172,13 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, FIDA*5
DOUBLE PRECISION A(*),B(LDB,*),C(LDC,*),WORK(*)
C .. Local Scalars ..
INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P
INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT
LOGICAL LP, RP
C .. Local Array..
INTEGER INT_VAL(5)
CHARACTER*20 NAME
DOUBLE PRECISION REAL_VAL(5)
CHARACTER*30 STRINGS(2)
C .. Parameters ..
DOUBLE PRECISION ZERO
INTEGER IONE
PARAMETER (ZERO=0.D0,IONE=1)
C .. External Subroutines ..
EXTERNAL DSWMM, DLPUPD, DSCAL, XERBLA
C .. Intrinsic Functions ..
@@ -271,9 +269,9 @@ C
C Both right and left permutation required
C
P=LWORKB+1
CALL DLPUPD(K,N,PR,B,LDB,ZERO,WORK,K)
CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K)
CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA,
& WORK,K,ZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR)
& WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR)
LWORKS = IDINT(WORK(P+LWORKC))
IF(IERROR .NE. 0) THEN
IERROR=4011
@@ -286,7 +284,7 @@ C
C Only right permutation required
C
P=LWORKB+1
CALL DLPUPD(K,N,PR,B,LDB,ZERO,WORK,K)
CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K)
CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA,
& WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR)
LWORKS = IDINT(WORK(P))
@@ -301,7 +299,7 @@ C Only left permutation required
C
P=LWORKC+1
CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA,
& B,LDB,ZERO,WORK,M,WORK(P),LWORKS,IERROR)
& B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR)
LWORKS = IDINT(WORK(P))
IF(IERROR .NE. 0) THEN
IERROR=4011
src/serial/f77/dcsnmi.f
+2 -2
View File
@@ -73,10 +73,11 @@ C .. Array Arguments ..
INTEGER IA1(*),IA2(*),INFOA(*)
CHARACTER DESCRA*11, FIDA*5
DOUBLE PRECISION A(*)
C .. Local Scalars..
INTEGER ERR_ACT
C .. Local Array..
INTEGER INT_VAL(5)
DOUBLE PRECISION REAL_VAL(5)
CHARACTER*30 NAME, STRINGS(2)
C .. External Subroutines ..
DOUBLE PRECISION DCRNRMI, DJDNRMI, DCOONRMI
EXTERNAL DCRNRMI, DJDNRMI, DCOONRMI
@@ -103,7 +104,6 @@ C
ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN
IERROR = 40
INT_VAL(1) = 1
STRINGS(1) = TRANS//'\0'
ENDIF
C
src/serial/f77/dcsrp.f
+2
View File
@@ -92,6 +92,8 @@ C
C .. Scalar Arguments ..
INTEGER LWORK, M, N, IERROR
CHARACTER TRANS
C .. Local Scalars..
INTEGER ERR_ACT
C .. Array Arguments ..
DOUBLE PRECISION WORK(LWORK)
INTEGER IA1(*), IA2(*), INFOA(*), P(*), INT_VAL(5)
src/serial/f77/dcssm.f
+1 -1
View File
@@ -175,7 +175,7 @@ C .. Array Arguments ..
INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*)
CHARACTER DESCRT*11, FIDT*5
C .. Local Scalars ..
INTEGER LWORKM, LWORKB, LWORKS, P
INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT
DOUBLE PRECISION ZERO
LOGICAL LP, RP
C .. Local Array..
src/serial/f77/dcsupd.f
+2
View File
@@ -12,6 +12,8 @@ C .. Array Arguments ..
+ GLOB_TO_LOC(*)
CHARACTER DESCRA*11,DESCRH*11, FIDA*5, FIDH*5
DOUBLE PRECISION A(*),H(*)
C .. Local Scalars..
INTEGER ERR_ACT
C .. Local Array..
integer int_val(5)
double precision real_val(5)
src/serial/f77/dgelp.f
+3 -1
View File
@@ -68,8 +68,10 @@ C .. Array Arguments ..
DOUBLE PRECISION B(LDB,*), WORK(*)
INTEGER P(*)
C .. Local Scalars ..
INTEGER I, J
INTEGER I, J, ERR_ACT
logical istran,isnotran
C .. Local Arrays..
INTEGER INT_VAL
C .. Intrinsic Functions ..
INTRINSIC DBLE
logical lsame
src/serial/f77/smmp.f
+2 -2
View File
@@ -16,7 +16,7 @@ c=======================================================================
* ib, jb, diagb,
* ic, jc, diagc,
* index)
use realloc
use psb_realloc_mod
c
integer ia(*), ja(*), diaga,
* ib(*), jb(*), diagb,
@@ -93,7 +93,7 @@ c
else
nze = max(ic(i+1), nint((dble(ic(i))*(dble(n)/i))) )
endif
call psrealloc(nze,jc,info)
call psb_realloc(nze,jc,info)
end if
do 40 j= ic(i),ic(i+1)-1
if (diagc.eq.1 .and. istart.eq.i) then
src/serial/jad/Makefile
+3 -8
View File
@@ -1,4 +1,4 @@
include ../../../../Make.inc
include ../../../Make.inc
#
# The object files
#
@@ -11,11 +11,10 @@ OBJS=$(FOBJS)
#
# Where the library should go, and how it is called.
# Note that we are regenerating most of libsparker.a on the fly.
#LIBDIR=../../LIB
LIBDIR=../../../lib
#LIBNAME=libsparker.a
LIBFILE=$(LIBDIR)/$(LIBNAME)
SPARKERDIR=..
INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
INCDIRS=-I. -I$(LIBDIR)
#
# No change should be needed below
@@ -24,10 +23,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR)
default: lib
lib: $(OBJS)
$(AR) $(LIBFILE) $(OBJS)
$(RANLIB) $(LIBFILE)
$(FOBJS): $(SPARKERDIR)/sparker.fh
clean: cleanobjs
src/serial/jad/dcojdupd.f
+5 -5
View File
@@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value;
C Flag = 2: sum block value to elements;
C
IMPLICIT NONE
include 'sparker.fh'
include 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER IA, JA, IH, JH, M, N,
+ IERROR, FLAG, LIWORK
@@ -26,18 +26,18 @@ C .. Local scalars ..
INTEGER J, NNZ, IP1, NNZI
C .. Local arrays ..
IERROR = 0
IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN
IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN
C
C Smart update capability
C
IP1 = INFOA(UPD_PNT_)
NNZ = IA1(IP1+NNZ_)
IP1 = INFOA(PSB_UPD_PNT_)
NNZ = IA1(IP1+PSB_NNZ_)
NNZI = INFOH(1)
DO J = 1, NNZI
NNZ = NNZ + 1
A(NNZ) = H(J)
ENDDO
IA1(IP1+NNZ_) = NNZ
IA1(IP1+PSB_NNZ_) = NNZ
ELSE
IERROR = 2
ENDIF
src/serial/jad/djadnr.f
+2 -2
View File
@@ -2,7 +2,7 @@ C ... Compute infinity norma for sparse matrix in CSR Format ...
DOUBLE PRECISION FUNCTION DJADNR(TRANS,M,N,NG,A,KA,JA,IA,
+ INFOA,IERROR)
IMPLICIT NONE
INCLUDE 'sparker.fh'
INCLUDE 'psb_const.fh'
C .. Scalar Arguments ..
INTEGER M,N, IERROR, NG
CHARACTER TRANS
@@ -10,7 +10,7 @@ C .. Array Arguments ..
INTEGER KA(*),JA(*),IA(3,*),INFOA(*)
DOUBLE PRECISION A(*)
C ... Local Array ..
DOUBLE PRECISION NRMI_BLOCK(MAXJDROWS)
DOUBLE PRECISION NRMI_BLOCK(PSB_MAXJDROWS_)
C ... Local Scalars ..
DOUBLE PRECISION NRMI
INTEGER I, K, IPG, NPG, IPX
src/serial/psb_cest.f90
+6 -5
View File
@@ -1,6 +1,7 @@
subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info)
use psb_error_mod
use psb_const_mod
implicit none
! .. scalar arguments ..
@@ -11,11 +12,11 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info)
integer :: int_val(5), err_act
character(len=20) :: name
name = 'cest'
name = 'psb_cest'
call psb_erractionsave(err_act)
if (afmt.eq.'???') then
afmt = fidef
afmt = psb_fidef_
endif
if (up.eq.'y') then
@@ -39,15 +40,15 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info)
else if (up.eq.'n') then
if (afmt.eq.'jad') then
if (afmt.eq.'JAD') then
lia1 = nnz + nnz/5
lia2 = nnz + nnz/5
lar = nnz + nnz/5
else if (afmt.eq.'coo') then
else if (afmt.eq.'COO') then
lia1 = nnz
lia2 = nnz
lar = nnz
else if(afmt.eq.'csr') then
else if(afmt.eq.'CSR') then
lia1 = nnz
lia2 = nnz
lar = nnz
src/serial/psb_dcoins.f90
+221
View File
@@ -0,0 +1,221 @@
! File: psbdcoins.f90
! Subroutine:
! Parameters:
subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_error_mod
use psb_serial_mod, only : psb_spinfo
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:),gtl(:)
real(kind(1.d0)), intent(in) :: val(:)
type(psb_dspmat_type), intent(inout) :: a
integer, intent(out) :: info
character(len=5) :: ufida
integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,&
& ip1, nzl, err_act, int_err(5)
logical, parameter :: debug=.true.
character(len=20) :: name, ch_err
name='psb_dcoins'
info = 0
call psb_erractionsave(err_act)
info = 0
if (nz <= 0) then
info = 10
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ia) < nz) then
info = 35
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ja) < nz) then
info = 35
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(val) < nz) then
info = 35
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
!!$ ufida = toupper(a%fida)
call touppers(a%fida,ufida)
ng = size(gtl)
spstate = a%infoa(psb_state_)
select case(spstate)
case(psb_spmat_bld_)
if ((ufida /= 'COO').and.(ufida/='COI')) then
info = 134
ch_err(1:3)=ufida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_spinfo(psb_nztotreq_,a,nza,info)
call psb_spinfo(psb_nzsizereq_,a,isza,info)
if(info.ne.izero) then
info=4010
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if ((nza+nz)>isza) then
call psb_spreall(a,nza+nz,info)
if(info.ne.izero) then
info=4010
ch_err='psb_spreall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,&
& imin,imax,jmin,jmax,info)
if(info.ne.izero) then
info=4010
ch_err='psb_inner_ins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) then
if ((nza - a%infoa(psb_nnz_)) /= nz) then
write(0,*) 'PSB_COINS: insert discarded items '
end if
end if
if ((nza - a%infoa(psb_nnz_)) /= nz) then
a%infoa(psb_del_bnd_) = nza
endif
a%infoa(psb_nnz_) = nza
case(psb_spmat_upd_)
if (ibits(a%infoa(psb_upd_),2,1).eq.1) then
ip1 = a%infoa(psb_upd_pnt_)
nza = a%ia2(ip1+psb_nnz_)
nzl = a%infoa(psb_del_bnd_)
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,&
& imin,imax,jmin,jmax,nzl,info)
if(info.ne.izero) then
info=4010
ch_err='psb_inner_upd'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
!!$ if (debug) then
!!$ if ((nza - a%ia2(ip1+nnz_)) /= nz) then
!!$ write(0,*) 'PSB_COINS: update discarded items '
!!$ end if
!!$ end if
a%ia2(ip1+psb_nnz_) = nza
else
info = 2231
call psb_errpush(info,name)
goto 9999
endif
case default
info = 2232
call psb_errpush(info,name)
goto 9999
end select
return
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
end if
return
contains
subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,imin,imax,jmin,jmax,nzl,info)
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*),gtl(*)
integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info
integer :: i,ir,ic
info = 0
if (nza >= nzl) then
do i=1, nz
nza = nza + 1
a%aspk(nza) = val(i)
end do
else
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%aspk(nza) = val(i)
end if
end if
end do
end if
end subroutine psb_inner_upd
subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,&
& imin,imax,jmin,jmax,info)
implicit none
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(*),ja(*),gtl(*)
integer, intent(inout) :: nza,ia1(*),ia2(*)
real(kind(1.d0)), intent(in) :: val(*)
real(kind(1.d0)), intent(inout) :: aspk(*)
integer, intent(out) :: info
integer :: i,ir,ic
info = 0
do i=1, nz
ir = ia(i)
ic = ja(i)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
ic = gtl(ic)
if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then
nza = nza + 1
a%ia1(nza) = ir
a%ia2(nza) = ic
a%aspk(nza) = val(i)
end if
end if
end do
end subroutine psb_inner_ins
end subroutine psb_dcoins
src/serial/psb_dcsdp.f90
+23 -23
View File
@@ -112,9 +112,9 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('CSR')
ia1_size=a%infoa(nnz_)
ia1_size=a%infoa(psb_nnz_)
ia2_size=a%m+1
aspk_size=a%infoa(nnz_)
aspk_size=a%infoa(psb_nnz_)
call psb_spreall(b,ia1_size,ia2_size,aspk_size,info)
call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
@@ -280,12 +280,12 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
else if (check_=='R') then
!...Regenerating matrix
if (b%infoa(state_) /= spmat_upd) then
if (b%infoa(psb_state_) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
if (ibits(b%infoa(upd_),2,1).eq.0) then
if (ibits(b%infoa(psb_upd_),2,1).eq.0) then
!
! Nothing to be done......
!
@@ -296,19 +296,19 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
if (b%fida(1:3)/='JAD') then
ip1 = b%infoa(upd_pnt_)
ip2 = b%ia2(ip1+ip2_)
nnz = b%ia2(ip1+nnz_)
iflag = b%ia2(ip1+iflag_)
ichk = b%ia2(ip1+ichk_)
nnzt = b%ia2(ip1+nnzt_)
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia2(ip1+psb_ip2_)
nnz = b%ia2(ip1+psb_nnz_)
iflag = b%ia2(ip1+psb_iflag_)
ichk = b%ia2(ip1+psb_ichk_)
nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(upd_),perm_update,nnz,nnzt ,iflag,info
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& b%infoa(upd_),perm_update,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
@@ -330,22 +330,22 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
else if (b%fida(1:3) == 'JAD') then
ip1 = b%infoa(upd_pnt_)
ip2 = b%ia1(ip1+ip2_)
count = b%ia1(ip1+zero_)
ipc = b%ia1(ip1+ipc_)
nnz = b%ia1(ip1+nnz_)
iflag = b%ia1(ip1+iflag_)
ichk = b%ia1(ip1+ichk_)
nnzt = b%ia1(ip1+nnzt_)
ip1 = b%infoa(psb_upd_pnt_)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(upd_),perm_update,nnz,nnzt,count, &
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(upd_),perm_update,nnz,nnzt ,iflag,ichk
& b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
@@ -372,7 +372,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
end if
b%infoa(state_) = spmat_asb
b%infoa(psb_state_) = psb_spmat_asb_
call psb_erractionrestore(err_act)
return
src/serial/psb_dcsnmi.f90
+3 -3
View File
@@ -36,11 +36,11 @@ real(kind(1.d0)) function psb_dcsnmi(a,info,trans)
itrans='N'
end if
dcsnmi90 = dcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info)
psb_dcsnmi = dcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info)
if(info/=0) then
dcsnmi90 = -1
psb_dcsnmi = -1
info=4010
ch_err='dcsnmi'
ch_err='psb_dcsnmi'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
src/serial/psb_dcsprt.f90
+8 -8
View File
@@ -85,23 +85,23 @@ subroutine psb_dcsprt(iout,a,iv,eirs,eics,head,ivr,ivc)
else if (a%fida=='COO') then
if (present(ivr).and..not.present(ivc)) then
write(iout,*) a%m,a%k,a%infoa(nnz_)
do j=1,a%infoa(nnz_)
write(iout,*) a%m,a%k,a%infoa(psb_nnz_)
do j=1,a%infoa(psb_nnz_)
write(iout,frmtr) ivr(a%ia1(j)),a%ia2(j),a%aspk(j)
enddo
else if (present(ivr).and.present(ivc)) then
write(iout,*) a%m,a%k,a%infoa(nnz_)
do j=1,a%infoa(nnz_)
write(iout,*) a%m,a%k,a%infoa(psb_nnz_)
do j=1,a%infoa(psb_nnz_)
write(iout,frmtr) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
write(iout,*) a%m,a%k,a%infoa(nnz_)
do j=1,a%infoa(nnz_)
write(iout,*) a%m,a%k,a%infoa(psb_nnz_)
do j=1,a%infoa(psb_nnz_)
write(iout,frmtr) a%ia1(j),ivc(a%ia2(j)),a%aspk(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
write(iout,*) a%m,a%k,a%infoa(nnz_)
do j=1,a%infoa(nnz_)
write(iout,*) a%m,a%k,a%infoa(psb_nnz_)
do j=1,a%infoa(psb_nnz_)
write(iout,frmtr) a%ia1(j),a%ia2(j),a%aspk(j)
enddo
endif
src/serial/psb_dfixcoo.f90
+4 -3
View File
@@ -4,6 +4,7 @@
Subroutine psb_dfixcoo(A,INFO)
use psb_spmat_type
use psb_const_mod
implicit none
!....Parameters...
@@ -24,7 +25,7 @@ Subroutine psb_dfixcoo(A,INFO)
return
end if
nza = a%infoa(nnz_)
nza = a%infoa(psb_nnz_)
if (nza < 2) return
allocate(iaux(nza+2),stat=info)
@@ -64,8 +65,8 @@ Subroutine psb_dfixcoo(A,INFO)
icl = a%ia2(i)
endif
enddo
a%infoa(nnz_) = i
a%infoa(srtd_) = isrtdcoo
a%infoa(psb_nnz_) = i
a%infoa(psb_srtd_) = psb_isrtdcoo_
if(debug) write(0,*)'FIXCOO: end second loop'
src/serial/psb_dipcoo2csr.f90
+3 -2
View File
@@ -4,7 +4,8 @@
subroutine psb_dipcoo2csr(a,info,rwshr)
use psb_spmat_type
use psb_serial_mod, only : fixcoo
use psb_const_mod
use psb_serial_mod, only : psb_fixcoo
use psb_error_mod
implicit none
@@ -40,7 +41,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr)
call psb_fixcoo(a,info)
nr = a%m
nza = a%infoa(nnz_)
nza = a%infoa(psb_nnz_)
allocate(iaux(nr+1))
if(debug) write(0,*)'DIPCOO2CSR: out of fixcoo',nza,nr,size(a%ia2),size(iaux)
src/serial/psb_dipcsr2coo.f90
+5 -4
View File
@@ -4,6 +4,7 @@
Subroutine psb_dipcsr2coo(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
@@ -11,12 +12,12 @@ Subroutine psb_dipcsr2coo(a,info)
Type(psb_dspmat_type), intent(inout) :: A
Integer, intent(out) :: info
integer, pointer :: iaux(:), itemp(:)
!locals
Integer :: nza, nr
integer :: i,j,err_act
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
integer, pointer :: iaux(:), itemp(:)
character(len=20) :: name, ch_err
name='psb_dipcsr2coo'
info = 0
@@ -47,8 +48,8 @@ Subroutine psb_dipcsr2coo(a,info)
end do
a%fida='COO'
a%infoa(nnz_) = nza
a%infoa(srtd_) = isrtdcoo
a%infoa(psb_nnz_) = nza
a%infoa(psb_srtd_) = psb_isrtdcoo_
deallocate(itemp)
call psb_erractionrestore(err_act)
src/serial/psb_dneigh.f90
+1 -1
View File
@@ -5,6 +5,7 @@
subroutine psb_dneigh(a,idx,neigh,n,info,lev)
use psb_realloc_mod
use psb_const_mod
use psb_spmat_type
implicit none
@@ -18,7 +19,6 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev)
integer :: level, dim, i, j, k, r, c, brow,&
& elem_pt, ii, n1, col_idx, ne, err_act
integer, parameter :: izero=0
character(len=20) :: name, ch_err
name='psb_dneigh'
src/serial/psb_dspgtdiag.f90
+1 -1
View File
@@ -44,7 +44,7 @@ subroutine psb_dspgtdiag(a,d,info)
else if (a%fida == 'COO') then
do i=1,a%infoa(nnz_)
do i=1,a%infoa(psb_nnz_)
j=a%ia1(i)
if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then
d(j) = a%aspk(i)
src/serial/psb_dspgtrow.f90
+8 -8
View File
@@ -57,7 +57,7 @@ subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw)
if (append_) then
nzb = b%infoa(nnz_)
nzb = b%infoa(psb_nnz_)
else
nzb = 0
b%m = 0
@@ -126,7 +126,7 @@ contains
nr = lrw - irw + 1
nz = a%ia2(idx+nr) - a%ia2(idx)
if (append) then
nzb = b%infoa(nnz_)
nzb = b%infoa(psb_nnz_)
else
nzb = 0
endif
@@ -159,7 +159,7 @@ contains
end do
enddo
end if
b%infoa(nnz_) = nzb+nz
b%infoa(psb_nnz_) = nzb+nz
if (a%pr(1) /= 0) then
write(0,*) 'Feeling lazy today, Right Permutation will have to wait'
endif
@@ -181,7 +181,7 @@ contains
integer, pointer :: iren(:)
integer :: lrw
nza = a%infoa(nnz_)
nza = a%infoa(psb_nnz_)
if (a%pl(1) /= 0) then
write(0,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!'
idx = -1
@@ -193,7 +193,7 @@ contains
return
end if
if (a%infoa(srtd_) == isrtdcoo) then
if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then
!!$ write(0,*) 'Gtrow_: srtd coo',irw
! In this case we can do a binary search.
do
@@ -274,7 +274,7 @@ contains
if (associated(iren)) then
k = 0
do i=1,a%infoa(nnz_)
do i=1,a%infoa(psb_nnz_)
if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
k = k + 1
if (k > nz) then
@@ -288,7 +288,7 @@ contains
enddo
else
k = 0
do i=1,a%infoa(nnz_)
do i=1,a%infoa(psb_nnz_)
if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
k = k + 1
if (k > nz) then
@@ -303,7 +303,7 @@ contains
end if
end if
b%infoa(nnz_) = nzb + k
b%infoa(psb_nnz_) = nzb + k
b%m = b%m+lrw-irw+1
b%k = max(b%k,a%k)
end subroutine coo_dspgtrow
src/serial/psb_dspinfo.f90
+9 -9
View File
@@ -28,12 +28,12 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux)
call psb_erractionsave(err_act)
if (ireq == nztotreq) then
if (ireq == psb_nztotreq_) then
if (a%fida == 'CSR') then
nr = a%m
ires = a%ia2(nr+1)-1
else if ((a%fida == 'COO').or.(a%fida == 'COI')) then
ires = a%infoa(nnz_)
ires = a%infoa(psb_nnz_)
else if (a%fida == 'JAD') then
ires=-1
info=135
@@ -48,7 +48,7 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux)
goto 9999
end if
else if (ireq == nzrowreq) then
else if (ireq == psb_nzrowreq_) then
if (.not.present(iaux)) then
write(0,*) 'Need IAUX when ireq=nzrowreq'
ires=-1
@@ -59,10 +59,10 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux)
ires = a%ia2(irw+1)-a%ia2(irw)
else if ((a%fida == 'COO').or.(a%fida == 'COI')) then
if (a%infoa(srtd_) == isrtdcoo) then
if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then
!!$ write(0,*) 'Gtrow_: srtd coo',irw
! In this case we can do a binary search.
nz = a%infoa(nnz_)
nz = a%infoa(psb_nnz_)
call ibsrch(ip,irw,nz,a%ia1)
jp = ip
! expand [ip,jp] to contain all row entries.
@@ -85,10 +85,10 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux)
end do
ires = jp-ip
else
ires = count(a%ia1(1:a%infoa(nnz_))==irw)
ires = count(a%ia1(1:a%infoa(psb_nnz_))==irw)
endif
!!$ ires = 0
!!$ do i=1, a%infoa(nnz_)
!!$ do i=1, a%infoa(psb_nnz_)
!!$ if (a%ia1(i) == irw) ires = ires + 1
!!$ enddo
else if (a%fida == 'JAD') then
@@ -105,13 +105,13 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux)
goto 9999
end if
else if (ireq == nzsizereq) then
else if (ireq == psb_nzsizereq_) then
if (a%fida == 'CSR') then
ires = size(a%aspk)
else if ((a%fida == 'COO').or.(a%fida == 'COI')) then
ires = size(a%aspk)
else if (a%fida == 'JAD') then
ires = a%infoa(nnz_)
ires = a%infoa(psb_nnz_)
else
ires=-1
info=136
src/serial/psb_dspscal.f90
+1 -1
View File
@@ -35,7 +35,7 @@ subroutine psb_dspscal(a,d,info)
else if (a%fida == 'COO') then
do i=1,a%infoa(nnz_)
do i=1,a%infoa(psb_nnz_)
j=a%ia1(i)
a%aspk(i) = a%aspk(i) * d(j)
enddo
src/serial/psb_dtransp.f90
+1 -1
View File
@@ -4,7 +4,7 @@
subroutine psb_dtransp(a,b,c,fmt)
use psb_spmat_type
use psb_serial_mod, only : ipcoo2csr, ipcsr2coo, fixcoo
use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo
implicit none
type(psb_dspmat_type) :: a,b
src/tools/Makefile
+1 -1
View File
@@ -11,7 +11,7 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_descprt.o \
MPFOBJS = psb_descasb.o psb_dcsrovr.o
INCDIRS = ../../lib .
INCDIRS = -I ../../lib -I .
lib: mpfobjs $(FOBJS)