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

Changed handling of duplicates and storage format. Changed interface

Browse Source 
to both geins and spasb. New and better strategies.
This commit is contained in:
Salvatore Filippone
2006-04-14 11:56:05 +00:00
parent 77106751a4
commit 4b2f930cf6
32 changed files with 1836 additions and 1405 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/tools/psb_dins.f90
+153 -55
View File
@@ -45,7 +45,7 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -61,12 +61,13 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
real(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, me ,mypcol,dupl_
character :: temp_descra*11,temp_fida*5
character(len=20) :: name, char_err
@@ -161,22 +162,52 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
else
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m
!loop over all blck's rows
select case(dupl_)
case(psb_dupl_ovwrt_)
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -240,7 +271,7 @@ end subroutine psb_dins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -265,10 +296,11 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
real(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err
integer :: nprow,npcol, me ,mypcol, iblock
integer :: nprow,npcol, me ,mypcol, iblock, dupl_
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
@@ -352,21 +384,48 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
iblock = 1
endif
do i = 1, m
!loop over all blck's rows
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -427,7 +486,7 @@ end subroutine psb_dinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ???
subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag)
& iblck,insflag,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -450,11 +509,12 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,&
& loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, me ,mypcol,dupl_
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
@@ -528,32 +588,70 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
else
liflag = psb_upd_glbnum_
end if
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
if (present(dupl)) then
dupl_ = dupl
else
info=-1
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
case(psb_dupl_ovwrt_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case(psb_dupl_add_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case default
info = 321
call psb_errpush(info,name)
goto 9999
endif
end select
call psb_erractionrestore(err_act)
return
src/tools/psb_dspasb.f90
+119 -164
View File
@@ -42,7 +42,7 @@
! up - character(optional). ???
! dup - integer(optional). ???
!
subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type
use psb_spmat_type
@@ -50,33 +50,25 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
implicit none
interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5
character, intent(in) :: up
end subroutine psb_cest
end interface
!...Parameters....
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dup
character, optional, intent(in) :: afmt*5, up
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
!....Locals....
integer :: int_err(5)
type(psb_dspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup
& nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
@@ -93,21 +85,21 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
! check on BLACS grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol /= 1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_dec(dscstate)) then
info = 600
int_err(1) = dscstate
call psb_errpush(info,name)
goto 9999
info = 600
int_err(1) = dscstate
call psb_errpush(info,name)
goto 9999
endif
if (debug) Write (*, *) ' Begin matrix assembly...'
@@ -116,165 +108,128 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then
!
! First case: we come from a fresh build.
!
!
! First case: we come from a fresh build.
!
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
!
! Second step: handle the local matrix part.
!
iupdup = 0
if (present(up)) then
if(up.eq.'Y') then
iupdup = 4
iup = up
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...'
write(0,*)'Changing to default'
iup = 'N'
else
iup = 'N'
endif
else
iup = 'N'
endif
!
! Second step: handle the local matrix part.
!
if (present(upd)) then
upd_=upd
else
upd_ = psb_upd_dflt_
endif
if (present(dup)) then
if((dup.lt.1).or.(dup.gt.3)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
idup = 1
else
idup = dup
endif
else
idup = 1
endif
iupdup = ieor(iupdup,idup)
if (present(dupl)) then
if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
dupl_ = psb_dupl_def_
else
dupl_ = dupl
endif
else
dupl_ = psb_dupl_def_
endif
a%infoa(psb_upd_)=iupdup
if (debug) write(0,*)'in ASB',psb_upd_,iupdup
call psb_sp_setifld(upd_,psb_upd_,a,info)
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
a%m = n_row
a%k = n_col
a%m = n_row
a%k = n_col
call psb_sp_clone(a,atemp,info)
if(info /= no_err) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
call psb_sp_clone(a,atemp,info)
if(info /= no_err) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
!
! work area requested must be fixed to
! No of Grid'd processes and NNZ+2
!
!!$ size_req = max(a%infoa(psb_nnz_),1)+3
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!!$ call psb_cest(a%fida, n_row,n_col,size_req,&
!!$ & ia1_size, ia2_size, aspk_size, iup,info)
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_cest'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ call psb_sp_reall(a,ia1_size,ia2_size,aspk_size,info)
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_sp_reall'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ a%pl(:) = 0
!!$ a%pr(:) = 0
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
!
! Second case: we come from an update loop.
!
! Right now, almost nothing to be done, but this
! may change in the future
! as we revise the implementation of the update routine.
call psb_sp_all(atemp,1,info)
atemp%m=a%m
atemp%k=a%k
! check on allocation
if (info /= no_err) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
! Right now, almost nothing to be done, but this
! may change in the future
! as we revise the implementation of the update routine.
call psb_sp_all(atemp,1,info)
atemp%m=a%m
atemp%k=a%k
! check on allocation
if (info /= no_err) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_csdp(atemp,a,info,check='R')
! check on error retuned by dcsdp
if (info /= no_err) then
info = 4010
ch_err='psb_csdp90'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_csdp(atemp,a,info,check='R')
! check on error retuned by dcsdp
if (info /= no_err) then
info = 4010
ch_err='psb_csdp90'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_sp_free(atemp,info)
if (info /= no_err) then
info = 4010
ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_sp_free(atemp,info)
if (info /= no_err) then
info = 4010
ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
@@ -284,8 +239,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
src/tools/psb_dsprn.f90
+28 -25
View File
@@ -73,40 +73,43 @@ Subroutine psb_dsprn(a, desc_a,info)
! ....verify blacs grid correctness..
if (npcol.ne.1) then
info = 2030
call psb_errpush(info,name)
goto 9999
info = 2030
call psb_errpush(info,name)
goto 9999
endif
if (debug) write(*,*) 'got through igamx2d '
if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then
info=590
call psb_errpush(info,name)
goto 9999
info=590
call psb_errpush(info,name)
goto 9999
endif
if (a%infoa(psb_state_) == psb_spmat_asb_) then
select case(psb_sp_getifld(psb_state_,a,info))
case(psb_spmat_asb_)
a%aspk(:) = dzero
if (ibits(a%infoa(psb_upd_),2,1)==1) then
if(a%fida(1:3).eq.'JAD') then
a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
else
a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
endif
endif
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(psb_state_) == psb_spmat_upd_) then
a%aspk(:) = dzero
else
info=591
call psb_errpush(info,name)
endif
if (psb_sp_getifld(psb_upd_,a,info)==psb_upd_perm_) then
if(a%fida(1:3).eq.'JAD') then
a%ia1(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
else
a%ia2(a%infoa(psb_upd_pnt_)+psb_nnz_) = 0
endif
endif
a%infoa(psb_state_) = psb_spmat_upd_
case(psb_spmat_bld_)
! in this case do nothing. this allows sprn to be called
! right after allocate, with spins doing the right thing.
! hopefully :-)
case( psb_spmat_upd_)
case default
info=591
call psb_errpush(info,name)
end select
if (info /= 0) goto 9999
src/tools/psb_iins.f90
+248 -161
View File
@@ -45,13 +45,13 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
use psb_error_mod
implicit none
!....parameters...
integer, intent(in) :: m,n
type(psb_desc_type), intent(in) :: desc_a
@@ -60,11 +60,12 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:,:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,col,iblock, jblock, mglob
& loc_cols,col,iblock, jblock, mglob,dupl_
integer :: nprow,npcol, myrow ,mycol, int_err(5),err_act
character(len=20) :: name, ch_err
@@ -73,110 +74,138 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
call psb_erractionsave(err_act)
name = 'psb_iins'
if ((.not.associated(desc_a%matrix_data))) then
info=3110
call psb_errpush(info, name)
return
info=3110
call psb_errpush(info, name)
return
end if
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
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
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
if (.not.associated(desc_a%glob_to_loc)) then
info=3110
call psb_errpush(info,name,int_err)
goto 9999
info=3110
call psb_errpush(info,name,int_err)
goto 9999
end if
!... check parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (n.lt.0) then
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
goto 9999
else if (ix.lt.1) then
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
else if (jx.lt.1) then
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
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)
goto 9999
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=2).lt.n) then
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = n
call psb_errpush(info,name,int_err)
goto 9999
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = n
call psb_errpush(info,name,int_err)
goto 9999
endif
loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
if (present(jblck)) then
jblock = jblck
jblock = jblck
else
jblock = 1
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m
!loop over all blck's rows
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -184,11 +213,11 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
end subroutine psb_iins
@@ -238,23 +267,23 @@ end subroutine psb_iins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
use psb_error_mod
implicit none
! m rows number of submatrix belonging to blck to be inserted
! iblck first row of submatrix belonging to blck to be inserted
! ix x global-row corresponding to position at which blck submatrix
! must be inserted
! jx x global-col corresponding to position at which blck submatrix
! must be inserted
!....parameters...
integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
@@ -263,42 +292,71 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
integer, intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,&
& loc_cols,iblock, jblock,mglob, err_act, int_err(5)
integer :: nprow,npcol, myrow ,mycol
integer :: nprow,npcol, myrow ,mycol,dupl_
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_iinsvm'
call psb_erractionsave(err_act)
loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
do i = 1, m
!loop over all blck's rows
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -306,11 +364,11 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
end subroutine psb_iinsvm
@@ -356,20 +414,20 @@ end subroutine psb_iinsvm
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
use psb_error_mod
implicit none
! m rows number of submatrix belonging to blck to be inserted
! iblck first row of submatrix belonging to blck to be inserted
! ix x global-row corresponding to position at which blck submatrix
! must be inserted
!....parameters...
integer, intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
@@ -378,11 +436,12 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!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, myrow ,mycol
integer :: nprow,npcol, myrow ,mycol,dupl_
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
@@ -391,55 +450,55 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
call psb_erractionsave(err_act)
if ((.not.associated(desc_a%matrix_data))) then
info=3110
call psb_errpush(info,name)
return
info=3110
call psb_errpush(info,name)
return
end if
icontxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
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
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
if (.not.associated(desc_a%glob_to_loc)) then
info=3110
call psb_errpush(info,name)
goto 9999
info=3110
call psb_errpush(info,name)
goto 9999
end if
!... check parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (ix.lt.1) then
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
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)
goto 9999
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
loc_rows=desc_a%matrix_data(psb_n_row_)
@@ -447,34 +506,62 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
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
call psb_error(icontxt)
return
end if
return
src/tools/psb_zins.f90
+296 -199
View File
@@ -45,7 +45,7 @@
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck)
& iblck, jblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -61,12 +61,13 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
complex(kind(1.d0)), intent(in) :: blck(:,:)
integer,intent(out) :: info
integer, optional, intent(in) :: iblck,jblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,err_act,&
& nprocs,mode, loc_cols,col,iblock, jblock, mglob, int_err(5), err
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, me ,mypcol,dupl_
character :: temp_descra*11,temp_fida*5
character(len=20) :: name, char_err
@@ -76,14 +77,14 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
name = 'psb_zins'
if (.not.associated(desc_a%glob_to_loc)) then
info=3110
call psb_errpush(info,name)
return
info=3110
call psb_errpush(info,name)
return
end if
if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110
call psb_errpush(info,name)
return
int_err(1)=3110
call psb_errpush(info,name)
return
end if
icontxt=desc_a%matrix_data(psb_ctxt_)
@@ -91,92 +92,120 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
! 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
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
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
!... check parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (n.lt.0) then
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
goto 9999
else if (ix.lt.1) then
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
else if (jx.lt.1) then
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
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)
goto 9999
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=2).lt.n) then
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = n
call psb_errpush(info,name,int_err)
goto 9999
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = n
call psb_errpush(info,name,int_err)
goto 9999
endif
loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
if (present(jblck)) then
jblock = jblck
jblock = jblck
else
jblock = 1
jblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m
!loop over all blck's rows
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
do col = 1, n
x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -185,9 +214,9 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error(icontxt)
call psb_error(icontxt)
end if
return
@@ -240,7 +269,7 @@ end subroutine psb_zins
! info - integer. Eventually returns an error code
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
& iblck)
& iblck,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -265,10 +294,11 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
complex(kind(1.d0)), intent(in) :: blck(:)
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,loc_cols,mglob,err_act, int_err(5),err
integer :: nprow,npcol, me ,mypcol, iblock
integer :: nprow,npcol, me ,mypcol, iblock,dupl_
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
@@ -277,14 +307,14 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
name = 'psb_zinsvm'
if (.not.associated(desc_a%glob_to_loc)) then
info=3110
call psb_errpush(info,name)
return
info=3110
call psb_errpush(info,name)
return
end if
if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110
call psb_errpush(info,name)
return
int_err(1)=3110
call psb_errpush(info,name)
return
end if
icontxt=desc_a%matrix_data(psb_ctxt_)
@@ -292,80 +322,107 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
! 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
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
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
!... check parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (ix.lt.1) then
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
else if (jx.lt.1) then
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 7
int_err(2) = jx
call psb_errpush(info,name,int_err)
goto 9999
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)
goto 9999
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=2).lt.1) then
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = 1
call psb_errpush(info,name,int_err)
goto 9999
! check if dimension of x is greater than dimension of submatrix
! to insert
info = 320
int_err(1) = 2
int_err(2) = size(x, dim=2)
int_err(3) = 1
call psb_errpush(info,name,int_err)
goto 9999
endif
loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
do i = 1, m
!loop over all blck's rows
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1)
end if
enddo
case(psb_dupl_add_)
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if
enddo
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -374,9 +431,9 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error(icontxt)
call psb_error(icontxt)
end if
return
@@ -427,7 +484,7 @@ end subroutine psb_zinsvm
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
! insflag - integer(optional). ???
subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
& iblck,insflag)
& iblck,insflag,dupl)
!....insert dense submatrix to dense matrix .....
use psb_descriptor_type
use psb_const_mod
@@ -450,11 +507,12 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
integer, intent(out) :: info
integer, optional, intent(in) :: iblck
integer, optional, intent(in) :: insflag
integer, optional, intent(in) :: dupl
!locals.....
integer :: icontxt,i,loc_row,glob_row,row,k,&
& loc_rows,loc_cols,iblock, liflag,mglob,err_act, int_err(5), err
integer :: nprow,npcol, me ,mypcol
integer :: nprow,npcol, me ,mypcol,dupl_
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
@@ -463,14 +521,14 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
name = 'psb_zinsvv'
if (.not.associated(desc_a%glob_to_loc)) then
info=3110
call psb_errpush(info,name)
return
info=3110
call psb_errpush(info,name)
return
end if
if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110
call psb_errpush(info,name)
return
int_err(1)=3110
call psb_errpush(info,name)
return
end if
icontxt=desc_a%matrix_data(psb_ctxt_)
@@ -478,40 +536,40 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
! 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
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
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
!... check parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (ix.lt.1) then
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
info = 20
int_err(1) = 6
int_err(2) = ix
call psb_errpush(info,name,int_err)
goto 9999
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)
goto 9999
info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err)
goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
loc_rows=desc_a%matrix_data(psb_n_row_)
@@ -519,42 +577,81 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then
iblock = iblck
iblock = iblck
else
iblock = 1
iblock = 1
endif
if (present(insflag)) then
liflag = insflag
liflag = insflag
else
liflag = psb_upd_glbnum_
liflag = psb_upd_glbnum_
end if
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
if (present(dupl)) then
dupl_ = dupl
else
info=-1
call psb_errpush(info,name)
goto 9999
dupl_ = psb_dupl_ovwrt_
endif
select case(dupl_)
case(psb_dupl_ovwrt_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case(psb_dupl_add_)
if (liflag == psb_upd_glbnum_) then
do i = 1, m
!loop over all blck's rows
! row actual block row
glob_row=ix+i-1
if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then
! this row belongs to me
! copy i-th row of block blck in x
x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if
enddo
else if (liflag == psb_upd_locnum_) then
k = min(ix+m-1,loc_rows)
do i=ix,k
x(i) = x(i) + blck(i-ix+1)
enddo
else
info=-1
call psb_errpush(info,name)
goto 9999
endif
case default
info = 321
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
@@ -562,9 +659,9 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error(icontxt)
call psb_error(icontxt)
end if
return
src/tools/psb_zspasb.f90
+70 -115
View File
@@ -42,7 +42,7 @@
! up - character(optional). ???
! dup - integer(optional). ???
!
subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type
use psb_spmat_type
@@ -50,33 +50,25 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
implicit none
interface psb_cest
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, up, info)
integer, intent(in) :: m,n,nnz
integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5
character, intent(in) :: up
end subroutine psb_cest
end interface
!...Parameters....
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dup
character, optional, intent(in) :: afmt*5, up
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
!....Locals....
integer :: int_err(5)
type(psb_zspmat_type) :: atemp
real(kind(1.d0)) :: real_err(5)
integer :: ia1_size,ia2_size,aspk_size,m,i,err,&
& nprow,npcol,myrow,mycol ,size_req,idup,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j, iupdup
& nprow,npcol,myrow,mycol ,size_req,n_col,iout, err_act
integer :: dscstate, spstate, nr,k,j
integer :: upd_, dupl_
integer :: icontxt,temp(2),isize(2),n_row
character :: iup
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
@@ -116,118 +108,81 @@ subroutine psb_zspasb(a,desc_a, info, afmt, up, dup)
spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then
!
! First case: we come from a fresh build.
!
!
! First case: we come from a fresh build.
!
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
!
! Second step: handle the local matrix part.
!
iupdup = 0
if (present(up)) then
if(up.eq.'Y') then
iupdup = 4
iup = up
else if (up /= 'N') then
write(0,*)'Wrong value for update input in ASB...'
write(0,*)'Changing to default'
iup = 'N'
else
iup = 'N'
endif
else
iup = 'N'
endif
!
! Second step: handle the local matrix part.
!
if (present(upd)) then
upd_=upd
else
upd_ = psb_upd_dflt_
endif
if (present(dup)) then
if((dup.lt.1).or.(dup.gt.3)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
idup = 1
else
idup = dup
endif
else
idup = 1
endif
iupdup = ieor(iupdup,idup)
if (present(dupl)) then
if((dupl < psb_dupl_ovwrt_).or.(dupl > psb_dupl_err_)) then
write(0,*)'Wrong value for duplicate input in ASB...'
write(0,*)'Changing to default'
dupl_ = psb_dupl_def_
else
dupl_ = dupl
endif
else
dupl_ = psb_dupl_def_
endif
a%infoa(psb_upd_)=iupdup
if (debug) write(0,*)'in ASB',psb_upd_,iupdup
call psb_sp_setifld(upd_,psb_upd_,a,info)
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
a%m = n_row
a%k = n_col
a%m = n_row
a%k = n_col
call psb_sp_clone(a,atemp,info)
if(info /= no_err) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
call psb_sp_clone(a,atemp,info)
if(info /= no_err) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
!
! work area requested must be fixed to
! No of Grid'd processes and NNZ+2
!
!!$ size_req = max(a%infoa(psb_nnz_),1)+3
!!$ if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!!$ call psb_cest(a%fida, n_row,n_col,size_req,&
!!$ & ia1_size, ia2_size, aspk_size, iup,info)
!!$ write(0,*) 'ESTIMATE : ',ia1_size,ia2_size,aspk_Size,iup
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_cest'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ call psb_sp_reall(a,ia1_size,ia2_size,aspk_size,info)
!!$ if (info /= no_err) then
!!$ info=4010
!!$ ch_err='psb_sp_reall'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ endif
!!$
!!$ a%pl(:) = 0
!!$ a%pr(:) = 0
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
if (debugwrt) then
iout = 30+myrow
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage formatmode
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2)
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= no_err) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
if (debugwrt) then
iout = 60+myrow
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)