psblas2-dev:

base/serial/aux/dasr.f90
 base/serial/aux/dasrx.f90
 base/serial/aux/dsr.f90
 base/serial/aux/dsrx.f90
 base/serial/aux/iasr.f90
 base/serial/aux/iasrx.f90
 base/serial/aux/isr.f90
 base/serial/aux/isrx.f90
 base/serial/aux/zalsr.f90
 base/serial/aux/zalsrx.f90
 base/serial/aux/zasr.f90
 base/serial/aux/zasrx.f90
 base/serial/aux/zlsr.f90
 base/serial/aux/zlsrx.f90

Added sensible error handling fixes into serial sorting routines.

base/serial/aux/dasr.f90

@@ -303,7 +303,8 @@ subroutine dasr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='dasr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/dasrx.f90

@@ -343,7 +343,8 @@ subroutine dasrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='dasrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/dmsr.f90

@@ -54,8 +54,8 @@ subroutine dmsr(n,x,idir)
   
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory allocation failed',info
+    call psb_errpush(4000,r_name='dmsr')
-    return
+    call psb_error()
   endif
   
   if (idir==psb_sort_up_) then 
@@ -86,7 +86,8 @@ subroutine dmsr(n,x,idir)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory deallocation failed',info
+    call psb_errpush(4000,r_name='dmsr')
+    call psb_error()
   endif
   return
 end subroutine dmsr

base/serial/aux/dmsrx.f90

@@ -45,7 +45,7 @@ subroutine dmsrx(n,x,indx,idir,flag)
   real(psb_dpk_) :: swap
 
   if (n<0) then 
-    write(0,*) 'Error: DMSRX: N<0'
+!!$    write(0,*) 'Error: DMSRX: N<0'
     return
   endif
 
@@ -61,8 +61,8 @@ subroutine dmsrx(n,x,indx,idir,flag)
 
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'DMSRX: memory allocation failed',info
+    call psb_errpush(4000,r_name='dmsrx')
-    return
+    call psb_error()
   endif
 
   if (idir == psb_sort_up_) then 
@@ -96,7 +96,8 @@ subroutine dmsrx(n,x,indx,idir,flag)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'DMSRX: memory deallocation failed',info
+    call psb_errpush(4000,r_name='dmsrx')
+    call psb_error()
   endif
   return
 end subroutine dmsrx

base/serial/aux/dsr.f90

@@ -303,7 +303,8 @@ subroutine dsr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='dsr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/dsrx.f90

@@ -58,7 +58,8 @@ subroutine dsrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='isrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -345,7 +346,8 @@ subroutine dsrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='dsrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/iasr.f90

@@ -303,7 +303,8 @@ subroutine iasr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='iasr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/iasrx.f90

@@ -58,7 +58,8 @@ subroutine iasrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='iasrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -343,7 +344,8 @@ subroutine iasrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='iasrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/imsr.f90

@@ -46,7 +46,6 @@ subroutine imsr(n,x,idir)
   integer :: lswap
 
   if (n<0) then 
-!!$    write(0,*) 'Error: IMSR: N<0'
     return
   endif
   
@@ -54,8 +53,8 @@ subroutine imsr(n,x,idir)
   
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory allocation failed',info
+    call psb_errpush(4000,r_name='imsr')
-    return
+    call psb_error()
   endif
   
   if (idir==psb_sort_up_) then 
@@ -86,7 +85,8 @@ subroutine imsr(n,x,idir)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory deallocation failed',info
+    call psb_errpush(4000,r_name='imsr')
+    call psb_error()
   endif
   return
 end subroutine imsr

base/serial/aux/imsrx.f90

@@ -45,7 +45,6 @@ subroutine imsrx(n,x,indx,idir,flag)
   integer :: lswap, ixswap
 
   if (n<0) then 
-    write(0,*) 'Error: IMSRX: N<0'
     return
   endif
 
