base/modules/parts.f90

@@ -1,8 +0,0 @@
-module psb_parts_mod
-  interface 
-     subroutine psb_parts(glob_index,nrow,np,pv,nv)
-       integer(psb_ipk_), intent (in)  :: glob_index,np,nrow
-       integer(psb_ipk_), intent (out) :: nv, pv(*)
-     end subroutine psb_parts
-  end interface
-end module psb_parts_mod

base/modules/parts.fh

@@ -1,8 +0,0 @@
-interface 
-   !.....user passed subroutine.....
-   subroutine parts(glob_index,nrow,np,pv,nv)
-     import :: psb_ipk_
-     integer(psb_ipk_), intent (in)  :: glob_index,np,nrow
-     integer(psb_ipk_), intent (out) :: nv, pv(*)
-   end subroutine parts
-end interface

base/modules/psb_error_impl.F90

@@ -9,6 +9,57 @@ subroutine psb_errcomm(ictxt, err)
 
 end subroutine psb_errcomm
 
+subroutine psb_ser_error_handler(err_act)
+  use psb_error_mod, psb_protect_name => psb_ser_error_handler
+  use psb_penv_mod
+  implicit none 
+  integer(psb_ipk_), intent(inout) ::  err_act
+  
+  call psb_erractionrestore(err_act)
+  
+  if (err_act /= psb_act_ret_)     &
+       &  call psb_error()
+  if (err_act == psb_act_abort_) stop
+
+  return 
+end subroutine psb_ser_error_handler
+
+subroutine psb_par_error_handler(ictxt,err_act)
+  use psb_error_mod, psb_protect_name => psb_par_error_handler
+  use psb_penv_mod
+  implicit none 
+  integer(psb_mpik_), intent(in) ::  ictxt
+  integer(psb_ipk_), intent(in) ::  err_act
+
+  call psb_erractionrestore(err_act)
+  
+  if (err_act == psb_act_print_)     &
+       &  call psb_error(ictxt, abrt=.false.)
+  if (err_act == psb_act_abort_)      &
+       &  call psb_error(ictxt, abrt=.true.)
+
+  return 
+
+end subroutine psb_par_error_handler
+
+subroutine psb_par_error_print_stack(ictxt)
+  use psb_error_mod, psb_protect_name => psb_par_error_print_stack
+  use psb_penv_mod
+  integer(psb_mpik_), intent(in) ::  ictxt
+
+  call psb_error(ictxt, abrt=.false.)
+  
+end subroutine psb_par_error_print_stack
+
+subroutine psb_ser_error_print_stack()
+  use psb_error_mod, psb_protect_name => psb_ser_error_print_stack
+
+  call psb_error()
+end subroutine psb_ser_error_print_stack
+
+
+
+
 ! handles the occurence of an error in a serial routine
 subroutine psb_serror()
   use psb_const_mod
@@ -39,7 +90,7 @@ subroutine psb_serror()
     end if
   end if
 #if defined(HAVE_FLUSH_STMT)
-  flush(0) 
+  flush(psb_err_unit) 
 #endif
 
 
@@ -47,18 +98,23 @@ end subroutine psb_serror
 
 
 ! handles the occurence of an error in a parallel routine
-subroutine psb_perror(ictxt)
+subroutine psb_perror(ictxt,abrt)
   use psb_const_mod
   use psb_error_mod
   use psb_penv_mod
   implicit none 
   integer(psb_mpik_), intent(in) :: ictxt
+  logical, intent(in), optional  :: abrt
+
   integer(psb_ipk_)  :: err_c
   character(len=20)  :: r_name
   character(len=40)  :: a_e_d
   integer(psb_ipk_)  :: i_e_d(5)
   integer(psb_mpik_) :: iam, np
+  logical :: abrt_
 
+  abrt_=.true.
+  if (present(abrt)) abrt_=abrt
   call psb_info(ictxt,iam,np)
   
   if (psb_errstatus_fatal()) then
@@ -71,10 +127,10 @@ subroutine psb_perror(ictxt)
         !            write(psb_err_unit,'(50("="))')
       end do
 #if defined(HAVE_FLUSH_STMT)
