fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Changed to allow summing multiple entities.

Browse Source
psblas3-type-indexed
Salvatore Filippone 21 years ago
parent bf754a9274
commit 6860f244cc
3 changed files with 256 additions and 256 deletions
Show Stats Download Patch File Download Diff File

378
src/tools/psb_dins.f90
Unescape Escape View File

@ -76,14 +76,14 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
name = 'psb_dins' name = 'psb_dins'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -91,91 +91,91 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (n.lt.0) then else if (n.lt.0) then
info = 10 info = 10
int_err(1) = 2 int_err(1) = 2
int_err(2) = n int_err(2) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (jx.lt.1) then else if (jx.lt.1) then
info = 20 info = 20
int_err(1) = 7 int_err(1) = 7
int_err(2) = jx int_err(2) = jx
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_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 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=2).lt.n) then else if (size(x, dim=2).lt.n) then
! check if dimension of x is greater than dimension of submatrix ! check if dimension of x is greater than dimension of submatrix
! to insert ! to insert
info = 320 info = 320
int_err(1) = 2 int_err(1) = 2
int_err(2) = size(x, dim=2) int_err(2) = size(x, dim=2)
int_err(3) = n int_err(3) = n
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_cols = desc_a%matrix_data(psb_n_col_) loc_cols = desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(jblck)) then if (present(jblck)) then
jblock = jblck jblock = jblck
else else
jblock = 1 jblock = 1
endif endif
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
do col = 1, n do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1) x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo enddo
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -185,9 +185,9 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return
@ -277,14 +277,14 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
name = 'psb_dinsvm' name = 'psb_dinsvm'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -292,79 +292,79 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (jx.lt.1) then else if (jx.lt.1) then
info = 20 info = 20
int_err(1) = 7 int_err(1) = 7
int_err(2) = jx int_err(2) = jx
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_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 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=2).lt.1) then else if (size(x, dim=2).lt.1) then
! check if dimension of x is greater than dimension of submatrix ! check if dimension of x is greater than dimension of submatrix
! to insert ! to insert
info = 320 info = 320
int_err(1) = 2 int_err(1) = 2
int_err(2) = size(x, dim=2) int_err(2) = size(x, dim=2)
int_err(3) = 1 int_err(3) = 1
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_cols=desc_a%matrix_data(psb_n_col_) loc_cols=desc_a%matrix_data(psb_n_col_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1) x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -374,9 +374,9 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return
@ -463,14 +463,14 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
name = 'psb_dinsvv' name = 'psb_dinsvv'
if (.not.associated(desc_a%glob_to_loc)) then if (.not.associated(desc_a%glob_to_loc)) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
int_err(1)=3110 int_err(1)=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
@ -478,40 +478,40 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
!... check parameters.... !... check parameters....
if (m.lt.0) then if (m.lt.0) then
info = 10 info = 10
int_err(1) = 1 int_err(1) = 1
int_err(2) = m int_err(2) = m
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (ix.lt.1) then else if (ix.lt.1) then
info = 20 info = 20
int_err(1) = 6 int_err(1) = 6
int_err(2) = ix int_err(2) = ix
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (.not.psb_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 info = 3110
int_err(1) = desc_a%matrix_data(psb_dec_type_) int_err(1) = desc_a%matrix_data(psb_dec_type_)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then else if (size(x, dim=1).lt.desc_a%matrix_data(psb_n_row_)) then
info = 310 info = 310
int_err(1) = 5 int_err(1) = 5
int_err(2) = 4 int_err(2) = 4
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
loc_rows=desc_a%matrix_data(psb_n_row_) loc_rows=desc_a%matrix_data(psb_n_row_)
@ -519,40 +519,40 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (present(iblck)) then if (present(iblck)) then
iblock = iblck iblock = iblck
else else
iblock = 1 iblock = 1
endif endif
if (present(insflag)) then if (present(insflag)) then
liflag = insflag liflag = insflag
else else
liflag = psb_upd_glb_ liflag = psb_upd_glb_
end if end if
if (liflag == psb_upd_glb_) then if (liflag == psb_upd_glb_) then
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1) x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if end if
enddo enddo
else if (liflag == psb_upd_loc_) then else if (liflag == psb_upd_loc_) then
k = min(ix+m-1,loc_rows) k = min(ix+m-1,loc_rows)
do i=ix,k do i=ix,k
x(i) = blck(i-ix+1) x(i) = x(i) + blck(i-ix+1)
enddo enddo
else else
info=-1 info=-1
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -562,9 +562,9 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(icontxt)
end if end if
return return

52
src/tools/psb_iins.f90
Unescape Escape View File

@ -163,19 +163,19 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
endif endif
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
do col = 1, n do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1) x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo enddo
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -286,18 +286,18 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
endif endif
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1) x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -463,7 +463,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1) x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if end if
enddo enddo

82
src/tools/psb_zins.f90
Unescape Escape View File

@ -165,17 +165,17 @@ subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
do col = 1, n do col = 1, n
x(loc_row,jx+col-1) = blck(iblock+i-1,jblock+col-1) x(loc_row,jx+col-1) = x(loc_row,jx+col-1) + blck(iblock+i-1,jblock+col-1)
enddo enddo
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -353,18 +353,18 @@ subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
endif endif
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row,jx) = blck(iblock+i-1) x(loc_row,jx) = x(loc_row,jx) + blck(iblock+i-1)
end if end if
enddo enddo
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -530,25 +530,25 @@ subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
end if end if
if (liflag == psb_upd_glb_) then if (liflag == psb_upd_glb_) then
do i = 1, m do i = 1, m
!loop over all blck's rows !loop over all blck's rows
! row actual block row ! row actual block row
glob_row=ix+i-1 glob_row=ix+i-1
if (glob_row > mglob) exit if (glob_row > mglob) exit
loc_row=desc_a%glob_to_loc(glob_row) loc_row=desc_a%glob_to_loc(glob_row)
if (loc_row.ge.1) then if (loc_row.ge.1) then
! this row belongs to me ! this row belongs to me
! copy i-th row of block blck in x ! copy i-th row of block blck in x
x(loc_row) = blck(iblock+i-1) x(loc_row) = x(loc_row) + blck(iblock+i-1)
end if end if
enddo enddo
else if (liflag == psb_upd_loc_) then else if (liflag == psb_upd_loc_) then
k = min(ix+m-1,loc_rows) k = min(ix+m-1,loc_rows)
do i=ix,k do i=ix,k
x(i) = blck(i-ix+1) x(i) = x(i) + blck(i-ix+1)
enddo enddo
else else
info=-1 info=-1
call psb_errpush(info,name) call psb_errpush(info,name)

Write Preview
Loading…
Cancel
Save