@@ -61,8 +60,8 @@ subroutine imsrx(n,x,indx,idir,flag)
 
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSRX: memory allocation failed',info
+    call psb_errpush(4000,r_name='imsrx')
-    return
+    call psb_error()
   endif
 
   if (idir == psb_sort_up_) then 
@@ -96,7 +95,8 @@ subroutine imsrx(n,x,indx,idir,flag)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSRX: memory deallocation failed',info
+    call psb_errpush(4000,r_name='imsrx')
+    call psb_error()
   endif
   return
 end subroutine imsrx

base/serial/aux/isr.f90

@@ -303,7 +303,8 @@ subroutine isr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='isr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/isrx.f90

@@ -57,7 +57,8 @@ subroutine isrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='isrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -345,7 +346,8 @@ subroutine isrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='isrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zalsr.f90

@@ -304,7 +304,8 @@ subroutine zalsr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='zalsr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zalsrx.f90

@@ -59,7 +59,8 @@ subroutine zalsrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='zalsrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -347,7 +348,8 @@ subroutine zalsrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='zalsrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zamsr.f90

@@ -54,8 +54,8 @@ subroutine zamsr(n,x,idir)
   
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory allocation failed',info
+    call psb_errpush(4000,r_name='zamsr')
-    return
+    call psb_error()
   endif
   
   if (idir==psb_asort_up_) then 
@@ -86,7 +86,8 @@ subroutine zamsr(n,x,idir)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'IMSR: memory deallocation failed',info
+    call psb_errpush(4000,r_name='zamsr')
+    call psb_error()
   endif
   return
 end subroutine zamsr

base/serial/aux/zamsrx.f90

@@ -45,7 +45,6 @@ subroutine zamsrx(n,x,indx,idir,flag)
   complex(psb_dpk_) :: swap
 
   if (n<0) then 
-    write(0,*) 'Error: DMSRX: N<0'
     return
   endif
 
@@ -61,8 +60,8 @@ subroutine zamsrx(n,x,indx,idir,flag)
 
   allocate(iaux(0:n+1),stat=info)
   if (info/=0) then 
-    write(0,*) 'DMSRX: memory allocation failed',info
+    call psb_errpush(4000,r_name='zamsrx')
-    return
+    call psb_error()
   endif
 
   if (idir == psb_asort_up_) then 
@@ -96,7 +95,8 @@ subroutine zamsrx(n,x,indx,idir,flag)
 
   deallocate(iaux,stat=info)
   if (info/=0) then 
-    write(0,*) 'DMSRX: memory deallocation failed',info
+    call psb_errpush(4000,r_name='zamsrx')
+    call psb_error()
   endif
   return
 end subroutine zamsrx

base/serial/aux/zasr.f90

@@ -304,7 +304,8 @@ subroutine zasr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='zasr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zasrx.f90

@@ -59,7 +59,8 @@ subroutine zasrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='zasrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -347,7 +348,8 @@ subroutine zasrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='zasrx',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zlsr.f90

@@ -304,7 +304,8 @@ subroutine zlsr(n,x,dir)
     endif
 
   case default
-    write(0,*) 'isr error !',dir
+    call psb_errpush(4001,r_name='zlsr',a_err='wrong dir')
+    call psb_error()
   end select
 
 

base/serial/aux/zlsrx.f90

@@ -59,7 +59,8 @@ subroutine zlsrx(n,x,indx,dir,flag)
   case(psb_sort_keep_idx_)
     ! do nothing
   case default
-    write(0,*) 'Error in isrx: invalid flag',flag
+    call psb_errpush(4001,r_name='zlsrx',a_err='wrong flag')
+    call psb_error()
   end select
   !
 
@@ -347,7 +348,8 @@ subroutine zlsrx(n,x,indx,dir,flag)
     endif
 
   case default
-    write(0,*) 'isrx error  dir ',dir
+    call psb_errpush(4001,r_name='zlsrx',a_err='wrong dir')
+    call psb_error()
   end select