-      flush(0) 
+      flush(psb_err_unit) 
 #endif
       
-      call psb_abort(ictxt,-1)
+      if (abrt_) call psb_abort(ictxt,-1)
       
     else
 
@@ -84,10 +140,10 @@ subroutine psb_perror(ictxt)
         call psb_errpop(err_c, r_name, i_e_d, a_e_d)
       end do
 #if defined(HAVE_FLUSH_STMT)
-      flush(0) 
+      flush(psb_err_unit) 
 #endif
 
-      call psb_abort(ictxt,-1)
+      if (abrt_) call psb_abort(ictxt,-1)
 
     end if
   end if

base/modules/psb_error_mod.F90

@@ -32,7 +32,9 @@
 module psb_error_mod
   use psb_const_mod
 
-  integer(psb_ipk_), parameter, public :: psb_act_ret_=0, psb_act_abort_=1
+  integer(psb_ipk_), parameter, public :: psb_act_ret_=0
+  integer(psb_ipk_), parameter, public :: psb_act_print_=1
+  integer(psb_ipk_), parameter, public :: psb_act_abort_=2
   integer(psb_ipk_), parameter, public :: psb_debug_ext_=1, psb_debug_outer_=2
   integer(psb_ipk_), parameter, public :: psb_debug_comp_=3, psb_debug_inner_=4
   integer(psb_ipk_), parameter, public :: psb_debug_serial_=8, psb_debug_serial_comp_=9
@@ -53,21 +55,48 @@ module psb_error_mod
        & psb_get_errverbosity, psb_set_errverbosity, &
        & psb_erractionsave, psb_erractionrestore, &
        & psb_get_erraction, psb_set_erraction, &
+       & psb_set_erract_return, psb_set_erract_print, psb_set_erract_abort,&
+       & psb_is_erract_return, psb_is_erract_print, psb_is_erract_abort,&
        & psb_get_debug_level, psb_set_debug_level,&
        & psb_get_debug_unit, psb_set_debug_unit,&
        & psb_get_serial_debug_level, psb_set_serial_debug_level,&
-       & psb_clean_errstack
+       & psb_clean_errstack, psb_error_handler, &
+       & psb_ser_error_handler, psb_par_error_handler, &
+       & psb_ser_error_print_stack, psb_par_error_print_stack
 
 
+  interface psb_error_handler
+    subroutine psb_ser_error_handler(err_act)
+      import :: psb_ipk_
+      integer(psb_ipk_), intent(in) ::  err_act
+    end subroutine psb_ser_error_handler
+    subroutine psb_par_error_handler(ictxt,err_act)
+      import :: psb_ipk_,psb_mpik_
+      integer(psb_mpik_), intent(in) ::  ictxt
+      integer(psb_ipk_), intent(in) ::  err_act
+    end subroutine psb_par_error_handler
+  end interface
+ 
   interface psb_error
     subroutine psb_serror()
     end subroutine psb_serror
-    subroutine psb_perror(ictxt)
+    subroutine psb_perror(ictxt,abrt)
       import :: psb_mpik_
       integer(psb_mpik_), intent(in) ::  ictxt
+      logical, intent(in), optional  :: abrt
     end subroutine psb_perror
   end interface
 
+
+  interface psb_error_print_stack
+    subroutine psb_par_error_print_stack(ictxt)
+      import :: psb_ipk_,psb_mpik_
+      integer(psb_mpik_), intent(in) ::  ictxt
+    end subroutine psb_par_error_print_stack
+    subroutine psb_ser_error_print_stack()
+    end subroutine psb_ser_error_print_stack
+  end interface
+
   interface psb_errcomm
     subroutine psb_errcomm(ictxt, err)
       import :: psb_mpik_, psb_ipk_
@@ -76,6 +105,12 @@ module psb_error_mod
     end subroutine psb_errcomm
   end interface psb_errcomm
 
+  interface psb_errpop
+    module procedure psb_errpop, psb_ach_errpop
+  end interface
+  interface psb_errmsg
+    module procedure psb_errmsg, psb_ach_errmsg
+  end interface
 
 #if defined(LONG_INTEGERS)
   interface psb_error
