fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-24 23:01:48 +00:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
Alfredo Buttari
2005-09-07 16:10:09 +00:00
parent 1797b931dd
commit 7051d94726
22 changed files with 172 additions and 695 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/tools/Makefile
+2 -2
View File
@@ -1,13 +1,13 @@
include ../../Make.inc
FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_descprt.o \
psb_dfree.o psb_dgelp.o psb_dins.o psb_dptins.o \
psb_dfree.o psb_dgelp.o psb_dins.o \
psb_dscall.o psb_dscalv.o psb_dscasb.o psb_dsccpy.o \
psb_dscdec.o psb_dscfree.o psb_dscins.o psb_dscov.o \
psb_dscren.o psb_dscrep.o psb_dspalloc.o psb_dspasb.o \
psb_dspcnv.o psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_dspupdate.o psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o psb_ptasb.o
psb_ifree.o psb_iins.o psb_loc_to_glob.o
MPFOBJS = psb_descasb.o psb_dcsrovr.o
src/tools/psb_dallc.f90
+5 -4
View File
@@ -1,3 +1,4 @@
! File: psb_dallc.f90
!
! Function: psb_dalloc
@@ -87,13 +88,13 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
j=1
endif
!global check on m and n parameters
if (myrow.eq.root) then
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
exch(3)=j
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, root, 0)
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
if (exch(1).ne.m) then
info=550
int_err(1)=1
@@ -235,11 +236,11 @@ subroutine psb_dallocv(m, x, desc_a,info)
endif
!global check on m and n parameters
if (myrow.eq.root) then
if (myrow.eq.psb_root_) then
exch(1) = m
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, root, 0)
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
if (exch(1) .ne. m) then
info = 550
int_err(1) = 1
src/tools/psb_dptins.f90
-297
View File
@@ -1,297 +0,0 @@
! File: psb_dptins.f90
!
! Subroutine: psb_dptins
! insert sparse submatrix to sparse matrix structure for psblas
! routines
!
! Parameters:
! ia - integer. a global-row corresponding to position at which blck submatrix must be inserted.
! ja - integer. a global-col corresponding to position at which blck submatrix must be inserted.
! blck - type(<psb_dspmat_type>). The source sparse submatrix.
! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code
subroutine psb_dptins(ia,ja,blck,desc_a,info)
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
integer, intent(in) :: ia,ja
type(psb_dspmat_type), intent(in) :: blck
integer,intent(out) :: info
!locals.....
interface
subroutine dcsins(m,n,fida,descra,a,ia1,ia2,infoa,&
& ia,ja,latot,lia1tot,lia2tot,&
&fidh,descrh,h,ih1,ih2,infoh,ih,jh,work,lwork,ierror)
implicit none
! .. scalar arguments ..
integer, intent(in) :: m, n, lwork, latot,lia1tot,lia2tot,ia,ja,ih,jh
integer, intent(out) :: ierror
! .. array arguments ..
double precision, intent(in) :: h(*)
double precision, intent(inout) :: a(*), work(*)
integer, intent(in) :: ih1(*), ih2(*), infoh(10)
integer, intent(inout) :: ia1(*), ia2(*), infoa(10)
character, intent(in) :: fida*5, fidh*5,descra*11, descrh*11
end subroutine dcsins
end interface
integer :: i,icontxt,nprocs ,glob_row,row,&
& k ,start_row,end_row,int_err(5),&
& first_loc_row,n_row,j, ierror,locix,locjx,&
& allocated_prcv,dectype,mglob, nnza, err_act
integer,pointer :: prcv(:), tia1(:),tia2(:), temp(:)
integer :: nprow,npcol, me ,mypcol, iflag, isize, irlc
integer :: m,n, pnt_halo,ncol, nh, ip
type(psb_dspmat_type) :: a
real(kind(1.d0)),pointer :: workarea(:),taspk(:)
logical, parameter :: debug=.false.
integer, parameter :: nrlcthr=3
integer, save :: irlcmin,nrlc
data irlcmin/500/,nrlc/0/
character(len=20) :: name, ch_err
info=0
call psb_erractionsave(err_act)
name = 'psb_dptins'
locix=1
locjx=1
icontxt = desc_a%matrix_data(psb_ctxt_)
dectype = desc_a%matrix_data(psb_dec_type_)
mglob = desc_a%matrix_data(psb_m_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
if (.not.psb_is_bld_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
endif
allocate(workarea(1),prcv(nprow),stat=info)
if (info.ne.0) then
info = 2023
call psb_errpush(info,name)
goto 9999
end if
call psb_spall(a,size(blck%aspk),info)
if (info.ne.0) then
info = 4010
ch_err='spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocated_prcv = 1
a%infoa(:) = 0
a%fida = 'coo'
a%descra = 'gun'
n_row = desc_a%matrix_data(psb_n_row_)
nnza = a%infoa(psb_nnz_)
m = blck%m
n = blck%k
row = ia
i = 1
do while (i.le.m)
!loop over all blck's rows
! row actual block row
row = locix+i-1
glob_row = ia+i-1
if (glob_row > mglob) exit
if (debug) then
write(0,*) 'ptins: inserting ',glob_row
endif
k = desc_a%glob_to_loc(glob_row)
if (k.gt.0) then
start_row = row
first_loc_row = k
!!$ do while ((i.lt.m).and.&
!!$ & (desc_a%glob_to_loc(ia+i).gt.0))
!!$ i=i+1
!!$ enddo
do
if (i>=m) exit
if ((ia+i)>mglob) exit
if (desc_a%glob_to_loc(ia+i) <=0 ) exit
i=i+1
enddo
end_row=locix+i-1
! insert blck submatrix in 'coo' format
call dcsins(end_row-start_row+1,n,a%fida,a%descra,a%aspk,&
& a%ia1,a%ia2,a%infoa,first_loc_row, ja,&
& size(a%aspk),size(a%ia1),size(a%ia2),&
& blck%fida,blck%descra,blck%aspk,blck%ia1,blck%ia2,&
& blck%infoa,start_row,locjx,workarea,size(workarea),&
& info)
if (info.ne.0) then
if (info.eq.60) then
! try reallocating
irlc = irlcmin
do while (info.eq.60)
if (debug) write(*,*) "attempting reallocation with",irlc
isize = size(a%ia1)
allocate(tia1(isize+irlc),stat=info)
if (info.ne.0) goto 9998
tia1(1:isize) = a%ia1(1:isize)
deallocate(a%ia1,stat=info)
if (info.ne.0) goto 9998
a%ia1 => tia1
nullify(tia1)
isize = size(a%ia2)
allocate(tia2(isize+irlc),stat=info)
if (info.ne.0) goto 9998
tia2(1:isize) = a%ia2(1:isize)
deallocate(a%ia2,stat=info)
if (info.ne.0) goto 9998
a%ia2 => tia2
nullify(tia2)
isize = size(a%aspk)
allocate(taspk(isize+irlc),stat=info)
if (info.ne.0) goto 9998
taspk(1:isize) = a%aspk(1:isize)
deallocate(a%aspk,stat=info)
if (info.ne.0) goto 9998
a%aspk => taspk
nullify(taspk)
9998 if (info.ne.0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
! insert blck submatrix in 'coo' format
call dcsins(end_row-start_row+1,n,a%fida,a%descra,a%aspk,&
& a%ia1,a%ia2,a%infoa,first_loc_row, ja,&
& size(a%aspk), size(a%ia1),size(a%ia2),&
& blck%fida,blck%descra,blck%aspk,blck%ia1,blck%ia2,&
& blck%infoa,start_row, locjx,workarea,size(workarea),&
& info)
if (info.eq.60) irlc = irlc*2
enddo
! if we get here, it means we succesfully reallocated.
nrlc = nrlc+1
if (nrlc .ge. nrlcthr) then
nrlc = 0
irlcmin = irlcmin * 2
endif
else
info = 4010
ch_err='spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
endif
endif
! next blck's row
i=i+1
enddo
if (.not.associated(desc_a%halo_index)) then
allocate(desc_a%halo_index(irlcmin))
desc_a%halo_index(:) = -1
endif
pnt_halo=1
do while (desc_a%halo_index(pnt_halo) .ne. -1 )
pnt_halo = pnt_halo + 1
end do
ncol = desc_a%matrix_data(psb_n_col_)
isize = size(desc_a%halo_index)
do i = nnza+1,a%infoa(psb_nnz_)
ip = a%ia2(i)
k = desc_a%glob_to_loc(ip)
if (k.lt.-nprow) then
k = k + nprow
k = - k - 1
ncol = ncol + 1
desc_a%glob_to_loc(ip) = ncol
isize = size(desc_a%loc_to_glob)
if (ncol > isize) then
nh = ncol + irlcmin
call psb_realloc(nh,desc_a%loc_to_glob,info,pad=-1)
if (me==0) then
if (debug) write(0,*) 'done realloc ',nh
end if
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
isize = nh
endif
desc_a%loc_to_glob(ncol) = ip
isize = size(desc_a%halo_index)
if ((pnt_halo+3).gt.isize) then
nh = isize + irlcmin
call psb_realloc(nh,desc_a%halo_index,info,pad=-1)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
isize = nh
endif
desc_a%halo_index(pnt_halo) = k
desc_a%halo_index(pnt_halo+1) = 1
desc_a%halo_index(pnt_halo+2) = ncol
pnt_halo = pnt_halo + 3
endif
enddo
desc_a%matrix_data(psb_n_col_) = ncol
if (allocated_prcv.eq.1) then
call psb_spfree(a,info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
deallocate(prcv,workarea,stat=info)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
else
call psb_error(icontxt)
end if
return
end subroutine psb_dptins
src/tools/psb_dscall.f90
+10 -10
View File
@@ -25,7 +25,7 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
integer, intent(out) :: info
!locals
Integer :: counter,i,j,nprow,npcol,me,mypcol,&
Integer :: counter,i,j,nprow,npcol,myrow,mycol,&
& loc_row,err,loc_col,nprocs,&
& l_ov_ix,l_ov_el,idx, err_act, itmpov, k
Integer :: INT_ERR(5),TEMP(1),EXCH(2)
@@ -39,8 +39,8 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
name = 'psb_dscall'
call psb_erractionsave(err_act)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,me,mypcol
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness..
if (npcol /= 1) then
info = 2030
@@ -71,12 +71,12 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
if (debug) write(*,*) 'psb_dscall: doing global checks'
!global check on m and n parameters
if (me.eq.root) then
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, root,&
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0)
if (exch(1) /= m) then
err=550
@@ -145,15 +145,15 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
endif
desc_a%glob_to_loc(i) = -(nprow+prc_v(1)+1)
j=1
!!$ do while ((j.le.nprocs).and.(prc_v(j).ne.me))
!!$ do while ((j.le.nprocs).and.(prc_v(j).ne.myrow))
do
if (j > nprocs) exit
if (prc_v(j) == me) exit
if (prc_v(j) == myrow) exit
j=j+1
enddo
if (j.le.nprocs) then
if (prc_v(j).eq.me) then
! this point belongs to me
if (prc_v(j).eq.myrow) then
! this point belongs to myrow
counter=counter+1
desc_a%glob_to_loc(i) = counter
if (nprocs.gt.1) then
@@ -222,7 +222,7 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
ov_el(l_ov_el+2) = nprocs
l_ov_el = l_ov_el+2
do j=1, nprocs
if (temp_ovrlap(i+j) /= me) then
if (temp_ovrlap(i+j) /= myrow) then
ov_idx(l_ov_ix+1) = temp_ovrlap(i+j)
ov_idx(l_ov_ix+2) = 1
ov_idx(l_ov_ix+3) = idx
src/tools/psb_dscalv.f90
+7 -7
View File
@@ -24,7 +24,7 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
type(psb_desc_type), intent(out) :: desc_a
!locals
Integer :: counter,i,j,nprow,npcol,me,mypcol,&
Integer :: counter,i,j,nprow,npcol,myrow,mycol,&
& loc_row,err,loc_col,nprocs,n,itmpov, k,&
& l_ov_ix,l_ov_el,idx, flag_, err_act
Integer :: INT_ERR(5),TEMP(1),EXCH(2)
@@ -37,8 +37,8 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
err=0
name = 'psb_dscalv'
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,me,mypcol
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness..
if (npcol /= 1) then
info = 2030
@@ -70,12 +70,12 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
if (debug) write(*,*) 'psb_dscall: doing global checks'
!global check on m and n parameters
if (me.eq.root) then
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, root,&
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0)
if (exch(1) /= m) then
info=550
@@ -133,7 +133,7 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
exit
end if
if ((v(i)-flag_) == me) then
if ((v(i)-flag_) == myrow) then
! this point belongs to me
counter=counter+1
desc_a%glob_to_loc(i) = counter
@@ -188,7 +188,7 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
ov_el(l_ov_el+2) = nprocs
l_ov_el = l_ov_el+2
do j=1, nprocs
if (temp_ovrlap(i+j) /= me) then
if (temp_ovrlap(i+j) /= myrow) then
ov_idx(l_ov_ix+1) = temp_ovrlap(i+j)
ov_idx(l_ov_ix+2) = 1
ov_idx(l_ov_ix+3) = idx
src/tools/psb_dscasb.f90
+6 -7
View File
@@ -26,7 +26,6 @@ subroutine psb_dscasb(desc_a,info)
& lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,&
& ldesc_ovrlap, dectype, err_act
integer :: icontxt,temp(1),n_row
integer, parameter :: ione=1, itwo=2
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name,ch_err
@@ -54,7 +53,7 @@ subroutine psb_dscasb(desc_a,info)
goto 9999
endif
if (.not.is_ok_dec(dectype)) then
if (.not.psb_is_ok_dec(dectype)) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name)
@@ -63,7 +62,7 @@ subroutine psb_dscasb(desc_a,info)
if (debug) write (0, *) ' Begin matrix assembly...'
if (is_bld_dec(dectype)) then
if (psb_is_bld_dec(dectype)) then
if (debug) write(0,*) 'psb_dscasb: Checking rows insertion'
! check if all local row are inserted
do i=1,desc_a%matrix_data(psb_n_col_)
@@ -105,7 +104,7 @@ subroutine psb_dscasb(desc_a,info)
itemp(1) = max_size
itemp(2) = max_halo
call igamx2d(icontxt, all, topdef, itwo, ione, itemp,&
call igamx2d(icontxt, psb_all_, psb_topdef_, itwo, ione, itemp,&
& itwo,temp ,temp,-ione ,-ione,-ione)
max_size = itemp(1)
max_halo = itemp(2)
@@ -167,7 +166,7 @@ subroutine psb_dscasb(desc_a,info)
end if
! Ok, register into MATRIX_DATA & free temporary work areas
desc_a%matrix_data(psb_dec_type_) = desc_asb
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
deallocate(halo_index,ovrlap_index, stat=info)
if (info /= 0) then
@@ -180,8 +179,8 @@ subroutine psb_dscasb(desc_a,info)
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'dectype 2 :',dectype,desc_bld,&
&desc_asb,desc_upd
if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,&
&psb_desc_asb_,psb_desc_upd_
endif
call psb_erractionrestore(err_act)
src/tools/psb_dscdec.f90
+6 -6
View File
@@ -103,7 +103,7 @@ subroutine psb_dscdec(nloc, icontxt, desc_a, info)
info=0
err=0
name = 'psb_dscrep'
name = 'psb_dscdec'
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,me,mypcol
@@ -149,7 +149,7 @@ subroutine psb_dscdec(nloc, icontxt, desc_a, info)
!count local rows number
! allocate work vector
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(mdata_size),&
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
& desc_a%loc_to_glob(nloc),desc_a%lprm(1),&
& desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),&
& desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info)
@@ -187,13 +187,13 @@ subroutine psb_dscdec(nloc, icontxt, desc_a, info)
desc_a%ovrlap_elem(:) = -1
desc_a%matrix_data(m_) = m
desc_a%matrix_data(n_) = m
desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = m
desc_a%matrix_data(psb_n_row_) = nloc
desc_a%matrix_data(psb_n_col_) = nloc
desc_a%matrix_data(psb_dec_type_) = desc_asb
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
desc_a%matrix_data(psb_ctxt_) = icontxt
call blacs_get(icontxt,10,desc_a%matrix_data(mpi_c_))
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act)
return
src/tools/psb_dscins.f90
+3 -3
View File
@@ -43,8 +43,8 @@ subroutine psb_dscins(nz,ia,ja,desc_a,info,is,js)
icontxt = desc_a%matrix_data(psb_ctxt_)
dectype = desc_a%matrix_data(psb_dec_type_)
mglob = desc_a%matrix_data(m_)
nglob = desc_a%matrix_data(n_)
mglob = desc_a%matrix_data(psb_m_)
nglob = desc_a%matrix_data(psb_n_)
nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_)
@@ -55,7 +55,7 @@ subroutine psb_dscins(nz,ia,ja,desc_a,info,is,js)
call psb_errpush(info,name)
goto 9999
endif
if (.not.is_bld_dec(dectype)) then
if (.not.psb_is_bld_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
src/tools/psb_dscov.f90
+4 -4
View File
@@ -128,10 +128,10 @@ Subroutine psb_dscov(a,desc_a,novr,desc_ov,info)
! LOVR= (NNZ/NROW)*N_HALO*N_OVR This assumes that the local average
! nonzeros per row is the same as the global.
!
call psb_spinfo(nztotreq,a,nztot,info)
call psb_spinfo(psb_nztotreq_,a,nztot,info)
if (info.ne.0) then
info=4010
ch_err='spinfo'
ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -165,7 +165,7 @@ Subroutine psb_dscov(a,desc_a,novr,desc_ov,info)
desc_ov%ovrlap_elem(:) = -1
desc_ov%halo_index(:) = -1
desc_ov%matrix_data(1:10) = desc_a%matrix_data(1:10)
desc_ov%matrix_data(psb_dec_type_) = desc_bld
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),&
& desc_ov%glob_to_loc(Size(desc_a%glob_to_loc)))
@@ -186,7 +186,7 @@ Subroutine psb_dscov(a,desc_a,novr,desc_ov,info)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
desc_ov%matrix_data(psb_dec_type_) = desc_asb
desc_ov%matrix_data(psb_dec_type_) = psb_desc_asb_
If(debug)Write(0,*)'Done descasb',me,lworks,lworkr
call blacs_barrier(icontxt,'All')
!!$ ierr = MPE_Log_event( idsce, 0, "st DSCASB" )
src/tools/psb_dscren.f90
+9 -10
View File
@@ -28,10 +28,9 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
character, intent(in) :: trans
integer, intent(out) :: info
!....locals....
integer :: i,j,err,nprow,npcol,me,mypcol, n_col, kh, nh
integer :: i,j,err,nprow,npcol,myrow,mycol, n_col, kh, nh
integer :: dectype
integer :: icontxt,temp(1),n_row, int_err(5), err_act
integer, parameter :: ione=1
real(kind(1.d0)) :: time(10), mpi_wtime, real_err(6)
external mpi_wtime
logical, parameter :: debug=.false.
@@ -49,7 +48,7 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -61,7 +60,7 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
goto 9999
endif
if (.not.is_asb_dec(dectype)) then
if (.not.psb_is_asb_dec(dectype)) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,int_err)
@@ -110,7 +109,7 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
desc_a%glob_to_loc(desc_a%loc_to_glob(desc_a%lprm(i))) = i
enddo
if (debug) write(0,*) 'spasb: renumbering loc_to_glob'
do i=1,desc_a%matrix_data(m_)
do i=1,desc_a%matrix_data(psb_m_)
j = desc_a%glob_to_loc(i)
if (j>0) then
desc_a%loc_to_glob(j) = i
@@ -159,18 +158,18 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
enddo
if (debug) write(0,*) 'spasb: done renumbering'
if (debug) then
write(60+me,*) 'n_row ',n_row,' n_col',n_col, ' trans: ',trans
write(60+myrow,*) 'n_row ',n_row,' n_col',n_col, ' trans: ',trans
do i=1,n_col
write(60+me,*)i, ' lprm ', desc_a%lprm(i), ' iperm',iperm(i)
write(60+myrow,*)i, ' lprm ', desc_a%lprm(i), ' iperm',iperm(i)
enddo
i=1
kh = desc_a%halo_index(i)
do while (kh /= -1)
write(60+me,*) i, kh
write(60+myrow,*) i, kh
i = i+1
kh = desc_a%halo_index(i)
enddo
close(60+me)
close(60+myrow)
end if
!!$ iperm(1) = 0
@@ -183,7 +182,7 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
time(4) = mpi_wtime()
time(4) = time(4) - time(3)
if (debug) then
call dgamx2d(icontxt, all, topdef, ione, ione, time(4),&
call dgamx2d(icontxt, psb_all_, psb_topdef_, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3
src/tools/psb_dscrep.f90
+11 -12
View File
@@ -90,12 +90,11 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
Type(psb_desc_type), intent(out) :: desc_a
!locals
Integer :: counter,i,j,nprow,npcol,me,mypcol,&
Integer :: counter,i,j,nprow,npcol,myrow,mycol,&
& loc_row,err,loc_col,nprocs,n,itmpov, k,&
& l_ov_ix,l_ov_el,idx, flag_, err_act
Integer :: INT_ERR(5),TEMP(1),EXCH(2)
Real(Kind(1.d0)) :: REAL_ERR(5)
Integer, Parameter :: IONE=1, ITWO=2,ROOT=0
Integer, Pointer :: temp_ovrlap(:), ov_idx(:),ov_el(:)
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
@@ -104,8 +103,8 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
err=0
name = 'psb_dscrep'
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,me,mypcol
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_dscall: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness..
if (npcol /= 1) then
info = 2030
@@ -133,12 +132,12 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
if (debug) write(*,*) 'psb_dscall: doing global checks'
!global check on m and n parameters
if (me.eq.root) then
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
call igebs2d(icontxt,all,topdef, itwo,ione, exch, itwo)
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else
call igebr2d(icontxt,all,topdef, itwo,ione, exch, itwo, root,&
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0)
if (exch(1) /= m) then
info=550
@@ -160,7 +159,7 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
!count local rows number
! allocate work vector
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(mdata_size),&
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
& desc_a%loc_to_glob(m),desc_a%lprm(1),&
& desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),&
& desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info)
@@ -183,13 +182,13 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
desc_a%ovrlap_elem(:) = -1
desc_a%matrix_data(m_) = m
desc_a%matrix_data(n_) = n
desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = n
desc_a%matrix_data(psb_n_row_) = m
desc_a%matrix_data(psb_n_col_) = n
desc_a%matrix_data(psb_dec_type_) = desc_repl
desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_
desc_a%matrix_data(psb_ctxt_) = icontxt
call blacs_get(icontxt,10,desc_a%matrix_data(mpi_c_))
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act)
return
src/tools/psb_dspalloc.f90
+10 -10
View File
@@ -12,7 +12,7 @@
subroutine psb_dspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
use psb_dspmat_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
@@ -26,7 +26,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
!locals
integer :: icontxt, dectype
integer :: nprow,npcol,me,mypcol,loc_row,&
integer :: nprow,npcol,myrow,mycol,loc_row,&
& length_ia1,length_ia2,err,nprocs, err_act,m,n
integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5)
@@ -40,7 +40,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
icontxt = desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
! ....verify blacs grid correctness..
if (nprow.eq.-1) then
info = 2010
@@ -61,8 +61,8 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
! set fields in desc_a%matrix_data....
loc_row = desc_a%matrix_data(psb_n_row_)
m = desc_a%matrix_data(m_)
n = desc_a%matrix_data(n_)
m = desc_a%matrix_data(psb_m_)
n = desc_a%matrix_data(psb_n_)
!...allocate matrix data...
if (present(nnz))then
@@ -97,13 +97,13 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
! set infoa fields
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(nnz_) = 0
a%infoa(srtd_) = 0
a%infoa(state_) = spmat_bld
a%infoa(psb_nnz_) = 0
a%infoa(psb_srtd_) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'spall: ', &
&desc_a%matrix_data(psb_dec_type_),desc_bld
desc_a%matrix_data(psb_dec_type_) = desc_bld
&desc_a%matrix_data(psb_dec_type_),psb_desc_bld_
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
return
call psb_erractionrestore(err_act)
src/tools/psb_dspasb.f90
+18 -19
View File
@@ -15,7 +15,7 @@
subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
use psb_descriptor_type
use psb_dspmat_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psi_mod
@@ -42,11 +42,10 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
type(psb_dspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,me,mypcol ,size_req,idup,n_col,iout, err_act
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup
integer :: icontxt,temp(2),isize(2),n_row
character :: iup
integer, parameter :: ione=1
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
@@ -61,7 +60,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
n_col = desc_a%matrix_data(psb_n_col_)
! check on BLACS grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -73,7 +72,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
goto 9999
endif
if (.not.is_asb_dec(dscstate)) then
if (.not.psb_is_asb_dec(dscstate)) then
info = 600
int_err(1) = dscstate
call psb_errpush(info,name)
@@ -84,8 +83,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
!check on errors encountered in psdspins
spstate = a%infoa(state_)
if (spstate == SPMAT_BLD) then
spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then
!
! First case: we come from a fresh build.
!
@@ -126,8 +125,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
iupdup = ieor(iupdup,idup)
a%infoa(upd_)=iupdup
if (debug) write(0,*)'in ASB',upd_,iupdup
a%infoa(psb_upd_)=iupdup
if (debug) write(0,*)'in ASB',psb_upd_,iupdup
a%m = n_row
a%k = n_col
@@ -150,7 +149,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
! work area requested must be fixed to
! No of Grid'd processes and NNZ+2
!
size_req = max(a%infoa(nnz_),1)+3
size_req = max(a%infoa(psb_nnz_),1)+3
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
call psb_cest(a%fida, size_req, ia1_size, ia2_size, aspk_size, iup,info)
if (info /= no_err) then
@@ -172,7 +171,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
a%pr(:) = 0
if (debugwrt) then
iout = 30+me
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
@@ -180,25 +179,25 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
! Do the real conversion into the requested storage formatmode
! result is put in A
call psb_csdp90(atemp,a,info,ifc=2)
call psb_csdp(atemp,a,info,ifc=2)
IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp90'
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+me
iout = 60+myrow
open(iout)
call csprt(iout,a,head='Output mat')
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
else if (spstate == SPMAT_UPD) then
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
@@ -218,7 +217,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
goto 9999
endif
call psb_csdp90(atemp,a,info,check='R')
call psb_csdp(atemp,a,info,check='R')
! check on error retuned by dcsdp
if (info /= no_err) then
info = 4010
@@ -240,7 +239,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,spmat_bld,spmat_upd
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
src/tools/psb_dspcnv.f90
+5 -5
View File
@@ -68,12 +68,12 @@ subroutine psb_dspcnv(a,b,desc_a,info)
integer, intent(out) :: info
!....locals....
integer :: int_err(5)
integer,pointer :: ovrlap_elem(:),ovrlap_index(:)
integer,pointer :: ovrlap_elem(:),ovrlap_index(:)
real(kind(1.d0)) :: d(1)
integer,pointer :: i_temp(:)
real(kind(1.d0)),pointer :: work_dcsdp(:)
integer :: ia1_size,ia2_size,aspk_size,err_act&
& ,i,err,nprow,npcol,me,mypcol,n_col,l_dcsdp, iout, nrow
& ,i,err,nprow,npcol,myrow,mycol,n_col,l_dcsdp, iout, nrow
integer :: lwork_dcsdp,dectype
integer :: icontxt,temp(1),n_row
character :: check*1, trans*1, unitd*1
@@ -97,7 +97,7 @@ subroutine psb_dspcnv(a,b,desc_a,info)
n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -109,7 +109,7 @@ subroutine psb_dspcnv(a,b,desc_a,info)
goto 9999
endif
if (.not.is_ok_dec((dectype))) then
if (.not.psb_is_ok_dec((dectype))) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,i_err=int_err)
@@ -207,7 +207,7 @@ subroutine psb_dspcnv(a,b,desc_a,info)
endif
if (debug) write (0, *) me,name,' from dcsdp ',&
if (debug) write (0, *) myrow,name,' from dcsdp ',&
&b%fida,' pl ', b%pl(:),'pr',b%pr(:)
call psb_erractionrestore(err_act)
src/tools/psb_dspins.f90
+10 -10
View File
@@ -37,15 +37,15 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,is,js)
& first_loc_row,nrow,j, err,locix,locjx,err_act,&
& dectype,mglob, nnza,m,n, pnt_halo,ncol, nh, ip, spstate
integer,pointer :: tia1(:),tia2(:), temp(:)
integer :: nprow,npcol, me ,mypcol, iflag, isize, irlc
integer :: nprow,npcol, myrow ,mycol, iflag, isize, irlc
logical, parameter :: debug=.false.
integer, parameter :: relocsz=200
interface psb_dscins
subroutine psb_dscins(nz,ia,ja,desc_a,info,is,js)
use typedesc
use psb_descriptor_type
implicit none
type(desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
integer, intent(in) :: nz,ia(:),ja(:)
integer, intent(out) :: info
integer, intent(in), optional :: is,js
@@ -61,15 +61,15 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,is,js)
icontxt = desc_a%matrix_data(psb_ctxt_)
dectype = desc_a%matrix_data(psb_dec_type_)
mglob = desc_a%matrix_data(m_)
mglob = desc_a%matrix_data(psb_m_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (npcol.ne.1) then
info = 2030
call psb_errpush(info,name)
goto 9999
endif
if (.not.is_ok_dec(dectype)) then
if (.not.psb_is_ok_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
@@ -98,8 +98,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,is,js)
end if
spstate = a%infoa(state_)
if (is_bld_dec(dectype)) then
spstate = a%infoa(psb_state_)
if (psb_is_bld_dec(dectype)) then
call psb_dscins(nz,ia,ja,desc_a,info)
if (info /= 0) then
info=4010
@@ -110,7 +110,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,is,js)
nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_)
if (spstate == spmat_bld) then
if (spstate == psb_spmat_bld_) then
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,info)
if (info /= 0) then
info=4010
@@ -123,7 +123,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,is,js)
call psb_errpush(info,name)
goto 9999
end if
else if (is_asb_dec(dectype)) then
else if (psb_is_asb_dec(dectype)) then
nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_)
call psb_coins(nz,ia,ja,val,a,desc_a%glob_to_loc,1,nrow,1,ncol,info)
src/tools/psb_dsprn.f90
+15 -18
View File
@@ -24,12 +24,11 @@ Subroutine psb_dsprn(a, desc_a,info)
!locals
Integer :: icontxt
Integer :: nprow,npcol,me,mypcol,err,err_act
integer, parameter :: ione=1, itwo=2,root=0
Integer :: nprow,npcol,myrow,mycol,err,err_act
logical, parameter :: debug=.false.
integer :: int_err(5)
real(kind(1.d0)) :: real_err(5)
character(len=20) :: name, ch_err
integer :: int_err(5)
real(kind(1.d0)) :: real_err(5)
character(len=20) :: name, ch_err
info = 0
err = 0
@@ -38,9 +37,9 @@ Subroutine psb_dsprn(a, desc_a,info)
call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (debug) &
&write(*,*) 'starting spalloc ',icontxt,nprow,npcol,me
&write(*,*) 'starting spalloc ',icontxt,nprow,npcol,myrow
! ....verify blacs grid correctness..
if (npcol.ne.1) then
@@ -49,32 +48,30 @@ Subroutine psb_dsprn(a, desc_a,info)
goto 9999
endif
if (debug) &
&write(*,*) 'got through igamx2d '
if (debug) write(*,*) 'got through igamx2d '
if (.not.is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then
if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then
info=590
call psb_errpush(info,name)
goto 9999
endif
if (a%infoa(state_) == spmat_asb) then
if (a%infoa(psb_state_) == psb_spmat_asb_) then
a%aspk(:) = 0.0
if (ibits(a%infoa(upd_),2,1)==1) then
if (ibits(a%infoa(psb_upd_),2,1)==1) then
if(a%fida(1:3).eq.'JAD') then
a%ia1(a%infoa(upd_pnt_)+nnz_) = 0
a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
else
a%ia2(a%infoa(upd_pnt_)+nnz_) = 0
a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
endif
endif
a%infoa(state_) = spmat_upd
else if (a%infoa(state_) == spmat_bld) then
a%infoa(psb_state_) = psb_spmat_upd_
else if (a%infoa(psb_state_) == psb_spmat_bld_) then
! in this case do nothing. this allows sprn to be called
! right after allocate, with spins doing the right thing.
! hopefully :-)
else if (a%infoa(state_) == spmat_upd) then
else if (a%infoa(psb_state_) == psb_spmat_upd_) then
else
info=591
src/tools/psb_dspupdate.f90
+7 -7
View File
@@ -18,7 +18,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
use psb_descriptor_type
use psb_spmat_type
use psbserial_mod
use psb_serial_mod
use psb_error_mod
implicit none
@@ -56,7 +56,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
& k ,start_row,end_row,first_loc_row,n_row,j,int_err(5),&
&locix,locjx,allocated_prcv, dectype, flag,err_act,err
integer,pointer :: prcv(:),gtl(:), ltg(:)
integer :: nprow,npcol, me ,mypcol, lr, lc, nrow,ncol
integer :: nprow,npcol, myrow ,mycol, lr, lc, nrow,ncol
integer :: m,n, iupdflag
integer,pointer :: iworkaux(:)
character(len=20) :: name, ch_err
@@ -74,7 +74,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
if (present(updflag)) then
iupdflag = updflag
else
iupdflag = upd_glb
iupdflag = psb_upd_glb_
endif
if (present(jx)) then
@@ -85,7 +85,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
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.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -103,7 +103,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
ncol = desc_a%matrix_data(psb_n_col_)
dectype = desc_a%matrix_data(psb_dec_type_)
! check if a is already allocated (called psdalloc)
if (.not.is_upd_dec(dectype)) then
if (.not.psb_is_upd_dec(dectype)) then
info = 290
int_err(1) = dectype
call psb_errpush(info,name,i_err=int_err)
@@ -122,7 +122,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
m = blck%m
n = blck%k
if (iupdflag == upd_glb) then
if (iupdflag == psb_upd_glb_) then
row = ia
i = 1
@@ -187,7 +187,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
endif
else if (iupdflag == upd_loc) then
else if (iupdflag == psb_upd_loc_) then
! insert blck submatrix
call dcsupd(m,n,a%fida,a%descra,a%aspk,&
src/tools/psb_glob_to_loc.f90
+8 -8
View File
@@ -18,7 +18,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
implicit none
!...parameters....
type(desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(in) :: x(:)
integer, intent(out) :: y(:), info
character, intent(in), optional :: iact
@@ -46,14 +46,14 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
n=size(x)
do i=1,n
if ((x(i).gt.desc_a%matrix_data(m_)).or.&
if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.&
& (x(i).le.zero)) then
if(act.eq.'I') then
y(i)=-3*desc_a%matrix_data(m_)
y(i)=-3*desc_a%matrix_data(psb_m_)
else
info=140
int_err(1)=x(i)
int_err(2)=desc_a%matrix_data(m_)
int_err(2)=desc_a%matrix_data(psb_m_)
exit
end if
else
@@ -120,7 +120,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
implicit none
!...parameters....
type(desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: x(:)
integer, intent(out) :: info
character, intent(in), optional :: iact
@@ -146,14 +146,14 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
real_val = 0.d0
n=size(x)
do i=1,n
if ((x(i).gt.desc_a%matrix_data(m_)).or.&
if ((x(i).gt.desc_a%matrix_data(psb_m_)).or.&
& (x(i).le.zero)) then
if(act.eq.'I') then
x(i)=-3*desc_a%matrix_data(m_)
x(i)=-3*desc_a%matrix_data(psb_m_)
else
info=140
int_err(1)=x(i)
int_err(2)=desc_a%matrix_data(m_)
int_err(2)=desc_a%matrix_data(psb_m_)
exit
end if
else
src/tools/psb_ialloc.f90
+23 -25
View File
@@ -25,12 +25,11 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
integer, optional, intent(in) :: js
!locals
integer :: j,nprow,npcol,me,mypcol,&
integer :: j,nprow,npcol,myrow,mypcol,&
& n_col,n_row, err_act
integer :: icontxt,dectype
integer :: int_err(5),temp(1),exch(3)
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1, itwo=2, ithree=3,root=0
character(len=20) :: name, char_err
info=0
@@ -39,7 +38,7 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
icontxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mypcol)
! ....verify blacs grid correctness..
if (nprow.eq.-1) then
info = 2010
@@ -66,17 +65,17 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
int_err(2) = n
call psb_errpush(info,name,int_err)
goto 9999
else if (.not.is_ok_dec(dectype)) then
else if (.not.psb_is_ok_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
else if (m.ne.desc_a%matrix_data(n_)) then
else if (m.ne.desc_a%matrix_data(psb_n_)) then
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = n_
int_err(5) = desc_a%matrix_data(n_)
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
endif
@@ -87,13 +86,13 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
j=1
endif
!global check on m and n parameters
if (me.eq.root) then
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
exch(3)=j
call igebs2d(icontxt,all,topdef, ithree,ione, exch, ithree)
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
else
call igebr2d(icontxt,all,topdef, ithree,ione, exch, ithree, root, 0)
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
if (exch(1).ne.m) then
info=550
int_err(1)=1
@@ -113,7 +112,7 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
endif
!....allocate x .....
if (is_asb_dec(dectype).or.is_upd_dec(dectype)) then
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
n_col = max(1,desc_a%matrix_data(psb_n_col_))
allocate(x(n_col,j:j+n-1),stat=info)
if (info.ne.0) then
@@ -122,7 +121,7 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
call psb_errpush(info,name,int_err)
goto 9999
endif
else if (is_bld_dec(dectype)) then
else if (psb_is_bld_dec(dectype)) then
n_row = max(1,desc_a%matrix_data(psb_n_row_))
allocate(x(n_row,j:j+n-1),stat=info)
if (info.ne.0) then
@@ -174,11 +173,10 @@ subroutine psb_iallocv(m, x, desc_a, info)
integer, intent(out) :: info
!locals
integer :: nprow,npcol,me,mypcol,err,n_col,n_row,dectype,err_act
integer :: nprow,npcol,myrow,mypcol,err,n_col,n_row,dectype,err_act
integer :: icontxt
integer :: int_err(5),temp(1),exch(2)
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1, itwo=2,root=0
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
@@ -188,7 +186,7 @@ subroutine psb_iallocv(m, x, desc_a, info)
icontxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mypcol)
! ....verify blacs grid correctness..
if (nprow.eq.-1) then
info = 2010
@@ -203,7 +201,7 @@ subroutine psb_iallocv(m, x, desc_a, info)
dectype=desc_a%matrix_data(psb_dec_type_)
if (debug) write(0,*) 'dall: dectype',dectype
if (debug) write(0,*) 'dall: is_ok? dectype',is_ok_dec(dectype)
if (debug) write(0,*) 'dall: is_ok? dectype',psb_is_ok_dec(dectype)
!... check m and n parameters....
if (m.lt.0) then
info = 10
@@ -211,27 +209,27 @@ subroutine psb_iallocv(m, x, desc_a, info)
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (.not.is_ok_dec(dectype)) then
else if (.not.psb_is_ok_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
else if (m.ne.desc_a%matrix_data(n_)) then
else if (m.ne.desc_a%matrix_data(psb_n_)) then
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = n_
int_err(5) = desc_a%matrix_data(n_)
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
endif
!global check on m and n parameters
if (me.eq.root) then
if (myrow.eq.psb_root_) then
exch(1) = m
call igebs2d(icontxt,all,topdef, ione,ione, exch, ione)
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
else
call igebr2d(icontxt,all,topdef, ione,ione, exch, ione, root, 0)
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
if (exch(1) .ne. m) then
info = 550
int_err(1) = 1
@@ -242,7 +240,7 @@ subroutine psb_iallocv(m, x, desc_a, info)
!....allocate x .....
if (is_asb_dec(dectype).or.is_upd_dec(dectype)) then
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
n_col = max(1,desc_a%matrix_data(psb_n_col_))
allocate(x(n_col),stat=info)
if (info.ne.0) then
@@ -251,7 +249,7 @@ subroutine psb_iallocv(m, x, desc_a, info)
call psb_errpush(info,name,int_err)
goto 9999
endif
else if (is_bld_dec(dectype)) then
else if (psb_is_bld_dec(dectype)) then
n_row = max(1,desc_a%matrix_data(psb_n_row_))
allocate(x(n_row),stat=info)
if (info.ne.0) then
src/tools/psb_iins.f90
+10 -10
View File
@@ -35,7 +35,7 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,col,iblock, jblock, mglob
integer :: nprow,npcol, me ,mypcol, int_err(5),err_act
integer :: nprow,npcol, myrow ,mycol, int_err(5),err_act
character(len=20) :: name, ch_err
info=0
@@ -52,7 +52,7 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
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.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -95,7 +95,7 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
else if (.not.is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
@@ -118,7 +118,7 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
endif
loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(m_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
else
@@ -206,7 +206,7 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
!locals.....
integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,iblock, jblock,mglob, err_act, int_err(5)
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, myrow ,mycol
character(len=20) :: name, ch_err
info=0
@@ -215,7 +215,7 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(m_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
@@ -291,7 +291,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
!locals.....
integer :: icontxt,i,loc_row,glob_row,k,&
& loc_rows,loc_cols,col,iblock, jblock, mglob, err_act, int_err(5)
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, myrow ,mycol
character(len=20) :: name, ch_err
info=0
@@ -306,7 +306,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
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.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -337,7 +337,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
else if (.not.is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
else if (.not.psb_is_ok_dec(desc_a%matrix_data(psb_dec_type_))) then
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
@@ -352,7 +352,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
loc_rows=desc_a%matrix_data(psb_n_row_)
loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(m_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
src/tools/psb_loc_to_glob.f90
+3 -3
View File
@@ -50,11 +50,11 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact)
& (x(i).le.zero)) then
info=140
int_err(1)=tmp
int_err(2)=desc_a%matrix_data(m_)
int_err(2)=desc_a%matrix_data(psb_n_col_)
exit
else
tmp=desc_a%loc_to_glob(x(i))
if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(m_))) then
if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_m_))) then
y(i)=tmp
else
info = 140
@@ -146,7 +146,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact)
exit
else
tmp=desc_a%loc_to_glob(x(i))
if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(m_))) then
if((tmp.gt.zero).or.(tmp.le.desc_a%matrix_data(psb_m_))) then
x(i)=tmp
else
info = 140
src/tools/psb_ptasb.f90
-218
View File
@@ -1,218 +0,0 @@
! File: psb_ptasb.f90
!
! Subroutine: psb_ptasb
! ???
!
! Parameters:
! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code.
!
subroutine psb_ptasb(desc_a,info)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
use psi_mod
use psb_error_mod
implicit none
!...parameters....
type(psb_desc_type), intent(inout) :: desc_a
integer,intent(out) :: info
!....locals....
integer :: int_err(5)
integer,pointer :: ovrlap_index(:),halo_index(:)
real(kind(1.d0)) :: real_err(5)
integer,pointer :: work5(:)
integer :: err_act,&
& i,nprow,npcol,me,mypcol ,size_req,&
& lovrlap,lhalo,nhalo,novrlap,max_size,max_size1,&
& max_halo,size_req1,n_col,lwork5,ldesc_halo,&
& ldesc_ovrlap, dectype
integer :: icontxt,temp(1),n_row
integer, parameter :: ione=1
real(kind(1.d0)) :: time(10), mpi_wtime
external mpi_wtime
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
info=0
name = 'psb_ptasb'
call psb_erractionsave(err_act)
time(1) = mpi_wtime()
icontxt = desc_a%matrix_data(psb_ctxt_)
dectype = desc_a%matrix_data(psb_dec_type_)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
if (.not.is_ok_dec(dectype)) then
info = 600
int_err(1) = dectype
call psb_errpush(info, name, int_err)
goto 9999
endif
if (debug) write (*, *) ' begin matrix assembly...'
if (is_bld_dec(dectype)) then
if (debug) write(0,*) 'ptasb: checking rows insertion'
! check if all local row are inserted
do i=1,desc_a%matrix_data(psb_n_col_)
if (desc_a%loc_to_glob(i).lt.0) then
write(0,*) 'error on index: ',i,desc_a%loc_to_glob(i)
info=3100
exit
endif
enddo
if(info.ne.no_err) then
call psb_errpush(info, name)
goto 9999
end if
! comm desc_size is size requested for temporary comm descriptors
! (expressed in no of dble element)
ldesc_halo = (((3*(n_col-n_row)+1)+1))
ovrlap_index => desc_a%ovrlap_index
nullify(desc_a%ovrlap_index)
halo_index => desc_a%halo_index
nullify(desc_a%halo_index)
lhalo = 1
do while (halo_index(lhalo) /= -1)
lhalo = lhalo + 1
enddo
nhalo = (lhalo-1)/3
lovrlap=1
do while (ovrlap_index(lovrlap) /= -1)
lovrlap=lovrlap+1
enddo
novrlap = (lovrlap-1)/3
if (debug) write(0,*) 'ptasb: from asbx',&
& nhalo,lhalo,halo_index(lhalo)
! allocate final comm psblas descriptors
! compute necessary dimension of halo index
max_halo=max(nhalo,1)
max_size= max(1,min(3*desc_a%matrix_data(psb_n_row_),novrlap*3))
max_size1=max_size
call igamx2d(icontxt, all, topdef, ione, ione, max_size,&
& ione,temp ,temp,-ione ,-ione,-ione)
call igamx2d(icontxt, all, topdef, ione, ione,max_halo,&
& ione,temp ,temp,-ione ,-ione,-ione)
ldesc_halo=3*max_halo+3*nhalo+1
! allocate halo_index field
allocate(desc_a%halo_index(ldesc_halo),stat=info)
! check on allocate
if (info.ne.0) then
info=2023
int_err(1)=ldesc_halo
call psb_errpush(info, name, int_err)
goto 9999
endif
! compute necessary dimension of ovrlap index
ldesc_ovrlap=2*lovrlap+1
! allocate ovrlap_index field
allocate(desc_a%ovrlap_index(ldesc_ovrlap),stat=info)
! check on allocate
if (info.ne.0) then
info=2023
int_err(1)=ldesc_ovrlap
call psb_errpush(info, name, int_err)
goto 9999
endif
size_req1=max((max_size+max_size1),(nprow*4)*(nprow+1)*5)
size_req=((nprow*4)*(nprow+1)*5)+(nprow+1)+(max&
& (nhalo,size_req1)+1)
if (info.ne.0) info =2040
allocate(work5(size_req),stat=info)
if (info.ne.0) then
info=2025
int_err(1)=size_req
call psb_errpush(info, name, int_err)
goto 9999
endif
lwork5=size(work5)
if (debug) write(0,*) 'ptasb: calling convert_comm',&
& nhalo,lhalo,halo_index(lhalo)
!.... convert comunication stuctures....
call psi_convert_comm(desc_a%matrix_data,&
& halo_index, ovrlap_index,&
& desc_a%halo_index,size(desc_a%halo_index),&
& desc_a%ovrlap_index,size(desc_a%ovrlap_index),&
& desc_a%ovrlap_elem,size(desc_a%ovrlap_elem),&
& desc_a%bnd_elem,&
& desc_a%loc_to_glob,desc_a%glob_to_loc,info)
if(info /= 0) then
info=4010
ch_err='psi_convert_comm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! ok, register into matrix_data & free temporary work areas
desc_a%matrix_data(psb_dec_type_) = desc_asb
deallocate(halo_index,ovrlap_index,&
& work5, stat=info)
if (info.ne.0) then
info =2040
call psb_errpush(info, name, int_err)
goto 9999
end if
else
info = 600
if (debug) write(0,*) 'dectype 2 :',dectype,desc_bld,&
&desc_asb,desc_upd
call psb_errpush(info, name, int_err)
goto 9999
endif
time(4) = mpi_wtime()
time(4) = time(4) - time(3)
if (debug) then
call dgamx2d(icontxt, all, topdef, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
end if
return
end subroutine psb_ptasb