From fb5fdf4f1a83b9ecd852372f556d7ed452d0cbda Mon Sep 17 00:00:00 2001
From: Salvatore Filippone <salvatore.filippone@cranfield.ac.uk>
Date: Fri, 23 May 2008 09:40:01 +0000
Subject: [PATCH] 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   | 3 ++-
 base/serial/aux/dasrx.f90  | 3 ++-
 base/serial/aux/dmsr.f90   | 7 ++++---
 base/serial/aux/dmsrx.f90  | 9 +++++----
 base/serial/aux/dsr.f90    | 3 ++-
 base/serial/aux/dsrx.f90   | 6 ++++--
 base/serial/aux/iasr.f90   | 3 ++-
 base/serial/aux/iasrx.f90  | 6 ++++--
 base/serial/aux/imsr.f90   | 8 ++++----
 base/serial/aux/imsrx.f90  | 8 ++++----
 base/serial/aux/isr.f90    | 3 ++-
 base/serial/aux/isrx.f90   | 6 ++++--
 base/serial/aux/zalsr.f90  | 3 ++-
 base/serial/aux/zalsrx.f90 | 6 ++++--
 base/serial/aux/zamsr.f90  | 7 ++++---
 base/serial/aux/zamsrx.f90 | 8 ++++----
 base/serial/aux/zasr.f90   | 3 ++-
 base/serial/aux/zasrx.f90  | 6 ++++--
 base/serial/aux/zlsr.f90   | 3 ++-
 base/serial/aux/zlsrx.f90  | 6 ++++--
 20 files changed, 65 insertions(+), 42 deletions(-)

diff --git a/base/serial/aux/dasr.f90 b/base/serial/aux/dasr.f90
index ea4c8ab8..2bd3960e 100644
--- a/base/serial/aux/dasr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/dasrx.f90 b/base/serial/aux/dasrx.f90
index b408bacc..ab44a8b4 100644
--- a/base/serial/aux/dasrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/dmsr.f90 b/base/serial/aux/dmsr.f90
index a91e346b..71406da5 100644
--- a/base/serial/aux/dmsr.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='dmsr')
+    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
diff --git a/base/serial/aux/dmsrx.f90 b/base/serial/aux/dmsrx.f90
index bddd4005..4250a961 100644
--- a/base/serial/aux/dmsrx.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='dmsrx')
+    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
diff --git a/base/serial/aux/dsr.f90 b/base/serial/aux/dsr.f90
index 614f57e7..e2473bb1 100644
--- a/base/serial/aux/dsr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/dsrx.f90 b/base/serial/aux/dsrx.f90
index 5c1d2091..90b89e85 100644
--- a/base/serial/aux/dsrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/iasr.f90 b/base/serial/aux/iasr.f90
index ddf7e6b9..e31399ff 100644
--- a/base/serial/aux/iasr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/iasrx.f90 b/base/serial/aux/iasrx.f90
index ca98864f..bf7eca48 100644
--- a/base/serial/aux/iasrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/imsr.f90 b/base/serial/aux/imsr.f90
index 4fec955b..f5bc74bc 100644
--- a/base/serial/aux/imsr.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='imsr')
+    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
diff --git a/base/serial/aux/imsrx.f90 b/base/serial/aux/imsrx.f90
index a0282029..671a10df 100644
--- a/base/serial/aux/imsrx.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='imsrx')
+    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
diff --git a/base/serial/aux/isr.f90 b/base/serial/aux/isr.f90
index fed4d9ea..880a28a4 100644
--- a/base/serial/aux/isr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/isrx.f90 b/base/serial/aux/isrx.f90
index 12b4e8cd..cba55699 100644
--- a/base/serial/aux/isrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zalsr.f90 b/base/serial/aux/zalsr.f90
index 89364edc..8081c871 100644
--- a/base/serial/aux/zalsr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zalsrx.f90 b/base/serial/aux/zalsrx.f90
index 4895ea06..d3911d99 100644
--- a/base/serial/aux/zalsrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zamsr.f90 b/base/serial/aux/zamsr.f90
index 627d6220..1837e5aa 100644
--- a/base/serial/aux/zamsr.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='zamsr')
+    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
diff --git a/base/serial/aux/zamsrx.f90 b/base/serial/aux/zamsrx.f90
index edbc828d..f65b5f24 100644
--- a/base/serial/aux/zamsrx.f90
+++ b/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
-    return
+    call psb_errpush(4000,r_name='zamsrx')
+    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
diff --git a/base/serial/aux/zasr.f90 b/base/serial/aux/zasr.f90
index 4aacf1e9..c274f902 100644
--- a/base/serial/aux/zasr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zasrx.f90 b/base/serial/aux/zasrx.f90
index 3bc516bf..8a6c28ba 100644
--- a/base/serial/aux/zasrx.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zlsr.f90 b/base/serial/aux/zlsr.f90
index 1b3b40be..57e281be 100644
--- a/base/serial/aux/zlsr.f90
+++ b/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
 
 
diff --git a/base/serial/aux/zlsrx.f90 b/base/serial/aux/zlsrx.f90
index 76c2c37a..478e4d29 100644
--- a/base/serial/aux/zlsrx.f90
+++ b/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