@@ -123,7 +158,7 @@ module psb_error_mod
   integer(psb_ipk_), save   :: error_status    = psb_no_err_    
   integer(psb_ipk_), save   :: verbosity_level = 1 
   integer(psb_ipk_), save   :: err_action      = psb_act_abort_
-  integer(psb_ipk_), save            :: debug_level=0, debug_unit, serial_debug_level=0
+  integer(psb_ipk_), save   :: debug_level     = 0, debug_unit, serial_debug_level=0
 
 contains
 
@@ -164,6 +199,30 @@ contains
     err_action=err_act
   end subroutine psb_set_erraction
 
+  ! sets the action to take upon error occurrence
+  subroutine psb_set_erract_return()
+    err_action  = psb_act_ret_
+  end subroutine psb_set_erract_return
+  subroutine psb_set_erract_print()
+    err_action  = psb_act_print_
+  end subroutine psb_set_erract_print
+  subroutine psb_set_erract_abort()
+    err_action  = psb_act_abort_
+  end subroutine psb_set_erract_abort
+
+  function psb_is_erract_return() result(res)
+    logical :: res
+    res = (err_action == psb_act_ret_)
+  end function psb_is_erract_return
+  function psb_is_erract_print() result(res)
+    logical :: res
+    res = (err_action == psb_act_print_)
+  end function psb_is_erract_print
+  function psb_is_erract_abort() result(res)
+    logical :: res
+    res = (err_action == psb_act_abort_)
+  end function psb_is_erract_abort
+
 
   ! restores error action previously saved with psb_erractionsave
   subroutine psb_erractionrestore(err_act)
@@ -328,6 +387,32 @@ contains
   end subroutine psb_warning_push
 
 
+  ! pops an error from the error stack
+  subroutine psb_ach_errpop(achmsg)
+    character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:)
+    integer(psb_ipk_)        ::  err_c
+    character(len=20)        ::  r_name
+    character(len=40)        ::  a_e_d
+    integer(psb_ipk_)        ::  i_e_d(5)
+
+    type(psb_errstack_node), pointer     ::  old_node
+
+    if (error_stack%n_elems > 0) then 
+      err_c      =  error_stack%top%err_code
+      r_name     =  error_stack%top%routine
+      i_e_d      =  error_stack%top%i_err_data
+      a_e_d      =  error_stack%top%a_err_data
+      call psb_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d)
+      old_node   => error_stack%top
+      error_stack%top  => old_node%next
+      error_stack%n_elems = error_stack%n_elems - 1
+      deallocate(old_node)
+    end if
+    if (error_stack%n_elems == 0) error_status=0
+      
+
+  end subroutine psb_ach_errpop
+
   ! pops an error from the error stack
   subroutine psb_errpop(err_c, r_name, i_e_d, a_e_d)
 
@@ -349,7 +434,7 @@ contains
       error_stack%n_elems = error_stack%n_elems - 1
       deallocate(old_node)
     end if
-    if (error_stack%n_elems == 0) error_status=0
+    if (error_stack%n_elems == 0) error_status=psb_no_err_
       
 
   end subroutine psb_errpop
@@ -369,299 +454,591 @@ contains
     
   end subroutine psb_clean_errstack
 
-
   ! prints the error msg associated to a specific error code
-  subroutine psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
+  subroutine psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me)
 
+    character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:)
     integer(psb_ipk_), intent(in)    ::  err_c
     character(len=20), intent(in)    ::  r_name
     character(len=40), intent(in)    ::  a_e_d
     integer(psb_ipk_), intent(in)    ::  i_e_d(5)
     integer(psb_mpik_), optional     ::  me
 
+    character(len=psb_max_errmsg_len_) :: tmpmsg
+  
+    
+    
     if(present(me)) then
