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_dreallocate1d
module procedure psb_dreallocated2
module procedure psb_dreallocatei2
module procedure psb_dreallocate2i1z
module procedure psb_dreallocate1z
module procedure psb_dreallocatez2
@ -285,7 +286,7 @@ Contains
! ...Local Variables
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
name='psb_dreallocated2'
@ -294,6 +295,7 @@ Contains
if (associated(rrax)) then
dim=size(rrax,1)
dim2=size(rrax,2)
If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info)
@ -306,10 +308,10 @@ Contains
!!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then
do i=1,m
tmp(i,:) = rrax(i,:)
tmp(i,1:min(len2,dim2)) = rrax(i,1:min(len2,dim2))
end do
else
tmp(1:m,:) = rrax(1:m,:)
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)
@ -331,6 +333,7 @@ Contains
endif
if (present(pad)) then
rrax(dim+1:len1,:) = pad
rrax(:,dim2+1:len2) = pad
endif
call psb_erractionrestore(err_act)
return
@ -357,7 +360,7 @@ Contains
! ...Local Variables
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
name='psb_dreallocatez2'
@ -366,6 +369,7 @@ Contains
if (associated(rrax)) then
dim=size(rrax,1)
dim2=size(rrax,2)
If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info)
@ -378,10 +382,10 @@ Contains
!!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then
do i=1,m
tmp(i,:) = rrax(i,:)
tmp(i,1:min(len2,dim2)) = rrax(i,1:min(len2,dim2))
end do
else
tmp(1:m,:) = rrax(1:m,:)
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)
@ -403,6 +407,7 @@ Contains
endif
if (present(pad)) then
rrax(dim+1:len1,:) = pad
rrax(:,dim2+1:len2) = pad
endif
call psb_erractionrestore(err_act)
return
@ -419,6 +424,80 @@ Contains
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)
use psb_error_mod

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

@ -41,8 +41,9 @@ subroutine psb_dasb(x, desc_a, info)
!....assembly dense matrix x .....
use psb_descriptor_type
use psb_const_mod
use psb_psblas_mod
use psb_comm_mod
use psb_error_mod
use psb_realloc_mod
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -51,7 +52,6 @@ subroutine psb_dasb(x, desc_a, info)
! local variables
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
double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1
@ -102,22 +102,13 @@ subroutine psb_dasb(x, desc_a, info)
i2sz = size(x,dim=2)
if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol
if (i1sz.lt.ncol) then
allocate(dtemp(ncol,i2sz),stat=info)
call psb_realloc(ncol,i2sz,x,info)
if (info.ne.0) then
info=2025
int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err)
goto 9999
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
! ..update halo elements..
@ -186,8 +177,9 @@ subroutine psb_dasbv(x, desc_a, info)
!....assembly dense matrix x .....
use psb_descriptor_type
use psb_const_mod
use psb_psblas_mod
use psb_comm_mod
use psb_error_mod
use psb_realloc_mod
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -197,7 +189,6 @@ subroutine psb_dasbv(x, desc_a, info)
! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork
integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act
real(kind(1.d0)),pointer :: dtemp(:)
double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
@ -234,19 +225,13 @@ subroutine psb_dasbv(x, desc_a, info)
i1sz = size(x)
if (debug) write(*,*) 'dasb: sizes ',i1sz,ncol
if (i1sz.lt.ncol) then
allocate(dtemp(ncol),stat=info)
call psb_realloc(ncol,x,info)
if (info.ne.0) then
info=2025
int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
do i=1,nrow
dtemp(i) = x(i)
end do
deallocate(x)
x => dtemp
endif
! ..update halo elements..

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

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

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

@ -41,8 +41,9 @@ subroutine psb_zasb(x, desc_a, info)
!....assembly dense matrix x .....
use psb_descriptor_type
use psb_const_mod
use psb_psblas_mod
use psb_comm_mod
use psb_error_mod
use psb_realloc_mod
implicit none
type(psb_desc_type), intent(in) :: desc_a
@ -51,7 +52,6 @@ subroutine psb_zasb(x, desc_a, info)
! local variables
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
double precision :: real_err(5)
logical, parameter :: debug=.false.
@ -101,22 +101,13 @@ subroutine psb_zasb(x, desc_a, info)
i2sz = size(x,dim=2)
if (debug) write(*,*) 'asb: ',i1sz,i2sz,nrow,ncol
if (i1sz.lt.ncol) then
allocate(ztemp(ncol,i2sz),stat=info)
call psb_realloc(ncol,i2sz,x,info)
if (info.ne.0) then
info=2025
int_err(1)=ncol
call psb_errpush(info,name,i_err=int_err)
goto 9999
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
! ..update halo elements..
@ -185,7 +176,7 @@ subroutine psb_zasbv(x, desc_a, info)
!....assembly dense matrix x .....
use psb_descriptor_type
use psb_const_mod
use psb_psblas_mod
use psb_comm_mod
use psb_error_mod
use psb_realloc_mod
implicit none

Write Preview
Loading…
Cancel
Save