*** empty log message ***

src/modules/psb_realloc_mod.f90

@@ -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

src/tools/psb_dasb.f90

@@ -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
@@ -62,18 +62,18 @@ subroutine psb_dasb(x, desc_a, info)
   info=0
   name='psb_dasb'
   call psb_erractionsave(err_act)
-  
+
   icontxt=desc_a%matrix_data(psb_ctxt_)
   dectype=desc_a%matrix_data(psb_dec_type_)
-  
+
   call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
-  
+
   if ((.not.associated(desc_a%matrix_data))) then
-     info=3110
-     call psb_errpush(info,name)
-     goto 9999
+    info=3110
+    call psb_errpush(info,name)
+    goto 9999
   endif
-  
+
   if (debug) write(*,*) 'asb start: ',nprow,npcol,me,&
        &desc_a%matrix_data(psb_dec_type_)
   !     ....verify blacs grid correctness..
@@ -93,7 +93,7 @@ subroutine psb_dasb(x, desc_a, info)
     call psb_errpush(info,name,i_err=int_err)
     goto 9999
   endif
-   
+
   ! check size
   icontxt=desc_a%matrix_data(psb_ctxt_)
   nrow=desc_a%matrix_data(psb_n_row_)
@@ -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)
-     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
+    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
   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.
@@ -206,7 +197,7 @@ subroutine psb_dasbv(x, desc_a, info)
   info = 0
   int_err(1) = 0
   name = 'psb_dasbv'
-  
+
   icontxt=desc_a%matrix_data(psb_ctxt_)
   dectype=desc_a%matrix_data(psb_dec_type_)
 
@@ -214,18 +205,18 @@ subroutine psb_dasbv(x, desc_a, info)
 
   !     ....verify blacs grid correctness..
   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,i_err=int_err)
-     goto 9999
+    info = 2030
+    int_err(1) = npcol
+    call psb_errpush(info,name,i_err=int_err)
+    goto 9999
   else if (.not.psb_is_asb_dec(dectype)) then
-     info = 3110
-     call psb_errpush(info,name)
-     goto 9999
+    info = 3110
+    call psb_errpush(info,name)
+    goto 9999
   endif
 
   nrow=desc_a%matrix_data(psb_n_row_)
@@ -234,20 +225,14 @@ 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  
+  endif
   
   ! ..update halo elements..
   call psb_halo(x,desc_a,info)

src/tools/psb_iasb.f90

@@ -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.
@@ -63,24 +63,24 @@ subroutine psb_iasb(x, 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
   endif
-  
+
   icontxt=desc_a%matrix_data(psb_ctxt_)
   dectype=desc_a%matrix_data(psb_dec_type_)
-  
+
   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 size
@@ -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)
-     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
+    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
   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..

src/tools/psb_zasb.f90

@@ -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.
@@ -61,18 +61,18 @@ subroutine psb_zasb(x, desc_a, info)
   info=0
   name='psb_zasb'
   call psb_erractionsave(err_act)
-  
+
   icontxt=desc_a%matrix_data(psb_ctxt_)
   dectype=desc_a%matrix_data(psb_dec_type_)
-  
+
   call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
-  
+
   if ((.not.associated(desc_a%matrix_data))) then
-     info=3110
-     call psb_errpush(info,name)
-     goto 9999
+    info=3110
+    call psb_errpush(info,name)
+    goto 9999
   endif
-  
+
   if (debug) write(*,*) 'asb start: ',nprow,npcol,me,&
        &desc_a%matrix_data(psb_dec_type_)
   !     ....verify blacs grid correctness..
@@ -92,7 +92,7 @@ subroutine psb_zasb(x, desc_a, info)
     call psb_errpush(info,name,i_err=int_err)
     goto 9999
   endif
-   
+
   ! check size
   icontxt=desc_a%matrix_data(psb_ctxt_)
   nrow=desc_a%matrix_data(psb_n_row_)
@@ -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)
-     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
+    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
   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