-      write(psb_err_unit,&
+      write(tmpmsg,&
            & '("Process: ",i0,".  PSBLAS Error (",i0,") in subroutine: ",a20)')&
            & me,err_c,trim(r_name)
     else
-      write(psb_err_unit,'("PSBLAS Error (",i0,") in subroutine: ",a)')&
+      write(tmpmsg,'("PSBLAS Error (",i0,") in subroutine: ",a)')&
            & err_c,trim(r_name)
     end if
 
     
     select case (err_c)
     case(:psb_success_)
-      write(psb_err_unit,'("error on calling sperror. err_c must be greater than 0")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("error on calling perror. err_c must be greater than 0")')
+      
     case(psb_err_pivot_too_small_)
-      write(psb_err_unit,'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d)
+
     case(psb_err_invalid_ovr_num_)
-      write(psb_err_unit,'("Invalid number of ovr:",i0)')i_e_d(1)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid number of ovr:",i0)')i_e_d(1)
+
     case(psb_err_invalid_input_)
-      write(psb_err_unit,'("Invalid input")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid input")')
 
     case(psb_err_iarg_neg_)
-      write(psb_err_unit,'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
+      write(achmsg(3),'("current value is ",i0)')i_e_d(2)
 
     case(psb_err_iarg_pos_)
-      write(psb_err_unit,'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
+      write(achmsg(3),'("current value is ",i0)')i_e_d(2)
+
     case(psb_err_input_value_invalid_i_)
-      write(psb_err_unit,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
+      write(achmsg(3),'("current value is ",i0)')i_e_d(2)
+
     case(psb_err_input_asize_invalid_i_)
-      write(psb_err_unit,'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("Current value is ",i0)')i_e_d(2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
+      write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
+
     case(psb_err_input_asize_small_i_)
-      write(psb_err_unit,'("Size of input array argument n. ",i0," is too small.")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')i_e_d(1)
+      write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3)
+
     case(psb_err_iarg_invalid_i_)
-      write(psb_err_unit,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("current value is ",a)')a_e_d(2:2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
+      write(achmsg(3),'("current value is ",a)')a_e_d(2:2)
+
     case(psb_err_iarg_not_gtia_ii_)
-      write(psb_err_unit,&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') &
            & i_e_d(1), i_e_d(3)
-      write(psb_err_unit,'("current values are ",i0," < ",i0)')&
+      write(achmsg(3),'("current values are ",i0," < ",i0)')&
            & i_e_d(2),i_e_d(5)
+
     case(psb_err_iarg_not_gteia_ii_)
-      write(psb_err_unit,'("input argument n. ",i0," must be greater than or equal to ",i0)')&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," must be greater than or equal to ",i0)')&
            & i_e_d(1),i_e_d(2)
-      write(psb_err_unit,'("current value is ",i0," < ",i0)')&
+      write(achmsg(3),'("current value is ",i0," < ",i0)')&
            & i_e_d(3), i_e_d(2)
+
     case(psb_err_iarg_invalid_value_)
-      write(psb_err_unit,'("input argument n. ",i0," in entry # ",i0," has an invalid value")')&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," in entry # ",i0," has an invalid value")')&
            & i_e_d(1:2)
-      write(psb_err_unit,'("current value is ",a)')trim(a_e_d)
+      write(achmsg(3),'("current value is ",a)')trim(a_e_d)
+
     case(psb_err_asb_nrc_error_)
-      write(psb_err_unit,'("Impossible error in ASB: nrow>ncol,")')
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Impossible error in ASB: nrow>ncol,")')
+      write(achmsg(3),'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
       !        ... csr format error ...
+
     case(psb_err_iarg2_neg_)
-      write(psb_err_unit,'("input argument ia2(1) is less than 0")')
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("current value is ",i0)')i_e_d(1)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument ia2(1) is less than 0")')
+      write(achmsg(3),'("current value is ",i0)')i_e_d(1)
       !        ... csr format error ...
+
     case(psb_err_ia2_not_increasing_)
-      write(psb_err_unit,'("indices in ia2 array are not in  increasing order")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("indices in ia2 array are not in  increasing order")')
+
     case(psb_err_ia1_not_increasing_)
-      write(psb_err_unit,'("indices in ia1 array are not in increasing order")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("indices in ia1 array are not in increasing order")')
       !        ... csr format error ...
+
     case(psb_err_ia1_badindices_)
-      write(psb_err_unit,'("indices in ia1 array are not within problem dimension")')
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("problem dimension is ",i0)')i_e_d(1)
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("indices in ia1 array are not within problem dimension")')
+      write(achmsg(3),'("problem dimension is ",i0)')i_e_d(1)
+
     case(psb_err_invalid_args_combination_)
-      write(psb_err_unit,'("invalid combination of input arguments")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("invalid combination of input arguments")')
+
     case(psb_err_invalid_pid_arg_)
-      write(psb_err_unit,'("Invalid process identifier in input array argument n. ",i0,".")')&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')&
            & i_e_d(1)
-      write(psb_err_unit,'("Current value is ",i0)')i_e_d(2)
+      write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
+
     case(psb_err_iarg_n_mbgtian_)
-      write(psb_err_unit,'("input argument n. ",i0," must be greater than input argument n. ",i0)')&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," must be greater than input argument n. ",i0)')&
            & i_e_d(1:2)
-      write(psb_err_unit,'("current values are ",i0," < ",i0)') i_e_d(3:4)
+      write(achmsg(3),'("current values are ",i0," < ",i0)') i_e_d(3:4)
+
     case(psb_err_dupl_cd_vl)
-      write(psb_err_unit,'("there are duplicated entries in vl (input to cdall)")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("there are duplicated entries in vl (input to cdall)")')
       !        ... coo format error ...
       !        ... coo format error ...
+
     case(psb_err_duplicate_coo)
-      write(psb_err_unit,'("there are duplicated elements in coo format")')
+      allocate(achmsg(3)) 
-      write(psb_err_unit,'("and you have chosen psb_dupl_err_ ")')
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("there are duplicated elements in coo format")')
+      write(achmsg(3),'("and you have chosen psb_dupl_err_ ")')
+
     case(psb_err_invalid_input_format_)
-      write(psb_err_unit,'("Invalid input format ",a3)')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid input format ",a3)')&
            & a_e_d(1:3)
+
     case(psb_err_unsupported_format_)
-      write(psb_err_unit,'("Format ",a3," not yet supported here")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Format ",a3," not yet supported here")')&
            &a_e_d(1:3)
+
     case(psb_err_format_unknown_)
-      write(psb_err_unit,'("Format ",a3," is unknown")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Format ",a3," is unknown")')&
            & a_e_d(1:3)
+
     case(psb_err_iarray_outside_bounds_)
-      write(psb_err_unit,'("indices in input array are not within problem dimension ",2(i0,2x))')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("indices in input array are not within problem dimension ",2(i0,2x))')&
            &i_e_d(1:2)
+
     case(psb_err_iarray_outside_process_)
-      write(psb_err_unit,'("indices in input array are not belonging to the calling process ",i0)')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("indices in input array are not belonging to the calling process ",i0)')&
            & i_e_d(1)
+
     case(psb_err_forgot_geall_)
-      write(psb_err_unit,'("To call this routine you must first call psb_geall on the same matrix")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("To call this routine you must first call psb_geall on the same matrix")')
+
     case(psb_err_forgot_spall_)
-      write(psb_err_unit,'("To call this routine you must first call psb_spall on the same matrix")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("To call this routine you must first call psb_spall on the same matrix")')
+
     case(psb_err_wrong_ins_)
-      write(0,'("Something went wrong before this call to ",a,", probably in cdins/spins")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("Something went wrong before this call to ",a,", probably in cdins/spins")')&
            & trim(r_name)
+
     case(psb_err_iarg_mbeeiarra_i_)
-      write(psb_err_unit,&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') &
            & i_e_d(1),i_e_d(4),i_e_d(3)
-      write(psb_err_unit,'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
+      write(achmsg(3),'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
+
     case(psb_err_mpi_error_)
-      write(psb_err_unit,'("MPI error:",i0)')i_e_d(1)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("MPI error:",i0)')i_e_d(1)
+
     case(psb_err_parm_differs_among_procs_)
-      write(psb_err_unit,'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1)
+
     case(psb_err_entry_out_of_bounds_)
-      write(psb_err_unit,'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')&
            & i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2)
+
     case(psb_err_inconsistent_index_lists_)
-      write(psb_err_unit,'("Index lists are inconsistent: some indices are orphans")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Index lists are inconsistent: some indices are orphans")')
+
     case(psb_err_partfunc_toomuchprocs_)
-      write(psb_err_unit,&
+      allocate(achmsg(4)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            &'("partition function passed as input argument n. ",i0," returns number of processes")')&
            &i_e_d(1)
-      write(psb_err_unit,&
+      write(achmsg(3),&
            & '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')&
            &i_e_d(4)
-      write(psb_err_unit,'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
+      write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
+
     case(psb_err_partfunc_toofewprocs_)
-      write(psb_err_unit,'("partition function passed as input argument n. ",i0," returns number of processes")')&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("partition function passed as input argument n. ",i0," returns number of processes")')&
            &i_e_d(1)
-      write(psb_err_unit,'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')&
+      write(achmsg(3),&
+           &'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')&
            &i_e_d(3),i_e_d(2)
+
     case(psb_err_partfunc_wrong_pid_)
-      write(psb_err_unit,&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            &'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')&
            & i_e_d(1)
-      write(psb_err_unit,'("on global point ",i0,". Current value returned is : ",i0)')&
+      write(achmsg(3),&
+           & '("on global point ",i0,". Current value returned is : ",i0)')&
            & i_e_d(3),i_e_d(2)
+
     case(psb_err_no_optional_arg_)
-      write(psb_err_unit,'("One of the optional arguments  ",a," must be present")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
+           &'("One of the optional arguments  ",a," must be present")')&
            & trim(a_e_d)
+
     case(psb_err_arg_m_required_)
-      write(psb_err_unit,'("Argument M is required when argument PARTS is specified")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Argument M is required when argument PARTS is specified")')
+
     case(psb_err_spmat_invalid_state_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Sparse Matrix and descriptors are in an invalid state for this subroutine call: ",i0)')&
            &i_e_d(1)
+
     case(psb_err_missing_override_method_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Base class method ",a," called: the class for ",a," is missing an overriding implementation")')&
            &  trim(r_name), trim(a_e_d)
+
     case(psb_err_invalid_dynamic_type_)
-      write(psb_err_unit,'("input argument n. ",i0," has a dynamic type not allowed here.")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')&
            & i_e_d(1)
-    case (psb_err_rectangular_mat_unsupported_)
+    case(psb_err_rectangular_mat_unsupported_)
-      write(psb_err_unit,&
+      write(achmsg(2),&
            &'("This routine does not support rectangular matrices: ",i0, " /= ",i0)') &
            & i_e_d(1), i_e_d(2)
-    case (psb_err_invalid_mat_state_)
+
-      write(psb_err_unit,'("Invalid state for sparse matrix")')
+    case(psb_err_invalid_mat_state_)
-    case (psb_err_invalid_cd_state_)
+      allocate(achmsg(2)) 
-      write(psb_err_unit,'("Invalid state for communication descriptor")')
+      achmsg(1) = tmpmsg
-    case (psb_err_invalid_a_and_cd_state_)
+      write(achmsg(2),'("Invalid state for sparse matrix")')
-      write(psb_err_unit,'("Invalid combined state for A and DESC_A")')
+
-    case (psb_err_invalid_vect_state_)
+    case(psb_err_invalid_cd_state_)
-      write(psb_err_unit,'("Invalid state for vector")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid state for communication descriptor")')
+
+    case(psb_err_invalid_a_and_cd_state_)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid combined state for A and DESC_A")')
+
+    case(psb_err_invalid_vect_state_)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid state for vector")')
+
     case(1125:1999)
-      write(psb_err_unit,'("computational error. code: ",i0)')err_c
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("computational error. code: ",i0)')err_c
+
     case(psb_err_context_error_)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
       write(0,'("Parallel context error. Number of processes=-1")')
+
     case(psb_err_initerror_neugh_procs_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Initialization error: not enough processes available in the parallel environment")')
+
     case(psb_err_invalid_matrix_input_state_)
-      write(psb_err_unit,'("Invalid input state for matrix.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid input state for matrix.")')
+
     case(psb_err_input_no_regen_)
-      write(psb_err_unit,'("Input state for matrix is not adequate for regeneration.")')
+      allocate(achmsg(2)) 
-    case (2233:2999)
+      achmsg(1) = tmpmsg
-      write(psb_err_unit,'("resource error. code: ",i0)')err_c
+      write(achmsg(2),'("Input state for matrix is not adequate for regeneration.")')
+
+    case(2233:2999)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("resource error. code: ",i0)')err_c
+
     case(3000:3009)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("sparse matrix representation ",a3," not yet implemented")')&
            &a_e_d(1:3)
+
     case(psb_err_lld_case_not_implemented_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            &'("Case lld not equal matrix_data[N_COL_] is not yet implemented.")')
+
     case(psb_err_transpose_unsupported_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("transpose option for sparse matrix representation ",a3," not implemented")')&
            & a_e_d(1:3)
+
     case(psb_err_transpose_c_unsupported_)
-      write(psb_err_unit,'("Case trans = C is not yet implemented.")') 
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case trans = C is not yet implemented.")') 
+
     case(psb_err_transpose_not_n_unsupported_)
-      write(psb_err_unit,'("Case trans /= N is not yet implemented.")') 
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case trans /= N is not yet implemented.")') 
+
     case(psb_err_only_unit_diag_)
-      write(psb_err_unit,'("Only unit diagonal so far for triangular matrices. ")') 
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Only unit diagonal so far for triangular matrices. ")') 
+
     case(3023)
-      write(psb_err_unit,'("Cases DESCRA(1:1)=S  DESCRA(1:1)=T not yet implemented. ")') 
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Cases DESCRA(1:1)=S  DESCRA(1:1)=T not yet implemented. ")') 
+
     case(3024)
-      write(psb_err_unit,'("Cases DESCRA(1:1)=G not yet implemented. ")') 
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Cases DESCRA(1:1)=G not yet implemented. ")') 
+
     case(psb_err_ja_nix_ia_niy_unsupported_)
-      write(psb_err_unit,'("Case ja /= ix or ia/=iy is not yet implemented.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case ja /= ix or ia/=iy is not yet implemented.")')
+
     case(psb_err_ix_n1_iy_n1_unsupported_)
-      write(psb_err_unit,'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
+
     case(3050)
-      write(psb_err_unit,'("Case ix /= iy is not yet implemented.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case ix /= iy is not yet implemented.")')
+
     case(3060)
-      write(psb_err_unit,'("Case ix /= 1 is not yet implemented.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Case ix /= 1 is not yet implemented.")')
+
     case(3070)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("This operation is only implemented with no overlap.")')
+
     case(3080)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Decompostion type ",i0," not yet supported.")')&
            & i_e_d(1)
+
     case(3090)
-      write(psb_err_unit,'("Insert matrix mode not yet implemented.")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Insert matrix mode not yet implemented.")')
+
     case(3100)
-      write(psb_err_unit,&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Error on index. Element has not been inserted")')
-      write(psb_err_unit,&
+      write(achmsg(3),&
            & '("local index is: ",i0," and global index is:",i0)')&
            & i_e_d(1:2)
+
     case(psb_err_input_matrix_unassembled_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            &'("Before you call this routine, you must assembly sparse matrix")')
+
     case(3111)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Before you call this routine, you must initialize the preconditioner")')
+
     case(3112)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Before you call this routine, you must build the preconditioner")')
+
     case(3113:3998)
-      write(psb_err_unit,'("miscellaneus error. code: ",i0)')err_c
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("miscellaneus error. code: ",i0)')err_c
+
     case(psb_err_missing_aux_lib_)
-      write(psb_err_unit,&
+      allocate(achmsg(3)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            &'("This method requires an external support library.")')
-      write(psb_err_unit,&
+      write(achmsg(3),&
            &'("Fix configure and rebuild the software.")')
+
     case(psb_err_alloc_dealloc_)
-      write(psb_err_unit,'("Allocation/deallocation error")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Allocation/deallocation error")')
+
     case(psb_err_internal_error_)
-      write(psb_err_unit,'("Internal error: ",a)') &
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Internal error: ",a)') &
            & trim(a_e_d)
+
     case(psb_err_from_subroutine_)
-      write(psb_err_unit,'("Error from call to subroutine ",a)')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Error from call to subroutine ",a)')&
            & trim(a_e_d)
+
     case(psb_err_from_subroutine_non_)
-      write(psb_err_unit,'("Error from call to a subroutine ")')
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Error from call to a subroutine ")')
+
     case(psb_err_from_subroutine_i_)
-      write(psb_err_unit,'("Error ",i0," from call to a subroutine ")')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Error ",i0," from call to a subroutine ")')&
            & i_e_d(1)
+
     case(psb_err_from_subroutine_ai_)
-      write(psb_err_unit,'("Error from call to subroutine ",a," ",i0)')&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Error from call to subroutine ",a," ",i0)')&
            & trim(a_e_d),i_e_d(1)
+
     case(psb_err_alloc_request_)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Error on allocation request for ",i0," items of type ",a)')&
            & i_e_d(1),trim(a_e_d)
+
     case(4110)
-      write(psb_err_unit,&
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),&
            & '("Error ",i0," from call to an external package in subroutine ",a)')&
            &i_e_d(1),trim(a_e_d)
-    case (psb_err_invalid_istop_)
+
-      write(psb_err_unit,'("Invalid ISTOP: ",i0)')i_e_d(1)
+    case(psb_err_invalid_istop_)
-    case (5002)
+      allocate(achmsg(2)) 
-      write(psb_err_unit,'("Invalid PREC: ",i0)')i_e_d(1)
+      achmsg(1) = tmpmsg
-    case (5003)
+      write(achmsg(2),'("Invalid ISTOP: ",i0)')i_e_d(1)
-      write(psb_err_unit,'("Invalid PREC: ",a3)')a_e_d(1:3)
+
+    case(5002)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid PREC: ",i0)')i_e_d(1)
+
+    case(5003)
+      allocate(achmsg(2)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("Invalid PREC: ",a3)')a_e_d(1:3)
+
     case default
-      write(psb_err_unit,'("unknown error (",i0,") in subroutine ",a)')&
+      allocate(achmsg(4)) 
+      achmsg(1) = tmpmsg
+      write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')&
            & err_c,trim(r_name)
-      write(psb_err_unit,'(5(i0,2x))') i_e_d
+      write(achmsg(3),'(5(i0,2x))') i_e_d
-      write(psb_err_unit,'(a)') trim(a_e_d)
+      write(achmsg(4),'(a)') trim(a_e_d)
 
     end select
 
-  end subroutine psb_errmsg
+  end subroutine psb_ach_errmsg
+
+
+  ! prints the error msg associated to a specific error code
+  subroutine psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
+
+    integer(psb_ipk_), intent(in)    ::  err_c
+    character(len=20), intent(in)    ::  r_name
+    character(len=40), intent(in)    ::  a_e_d
+    integer(psb_ipk_), intent(in)    ::  i_e_d(5)
+    integer(psb_mpik_), optional     ::  me
 
+    integer(psb_ipk_) :: i
+    character(len=psb_max_errmsg_len_), allocatable :: achmsg(:)
 
+    call psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me)
+    
+    do i=1,size(achmsg)
+      write(psb_err_unit,'(a)'),trim(achmsg(i))
+    end do
+
+  end subroutine psb_errmsg
 
 end module psb_error_mod

test/pargen/runs/ppde.inp

@@ -2,7 +2,7 @@
 BICGSTAB               Iterative method BICGSTAB CGS  BICG BICGSTABL RGMRES
 BJAC                   Preconditioner NONE  DIAG  BJAC 
 CSR                    Storage format for matrix A:  CSR COO JAD 
-160                    Domain size (acutal system is this**3)
+100                    Domain size (acutal system is this**3)
 2                      Stopping criterion
 1000                   MAXIT
 -1                     ITRACE