psblas3:

base/serial/f77/smmp.f
 base/serial/impl/psb_c_mat_impl.F90
 base/serial/impl/psb_d_mat_impl.F90
 base/serial/impl/psb_s_mat_impl.F90
 base/serial/impl/psb_z_mat_impl.F90
 base/serial/psb_cnumbmm.f90
 base/serial/psb_csymbmm.f90
 base/serial/psb_dnumbmm.f90
 base/serial/psb_dsymbmm.f90
 base/serial/psb_snumbmm.f90
 base/serial/psb_ssymbmm.f90
 base/serial/psb_znumbmm.f90
 base/serial/psb_zsymbmm.f90

Fixed usage of move_alloc with polymorphic arguments.

base/serial/f77/smmp.f

@@ -210,7 +210,7 @@ c$$$     ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1
  50   continue
       return
       end
-      subroutine numbmm(n, m, l,
+      subroutine dnumbmm(n, m, l,
      *  ia, ja, diaga, a,
      *  ib, jb, diagb, b,
      *  ic, jc, diagc, c,

base/serial/impl/psb_c_mat_impl.F90

@@ -867,7 +867,7 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csget'
   logical, parameter :: debug=.false.
-  type(psb_c_coo_sparse_mat), allocatable  :: acoo
+  class(psb_c_base_sparse_mat), allocatable  :: acoo
 
 
   info = psb_success_
@@ -878,12 +878,21 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
+  allocate(psb_c_coo_sparse_mat :: acoo,stat=info)    
 
-  if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,&
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_c_coo_sparse_mat)
+      call a%a%csget(imin,imax,acoo,info,&
            & jmin,jmax,iren,append,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+      class default
+        ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
 
   call psb_erractionrestore(err_act)
@@ -920,7 +929,7 @@ subroutine psb_c_csclip(a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csclip'
   logical, parameter :: debug=.false.
-  type(psb_c_coo_sparse_mat), allocatable  :: acoo
+  class(psb_c_base_sparse_mat), allocatable  :: acoo
 
   info = psb_success_
   call psb_erractionsave(err_act)
@@ -930,11 +939,22 @@ subroutine psb_c_csclip(a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
-  if (info == psb_success_) call a%a%csclip(acoo,info,&
+  allocate(psb_c_coo_sparse_mat :: acoo,stat=info)    
+  
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_c_coo_sparse_mat)
+      call a%a%csclip(acoo,info,&
            & imin,imax,jmin,jmax,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+ 
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
   
   call psb_erractionrestore(err_act)

base/serial/impl/psb_d_mat_impl.F90

@@ -867,7 +867,7 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csget'
   logical, parameter :: debug=.false.
-  type(psb_d_coo_sparse_mat), allocatable  :: acoo
+  class(psb_d_base_sparse_mat), allocatable  :: acoo
 
 
   info = psb_success_
@@ -878,12 +878,21 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
+  allocate(psb_d_coo_sparse_mat :: acoo,stat=info)    
 
-  if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,&
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_d_coo_sparse_mat)
+      call a%a%csget(imin,imax,acoo,info,&
            & jmin,jmax,iren,append,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+      class default
+        ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
 
   call psb_erractionrestore(err_act)
@@ -920,7 +929,7 @@ subroutine psb_d_csclip(a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csclip'
   logical, parameter :: debug=.false.
-  type(psb_d_coo_sparse_mat), allocatable  :: acoo
+  class(psb_d_base_sparse_mat), allocatable  :: acoo
 
   info = psb_success_
   call psb_erractionsave(err_act)
@@ -930,11 +939,22 @@ subroutine psb_d_csclip(a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
-  if (info == psb_success_) call a%a%csclip(acoo,info,&
+  allocate(psb_d_coo_sparse_mat :: acoo,stat=info)    
+  
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_d_coo_sparse_mat)
+      call a%a%csclip(acoo,info,&
            & imin,imax,jmin,jmax,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+ 
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
   
   call psb_erractionrestore(err_act)

base/serial/impl/psb_s_mat_impl.F90

@@ -867,7 +867,7 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csget'
   logical, parameter :: debug=.false.
-  type(psb_s_coo_sparse_mat), allocatable  :: acoo
+  class(psb_s_base_sparse_mat), allocatable  :: acoo
 
 
   info = psb_success_
@@ -878,12 +878,21 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
+  allocate(psb_s_coo_sparse_mat :: acoo,stat=info)    
 
-  if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,&
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_s_coo_sparse_mat)
+      call a%a%csget(imin,imax,acoo,info,&
            & jmin,jmax,iren,append,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+      class default
+        ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
 
   call psb_erractionrestore(err_act)
@@ -920,7 +929,7 @@ subroutine psb_s_csclip(a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csclip'
   logical, parameter :: debug=.false.
-  type(psb_s_coo_sparse_mat), allocatable  :: acoo
+  class(psb_s_base_sparse_mat), allocatable  :: acoo
 
   info = psb_success_
   call psb_erractionsave(err_act)
@@ -930,11 +939,22 @@ subroutine psb_s_csclip(a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
-  if (info == psb_success_) call a%a%csclip(acoo,info,&
+  allocate(psb_s_coo_sparse_mat :: acoo,stat=info)    
+  
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_s_coo_sparse_mat)
+      call a%a%csclip(acoo,info,&
            & imin,imax,jmin,jmax,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+ 
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
   
   call psb_erractionrestore(err_act)

base/serial/impl/psb_z_mat_impl.F90

@@ -867,7 +867,7 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csget'
   logical, parameter :: debug=.false.
-  type(psb_z_coo_sparse_mat), allocatable  :: acoo
+  class(psb_z_base_sparse_mat), allocatable  :: acoo
 
 
   info = psb_success_
@@ -878,12 +878,21 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
+  allocate(psb_z_coo_sparse_mat :: acoo,stat=info)    
 
-  if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,&
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_z_coo_sparse_mat)
+      call a%a%csget(imin,imax,acoo,info,&
            & jmin,jmax,iren,append,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+      class default
+        ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
 
   call psb_erractionrestore(err_act)
@@ -920,7 +929,7 @@ subroutine psb_z_csclip(a,b,info,&
   Integer :: err_act
   character(len=20)  :: name='csclip'
   logical, parameter :: debug=.false.
-  type(psb_z_coo_sparse_mat), allocatable  :: acoo
+  class(psb_z_base_sparse_mat), allocatable  :: acoo
 
   info = psb_success_
   call psb_erractionsave(err_act)
@@ -930,11 +939,22 @@ subroutine psb_z_csclip(a,b,info,&
     goto 9999
   endif
 
-  allocate(acoo,stat=info)    
-  if (info == psb_success_) call a%a%csclip(acoo,info,&
+  allocate(psb_z_coo_sparse_mat :: acoo,stat=info)    
+  
+  if (info == psb_success_) then 
+    select type (acoo)
+    type is (psb_z_coo_sparse_mat)
+      call a%a%csclip(acoo,info,&
            & imin,imax,jmin,jmax,rscale,cscale)
-!!$  if (info == psb_success_) call move_alloc(acoo,b%a)
-  if (info == psb_success_) call b%mv_from(acoo)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
+    info = psb_err_alloc_dealloc_
+  end if
+ 
+  if (info == psb_success_) call move_alloc(acoo,b%a)
   if (info /= psb_success_) goto 9999 
   
   call psb_erractionrestore(err_act)

base/serial/psb_cnumbmm.f90

@@ -198,7 +198,7 @@ contains
     endif
 
     do i = 1,maxlmn
-      temp(i) = dzero
+      temp(i) = czero
     end do
     minlm = min(l,m)
     minln = min(l,n)
@@ -233,7 +233,7 @@ contains
             return
         else
           c%val(j) = temp(c%ja(j))
-          temp(c%ja(j)) = dzero
+          temp(c%ja(j)) = czero
         endif
       end do
     end do
@@ -242,4 +242,3 @@ contains
   end subroutine gen_numbmm
 
 end subroutine psb_cbase_numbmm
-

base/serial/psb_csymbmm.f90

@@ -46,7 +46,7 @@ subroutine psb_csymbmm(a,b,c,info)
   type(psb_cspmat_type), intent(in)    :: a,b
   type(psb_cspmat_type), intent(out)   :: c
   integer, intent(out)                  :: info
-  type(psb_c_csr_sparse_mat), allocatable :: ccsr
+  class(psb_c_base_sparse_mat), allocatable :: ccsr
   integer               :: err_act
   character(len=*), parameter ::  name='psb_symbmm'
   call psb_erractionsave(err_act)
@@ -58,13 +58,20 @@ subroutine psb_csymbmm(a,b,c,info)
     goto 9999
   endif
 
-  allocate(ccsr, stat=info)
-  if (info /= psb_success_)  then
+  allocate(psb_c_csr_sparse_mat :: ccsr,stat=info)    
+
+  if (info == psb_success_) then 
+    select type (ccsr)
+    type is (psb_c_csr_sparse_mat)
+      call psb_symbmm(a%a,b%a,ccsr,info)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
     info = psb_err_alloc_dealloc_
-    call psb_errpush(info,name) 
-    goto 9999
   end if
-  call psb_symbmm(a%a,b%a,ccsr,info)
+  
   if (info /= psb_success_) then 
     call psb_errpush(info,name) 
     goto 9999

base/serial/psb_dnumbmm.f90

@@ -169,7 +169,7 @@ contains
     mb = b%get_nrows()
     nb = b%get_ncols()
     
-    call numbmm(ma,na,nb,a%irp,a%ja,0,a%val,&
+    call dnumbmm(ma,na,nb,a%irp,a%ja,0,a%val,&
          & b%irp,b%ja,0,b%val,&
          & c%irp,c%ja,0,c%val,temp)
 

base/serial/psb_dsymbmm.f90

@@ -46,7 +46,7 @@ subroutine psb_dsymbmm(a,b,c,info)
   type(psb_dspmat_type), intent(in)    :: a,b
   type(psb_dspmat_type), intent(out)   :: c
   integer, intent(out)                  :: info
-  type(psb_d_csr_sparse_mat), allocatable :: ccsr
+  class(psb_d_base_sparse_mat), allocatable :: ccsr
   integer               :: err_act
   character(len=*), parameter ::  name='psb_symbmm'
   call psb_erractionsave(err_act)
@@ -58,13 +58,20 @@ subroutine psb_dsymbmm(a,b,c,info)
     goto 9999
   endif
 
-  allocate(ccsr, stat=info)
-  if (info /= psb_success_)  then
+  allocate(psb_d_csr_sparse_mat :: ccsr,stat=info)    
+
+  if (info == psb_success_) then 
+    select type (ccsr)
+    type is (psb_d_csr_sparse_mat)
+      call psb_symbmm(a%a,b%a,ccsr,info)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
     info = psb_err_alloc_dealloc_
-    call psb_errpush(info,name) 
-    goto 9999
   end if
-  call psb_symbmm(a%a,b%a,ccsr,info)
+  
   if (info /= psb_success_) then 
     call psb_errpush(info,name) 
     goto 9999

base/serial/psb_snumbmm.f90

@@ -198,7 +198,7 @@ contains
     endif
 
     do i = 1,maxlmn
-      temp(i) = dzero
+      temp(i) = szero
     end do
     minlm = min(l,m)
     minln = min(l,n)
@@ -233,7 +233,7 @@ contains
             return
         else
           c%val(j) = temp(c%ja(j))
-          temp(c%ja(j)) = dzero
+          temp(c%ja(j)) = szero
         endif
       end do
     end do

base/serial/psb_ssymbmm.f90

@@ -46,7 +46,7 @@ subroutine psb_ssymbmm(a,b,c,info)
   type(psb_sspmat_type), intent(in)    :: a,b
   type(psb_sspmat_type), intent(out)   :: c
   integer, intent(out)                  :: info
-  type(psb_s_csr_sparse_mat), allocatable :: ccsr
+  class(psb_s_base_sparse_mat), allocatable :: ccsr
   integer               :: err_act
   character(len=*), parameter ::  name='psb_symbmm'
   call psb_erractionsave(err_act)
@@ -58,13 +58,20 @@ subroutine psb_ssymbmm(a,b,c,info)
     goto 9999
   endif
 
-  allocate(ccsr, stat=info)
-  if (info /= psb_success_)  then
+  allocate(psb_s_csr_sparse_mat :: ccsr,stat=info)    
+
+  if (info == psb_success_) then 
+    select type (ccsr)
+    type is (psb_s_csr_sparse_mat)
+      call psb_symbmm(a%a,b%a,ccsr,info)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
     info = psb_err_alloc_dealloc_
-    call psb_errpush(info,name) 
-    goto 9999
   end if
-  call psb_symbmm(a%a,b%a,ccsr,info)
+  
   if (info /= psb_success_) then 
     call psb_errpush(info,name) 
     goto 9999

base/serial/psb_znumbmm.f90

@@ -198,7 +198,7 @@ contains
     endif
 
     do i = 1,maxlmn
-      temp(i) = dzero
+      temp(i) = zzero
     end do
     minlm = min(l,m)
     minln = min(l,n)
@@ -233,7 +233,7 @@ contains
             return
         else
           c%val(j) = temp(c%ja(j))
-          temp(c%ja(j)) = dzero
+          temp(c%ja(j)) = zzero
         endif
       end do
     end do
@@ -242,4 +242,3 @@ contains
   end subroutine gen_numbmm
 
 end subroutine psb_zbase_numbmm
-

base/serial/psb_zsymbmm.f90

@@ -46,7 +46,7 @@ subroutine psb_zsymbmm(a,b,c,info)
   type(psb_zspmat_type), intent(in)    :: a,b
   type(psb_zspmat_type), intent(out)   :: c
   integer, intent(out)                  :: info
-  type(psb_z_csr_sparse_mat), allocatable :: ccsr
+  class(psb_z_base_sparse_mat), allocatable :: ccsr
   integer               :: err_act
   character(len=*), parameter ::  name='psb_symbmm'
   call psb_erractionsave(err_act)
@@ -58,13 +58,20 @@ subroutine psb_zsymbmm(a,b,c,info)
     goto 9999
   endif
 
-  allocate(ccsr, stat=info)
-  if (info /= psb_success_)  then
+  allocate(psb_z_csr_sparse_mat :: ccsr,stat=info)    
+
+  if (info == psb_success_) then 
+    select type (ccsr)
+    type is (psb_z_csr_sparse_mat)
+      call psb_symbmm(a%a,b%a,ccsr,info)
+    class default
+      ! This is impossible
+      info = psb_err_internal_error_
+    end select
+  else
     info = psb_err_alloc_dealloc_
-    call psb_errpush(info,name) 
-    goto 9999
   end if
-  call psb_symbmm(a%a,b%a,ccsr,info)
+  
   if (info /= psb_success_) then 
     call psb_errpush(info,name) 
     goto 9999