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

*** empty log message ***

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent 4ccc9ead15
commit a42b4b95ac
4 changed files with 159 additions and 112 deletions
Show Stats Download Patch File Download Diff File

91
src/modules/psb_realloc_mod.f90
Unescape Escape View File

@ -38,6 +38,7 @@ module psb_realloc_mod
module procedure psb_dreallocate2i1d module procedure psb_dreallocate2i1d
module procedure psb_dreallocate1d module procedure psb_dreallocate1d
module procedure psb_dreallocated2 module procedure psb_dreallocated2
module procedure psb_dreallocatei2
module procedure psb_dreallocate2i1z module procedure psb_dreallocate2i1z
module procedure psb_dreallocate1z module procedure psb_dreallocate1z
module procedure psb_dreallocatez2 module procedure psb_dreallocatez2
@ -285,7 +286,7 @@ Contains
! ...Local Variables ! ...Local Variables
Real(kind(1.d0)),Pointer :: tmp(:,:) Real(kind(1.d0)),Pointer :: tmp(:,:)
Integer :: dim,err_act,err,i, m Integer :: dim,err_act,err,i, m, dim2
character(len=20) :: name character(len=20) :: name
name='psb_dreallocated2' name='psb_dreallocated2'
@ -294,6 +295,7 @@ Contains
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax,1) dim=size(rrax,1)
dim2=size(rrax,2)
If (dim /= len1) Then If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info) Allocate(tmp(len1,len2),stat=info)
@ -306,10 +308,10 @@ Contains
!!$ write(0,*) 'DA: copying ',min(len,dim) !!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then if (.true.) then
do i=1,m do i=1,m
tmp(i,:) = rrax(i,:) tmp(i,1:min(len2,dim2)) = rrax(i,1:min(len2,dim2))
end do end do
else else
tmp(1:m,:) = rrax(1:m,:) tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
end if end if
!!$ write(0,*) 'DA: copying done ',m !!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
@ -331,6 +333,7 @@ Contains
endif endif
if (present(pad)) then if (present(pad)) then
rrax(dim+1:len1,:) = pad rrax(dim+1:len1,:) = pad
rrax(:,dim2+1:len2) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -357,7 +360,7 @@ Contains
! ...Local Variables ! ...Local Variables
complex(kind(1.d0)),Pointer :: tmp(:,:) complex(kind(1.d0)),Pointer :: tmp(:,:)
Integer :: dim,err_act,err,i, m Integer :: dim,err_act,err,i, m, dim2
character(len=20) :: name character(len=20) :: name
name='psb_dreallocatez2' name='psb_dreallocatez2'
@ -366,6 +369,7 @@ Contains
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax,1) dim=size(rrax,1)
dim2=size(rrax,2)
If (dim /= len1) Then If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info) Allocate(tmp(len1,len2),stat=info)
@ -378,10 +382,10 @@ Contains
!!$ write(0,*) 'DA: copying ',min(len,dim) !!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then if (.true.) then
do i=1,m do i=1,m
tmp(i,:) = rrax(i,:) tmp(i,1:min(len2,dim2)) = rrax(i,1:min(len2,dim2))
end do end do
else else
tmp(1:m,:) = rrax(1:m,:) tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
end if end if
!!$ write(0,*) 'DA: copying done ',m !!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
@ -403,6 +407,7 @@ Contains
endif endif
if (present(pad)) then if (present(pad)) then
rrax(dim+1:len1,:) = pad rrax(dim+1:len1,:) = pad
rrax(:,dim2+1:len2) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -419,6 +424,80 @@ Contains
End Subroutine psb_dreallocatez2 End Subroutine psb_dreallocatez2
Subroutine psb_dreallocatei2(len1,len2,rrax,info,pad)
use psb_error_mod
! ...Subroutine Arguments
Integer,Intent(in) :: len1,len2
integer,pointer :: rrax(:,:)
integer :: info
integer, optional, intent(in) :: pad
! ...Local Variables
integer,Pointer :: tmp(:,:)
Integer :: dim,err_act,err,i, m, dim2
character(len=20) :: name
name='psb_dreallocatei2'
call psb_erractionsave(err_act)
info = 0
if (associated(rrax)) then
dim=size(rrax,1)
dim2=size(rrax,2)
If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
m = min(dim,len1)
!!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then
do i=1,m
tmp(i,1:min(len2,dim2)) = rrax(i,1:min(len2,dim2))
end do
else
tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
end if
!!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
End If
else
dim = 0
Allocate(rrax(len1,len2),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif
if (present(pad)) then
rrax(dim+1:len1,:) = pad
rrax(:,dim2+1:len2) = pad
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()
end if
return
End Subroutine psb_dreallocatei2
Subroutine psb_dreallocate2i(len,rrax,y,info,pad) Subroutine psb_dreallocate2i(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod

79
src/tools/psb_dasb.f90
Unescape Escape View File

@ -41,8 +41,9 @@ subroutine psb_dasb(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -51,7 +52,6 @@ subroutine psb_dasb(x, desc_a, info)
! local variables ! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act
real(kind(1.d0)),pointer :: dtemp(:,:)
integer :: int_err(5), i1sz, i2sz, dectype, i,j integer :: int_err(5), i1sz, i2sz, dectype, i,j
double precision :: real_err(5) double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1 real(kind(1.d0)),parameter :: one=1
@ -62,18 +62,18 @@ subroutine psb_dasb(x, desc_a, info)
info=0 info=0
name='psb_dasb' name='psb_dasb'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& if (debug) write(*,*) 'asb start: ',nprow,npcol,me,&
&desc_a%matrix_data(psb_dec_type_) &desc_a%matrix_data(psb_dec_type_)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
@ -93,7 +93,7 @@ subroutine psb_dasb(x, desc_a, info)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
! check size ! check size
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
nrow=desc_a%matrix_data(psb_n_row_) nrow=desc_a%matrix_data(psb_n_row_)
@ -102,22 +102,13 @@ subroutine psb_dasb(x, desc_a, info)
i2sz = size(x,dim=2) i2sz = size(x,dim=2)
if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol
if (i1sz.lt.ncol) then if (i1sz.lt.ncol) then
allocate(dtemp(ncol,i2sz),stat=info) call psb_realloc(ncol,i2sz,x,info)
if (info.ne.0) then if (info.ne.0) then
info=2025 info=2025
int_err(1)=ncol int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
do j=1,size(x,2)
do i=1,nrow
dtemp(i,j) = x(i,j)
end do
end do
deallocate(x)
x => dtemp
endif endif
! ..update halo elements.. ! ..update halo elements..
@ -186,8 +177,9 @@ subroutine psb_dasbv(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -197,7 +189,6 @@ subroutine psb_dasbv(x, desc_a, info)
! local variables ! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork
integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act
real(kind(1.d0)),pointer :: dtemp(:)
double precision :: real_err(5) double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1 real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -206,7 +197,7 @@ subroutine psb_dasbv(x, desc_a, info)
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
name = 'psb_dasbv' name = 'psb_dasbv'
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
@ -214,18 +205,18 @@ subroutine psb_dasbv(x, desc_a, info)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
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,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
else if (.not.psb_is_asb_dec(dectype)) then else if (.not.psb_is_asb_dec(dectype)) then
info = 3110 info = 3110
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
nrow=desc_a%matrix_data(psb_n_row_) nrow=desc_a%matrix_data(psb_n_row_)
@ -234,20 +225,14 @@ subroutine psb_dasbv(x, desc_a, info)
i1sz = size(x) i1sz = size(x)
if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol
if (i1sz.lt.ncol) then if (i1sz.lt.ncol) then
allocate(dtemp(ncol),stat=info) call psb_realloc(ncol,x,info)
if (info.ne.0) then if (info.ne.0) then
info=2025 info=2025
int_err(1)=ncol int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
endif
do i=1,nrow
dtemp(i) = x(i)
end do
deallocate(x)
x => dtemp
endif
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

56
src/tools/psb_iasb.f90
Unescape Escape View File

@ -41,8 +41,9 @@ subroutine psb_iasb(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -51,7 +52,6 @@ subroutine psb_iasb(x, desc_a, info)
! local variables ! local variables
integer :: icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol,err_act integer :: icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol,err_act
integer, pointer :: itemp(:,:)
integer :: int_err(5), i1sz, i2sz, dectype, i integer :: int_err(5), i1sz, i2sz, dectype, i
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -63,24 +63,24 @@ subroutine psb_iasb(x, desc_a, info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
return return
endif endif
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
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 size ! check size
@ -91,17 +91,13 @@ subroutine psb_iasb(x, desc_a, info)
i2sz = size(x,dim=2) i2sz = size(x,dim=2)
if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol
if (i1sz.lt.ncol) then if (i1sz.lt.ncol) then
allocate(itemp(ncol,i2sz),stat=info) call psb_realloc(ncol,i2sz,x,info)
if (info.ne.0) then if (info.ne.0) then
info=2025 info=2025
int_err(1)=ncol int_err(1)=ncol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
itemp(nrow+1:,:) = 0
itemp(1:nrow,:) = x(1:nrow,:)
deallocate(x)
x => itemp
endif endif
! ..update halo elements.. ! ..update halo elements..
@ -163,8 +159,9 @@ subroutine psb_iasbv(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -174,7 +171,6 @@ subroutine psb_iasbv(x, desc_a, info)
! local variables ! local variables
integer :: icontxt,nprow,npcol,me,mypcol,temp,lwork, err_act integer :: icontxt,nprow,npcol,me,mypcol,temp,lwork, err_act
integer :: int_err(5), i1sz,nrow,ncol, dectype, i integer :: int_err(5), i1sz,nrow,ncol, dectype, i
integer, pointer :: itemp(:)
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -206,17 +202,13 @@ subroutine psb_iasbv(x, desc_a, info)
i1sz = size(x) i1sz = size(x)
if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol
if (i1sz.lt.ncol) then if (i1sz.lt.ncol) then
allocate(itemp(ncol),stat=info) call psb_realloc(ncol,x,info)
if (info.ne.0) then if (info.ne.0) then
info=2025 info=2025
int_err(1)=ncol int_err(1)=ncol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
itemp(nrow+1:) = 0
itemp(1:nrow) = x(1:nrow)
deallocate(x)
x => itemp
endif endif
! ..update halo elements.. ! ..update halo elements..

45
src/tools/psb_zasb.f90
Unescape Escape View File

@ -41,8 +41,9 @@ subroutine psb_zasb(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod
implicit none implicit none
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
@ -51,7 +52,6 @@ subroutine psb_zasb(x, desc_a, info)
! local variables ! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act
complex(kind(1.d0)),pointer :: ztemp(:,:)
integer :: int_err(5), i1sz, i2sz, dectype, i,j integer :: int_err(5), i1sz, i2sz, dectype, i,j
double precision :: real_err(5) double precision :: real_err(5)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -61,18 +61,18 @@ subroutine psb_zasb(x, desc_a, info)
info=0 info=0
name='psb_zasb' name='psb_zasb'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) write(*,*) 'asb start: ',nprow,npcol,me,& if (debug) write(*,*) 'asb start: ',nprow,npcol,me,&
&desc_a%matrix_data(psb_dec_type_) &desc_a%matrix_data(psb_dec_type_)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
@ -92,7 +92,7 @@ subroutine psb_zasb(x, desc_a, info)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
! check size ! check size
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
nrow=desc_a%matrix_data(psb_n_row_) nrow=desc_a%matrix_data(psb_n_row_)
@ -101,22 +101,13 @@ subroutine psb_zasb(x, desc_a, info)
i2sz = size(x,dim=2) i2sz = size(x,dim=2)
if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol
if (i1sz.lt.ncol) then if (i1sz.lt.ncol) then
allocate(ztemp(ncol,i2sz),stat=info) call psb_realloc(ncol,i2sz,x,info)
if (info.ne.0) then if (info.ne.0) then
info=2025 info=2025
int_err(1)=ncol int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
do j=1,size(x,2)
do i=1,nrow
ztemp(i,j) = x(i,j)
end do
end do
deallocate(x)
x => ztemp
endif endif
! ..update halo elements.. ! ..update halo elements..
@ -185,7 +176,7 @@ subroutine psb_zasbv(x, desc_a, info)
!....assembly dense matrix x ..... !....assembly dense matrix x .....
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none

Write Preview
Loading…
Cancel
Save