Merged new serial code.

Changelog

@@ -1,6 +1,12 @@
 Changelog. A lot less detailed than usual, at least for past
 history. 
 
+2007/09/14: Second round of serial changes: merged into trunk, fixed
+	    JAD regeneration and srch_upd now works.           
+
+2007/09/10: First round of serial changes: implemented serial
+	    psb_spcnv unifying multiple functionalities.
+
 2007/09/04: Implemented RGMRES for complex data.
 
 2007/06/04: Fixed implementation of fctint and coins: assume size

base/modules/psb_serial_mod.f90

@@ -140,10 +140,45 @@ module psb_serial_mod
     subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
       integer, intent(in) ::  m,n,nnz,iup
       integer, intent(out) :: lia1, lia2, lar, info
-      character, intent(inout) :: afmt*5
+      character(len=*), intent(inout) :: afmt
     end subroutine psb_cest
   end interface
 
+  interface psb_spcnv
+    subroutine psb_dspcnv2(ain, a, info, afmt, upd, dupl)
+      use psb_spmat_type
+      type(psb_dspmat_type), intent (in)     :: ain
+      type(psb_dspmat_type), intent (out)    :: a
+      integer, intent(out)                   :: info
+      integer,optional, intent(in)           :: dupl, upd
+      character(len=*), optional, intent(in) :: afmt
+    end subroutine psb_dspcnv2
+    subroutine psb_dspcnv1(a, info, afmt, upd, dupl)
+      use psb_spmat_type
+      type(psb_dspmat_type), intent (inout)   :: a
+      integer, intent(out)                    :: info
+      integer,optional, intent(in)            :: dupl, upd
+      character(len=*), optional, intent(in)  :: afmt
+    end subroutine psb_dspcnv1
+    subroutine psb_zspcnv2(ain, a, info, afmt, upd, dupl)
+      use psb_spmat_type
+      type(psb_zspmat_type), intent (in)     :: ain
+      type(psb_zspmat_type), intent (out)    :: a
+      integer, intent(out)                   :: info
+      integer,optional, intent(in)           :: dupl, upd
+      character(len=*), optional, intent(in) :: afmt
+    end subroutine psb_zspcnv2
+    subroutine psb_zspcnv1(a, info, afmt, upd, dupl)
+      use psb_spmat_type
+      type(psb_zspmat_type), intent (inout)   :: a
+      integer, intent(out)                    :: info
+      integer,optional, intent(in)            :: dupl, upd
+      character(len=*), optional, intent(in)  :: afmt
+    end subroutine psb_zspcnv1
+  end interface
+
+
+
   interface psb_fixcoo
     subroutine psb_dfixcoo(a,info,idir)
       use psb_spmat_type
@@ -466,10 +501,13 @@ module psb_serial_mod
     module procedure imsort_u
   end interface
   interface psb_qsort
-    module procedure iqsort
+    module procedure iqsort, dqsort, zqsort
   end interface
 
   integer, parameter :: psb_sort_up_=1,  psb_sort_down_=-1
+  integer, parameter :: psb_lsort_up_=2, psb_lsort_down_=-2
+  integer, parameter :: psb_asort_up_=3, psb_asort_down_=-3
+  integer, parameter :: psb_alsort_up_=4, psb_alsort_down_=-4
   integer, parameter :: psb_sort_ovw_idx_=0, psb_sort_keep_idx_=1
 
 contains
@@ -587,26 +625,158 @@ contains
     name='psb_qsort'
     call psb_erractionsave(err_act)
 
+    if (present(flag)) then 
+      flag_ = flag
+    else 
+      flag_ = psb_sort_ovw_idx_
+    end if
+    select case(flag_) 
+    case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
+      ! OK keep going
+    case default
+      call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
+      goto 9999
+    end select
+    
     if (present(dir)) then 
       dir_ = dir
     else
       dir_= psb_sort_up_
     end if
+
+    n = size(x)
+
     select case(dir_) 
     case( psb_sort_up_, psb_sort_down_)
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call isrx(n,x,ix,dir_,flag_)
+      else
+        call isr(n,x,dir_)
+      end if
+      
+    case( psb_asort_up_, psb_asort_down_)
       ! OK keep going
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call iasrx(n,x,ix,dir_,flag_)
+      else
+        call iasr(n,x,dir_)
+      end if
+      
     case default
       call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
       goto 9999
     end select
       
+    
+
+9999 continue 
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+  end subroutine iqsort
+
+
+  subroutine dqsort(x,ix,dir,flag)
+    use psb_error_mod
+    implicit none 
+    real(kind(1.d0)), intent(inout)  :: x(:) 
+    integer, optional, intent(in)    :: dir, flag
+    integer, optional, intent(inout) :: ix(:)
+    
+    integer  :: dir_, flag_, n, err_act
+    
+    character(len=20)  :: name
+
+    name='psb_qsort'
+    call psb_erractionsave(err_act)
+
+    if (present(flag)) then 
+      flag_ = flag
+    else 
+      flag_ = psb_sort_ovw_idx_
+    end if
+    select case(flag_) 
+    case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
+      ! OK keep going
+    case default
+      call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
+      goto 9999
+    end select
+    
+    if (present(dir)) then 
+      dir_ = dir
+    else
+      dir_= psb_sort_up_
+    end if
+
     n = size(x)
 
+    select case(dir_) 
+    case( psb_sort_up_, psb_sort_down_)
       if (present(ix)) then 
         if (size(ix) < n) then 
           call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
           goto 9999
         end if
+        
+        call dsrx(n,x,ix,dir_,flag_)
+      else
+        call dsr(n,x,dir_)
+      end if
+      
+    case( psb_asort_up_, psb_asort_down_)
+      ! OK keep going
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call dasrx(n,x,ix,dir_,flag_)
+      else
+        call dasr(n,x,dir_)
+      end if
+      
+    case default
+      call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
+      goto 9999
+    end select
+      
+    
+
+9999 continue 
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+  end subroutine dqsort
+
+
+  subroutine zqsort(x,ix,dir,flag)
+    use psb_error_mod
+    implicit none 
+    complex(kind(1.d0)), intent(inout)  :: x(:) 
+    integer, optional, intent(in)    :: dir, flag
+    integer, optional, intent(inout) :: ix(:)
+    
+    integer  :: dir_, flag_, n, err_act
+    
+    character(len=20)  :: name
+
+    name='psb_qsort'
+    call psb_erractionsave(err_act)
+
     if (present(flag)) then 
       flag_ = flag
     else 
@@ -620,19 +790,66 @@ contains
       goto 9999
     end select
     
-      call isrx(n,x,ix,dir_,flag_)
+    if (present(dir)) then 
+      dir_ = dir
     else
-      call isr(n,x,dir_)
+      dir_= psb_lsort_up_
+    end if
+
+    n = size(x)
+
+    select case(dir_) 
+    case( psb_lsort_up_, psb_lsort_down_)
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call zlsrx(n,x,ix,dir_,flag_)
+      else
+        call zlsr(n,x,dir_)
+      end if
+      
+    case( psb_alsort_up_, psb_alsort_down_)
+      ! OK keep going
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call zalsrx(n,x,ix,dir_,flag_)
+      else
+        call zalsr(n,x,dir_)
+      end if
+
+    case( psb_asort_up_, psb_asort_down_)
+      ! OK keep going
+      if (present(ix)) then 
+        if (size(ix) < n) then 
+          call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
+          goto 9999
+        end if
+        
+        call zasrx(n,x,ix,dir_,flag_)
+      else
+        call zasr(n,x,dir_)
       end if
       
+    case default
+      call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
+      goto 9999
+    end select
+      
+    
+
 9999 continue 
     if (err_act.eq.psb_act_abort_) then
       call psb_error()
       return
     end if
-  end subroutine iqsort
+  end subroutine zqsort
-
-
 
 end module psb_serial_mod
 

base/modules/psb_spmat_type.f90

@@ -48,25 +48,55 @@ module psb_spmat_type
   !
   !     Entries and values for  spmat%info
   !     
-
   integer, parameter :: psb_nnz_=1
   integer, parameter :: psb_del_bnd_=7, psb_srtd_=8
   integer, parameter :: psb_state_=9
   integer, parameter :: psb_upd_pnt_=10
   integer, parameter :: psb_dupl_=11,  psb_upd_=12
   integer, parameter :: psb_ifasize_=16
+  !
+  !
+  ! Possible matrix states.
+  !
+  ! A sparse matrix can move between states according to the 
+  ! following state transition table. 
+  ! In           Out        Routine
+  ! ----------------------------------
+  ! Null         Build      psb_sp_all
+  ! Build        Build      psb_coins
+  ! Build        Assembeld  psb_spcnv
+  ! Assembled    Assembled  psb_spcnv
+  ! Assembled    Update     psb_sp_reinit
+  ! Update       Update     psb_coins
+  ! Update       Assembled  psb_spcnv
+  ! *            unchanged  psb_sp_reall 
+  ! Assembled    Null       psb_sp_free
+  ! 
+  ! Note that psb_spcnv is overloaded in two flavours,
+  ! psb_spcnv(a,info)   
+  ! psb_spcnv(a,b,info)
+  ! in the second variant, the IN state applies to A and 
+  ! the OUT state applies to B.
+  ! 
+  !  
   integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
   integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
+  
   integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
   integer, parameter :: psb_iflag_=2, psb_ichk_=3
   integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
+  ! Duplicate coefficients handling
+  ! These are usually set while calling spcnv as one of its
+  ! optional arugments.
   integer, parameter :: psb_dupl_ovwrt_ = 0
   integer, parameter :: psb_dupl_add_   = 1
   integer, parameter :: psb_dupl_err_   = 2
   integer, parameter :: psb_dupl_def_   = psb_dupl_ovwrt_
-  integer, parameter :: psb_upd_dflt_   = 0
+  ! Matrix update mode
   integer, parameter :: psb_upd_srch_   = 98764
   integer, parameter :: psb_upd_perm_   = 98765
+  integer, parameter :: psb_upd_dflt_   = psb_upd_srch_
+  ! Mark a COO matrix with sorted entries.
   integer, parameter :: psb_isrtdcoo_   = 98761
   integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
   integer, parameter :: psb_dbleint_=2
@@ -379,6 +409,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     a%m        = 0
     a%k        = 0
     if (debug) write(0,*) 'SPALL : end'
@@ -412,6 +443,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     if (debug) write(0,*) 'SPALL : end'
     Return
 
@@ -445,6 +477,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     if (debug) write(0,*) 'spall : end'
     return
 
@@ -471,6 +504,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     a%m      = 0
     a%k      = 0
     if (debug) write(0,*) 'SPALL : end'
@@ -718,18 +752,18 @@ contains
       ia = size(a%aspk)
       return
     endif
-    select case(toupper(a%fida))
+    select case(tolower(a%fida))
-    case('CSR')
+    case('csr')
       nza = a%ia2(a%m+1)-1
       ia  = nza
       i1  = nza
       i2  = a%m + 1
-    case('COO')
+    case('coo','coi')
       nza = a%infoa(psb_nnz_)
       i1  = nza
       i2  = nza
       ia  = nza
-    case('JAD')
+    case('jad')
       ! Feeling lazy today
       i1 = size(a%ia1)
       i2 = size(a%ia2)
@@ -936,6 +970,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     a%m      = 0
     a%k      = 0
     if (debug) write(0,*) 'SPALL : end'
@@ -969,6 +1004,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     if (debug) write(0,*) 'SPALL : end'
     Return
 
@@ -1002,6 +1038,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_
     if (debug) write(0,*) 'spall : end'
     return
 
@@ -1029,6 +1066,7 @@ contains
     a%fida   = 'COO'
     a%descra = 'GUN'
     a%infoa(:) = 0
+    a%infoa(psb_state_) = psb_spmat_bld_    
     a%m      = 0
     a%k      = 0
     if (debug) write(0,*) 'SPALL : end'
@@ -1222,18 +1260,18 @@ contains
       ia = size(a%aspk)
       return
     endif
-    select case(toupper(a%fida))
+    select case(tolower(a%fida))
-    case('CSR')
+    case('csr')
       nza = a%ia2(a%m+1)-1
       ia  = nza
       i1  = nza
       i2  = a%m + 1
-    case('COO')
+    case('coo','coi')
       nza = a%infoa(psb_nnz_)
       i1  = nza
       i2  = nza
       ia  = nza
-    case('JAD')
+    case('jad')
       ! Feeling lazy today
       i1 = size(a%ia1)
       i2 = size(a%ia2)

base/modules/psb_tools_mod.f90

@@ -31,6 +31,7 @@
 Module psb_tools_mod
   use psb_const_mod
   use psb_gps_mod
+  use psb_spmat_type
 
   interface  psb_geall
     ! 2-D double precision version
@@ -447,7 +448,7 @@ Module psb_tools_mod
       type(psb_desc_type), intent(in)         :: desc_a
       integer, intent(out)                    :: info
       integer,optional, intent(in)            :: dupl, upd
-      character, optional, intent(in)         :: afmt*5
+      character(len=*), optional, intent(in)  :: afmt
     end subroutine psb_dspasb
     subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
       use psb_descriptor_type
@@ -456,32 +457,33 @@ Module psb_tools_mod
       type(psb_desc_type), intent(in)         :: desc_a
       integer, intent(out)                    :: info
       integer,optional, intent(in)            :: dupl, upd
-      character, optional, intent(in)         :: afmt*5
+      character(len=*), optional, intent(in)  :: afmt
     end subroutine psb_zspasb
   end interface
 
 
-  interface psb_spcnv
+!!$  interface psb_spcnv
-    subroutine psb_dspcnv(a,b,desc_a,info)
+!!$    subroutine psb_dspcnv(a,b,desc_a,info)
-      use psb_descriptor_type
+!!$      use psb_descriptor_type
-      use psb_spmat_type
+!!$      use psb_spmat_type
-      type(psb_dspmat_type), intent(in)   :: a
+!!$      type(psb_dspmat_type), intent(in)   :: a
-      type(psb_dspmat_type), intent(out)  :: b
+!!$      type(psb_dspmat_type), intent(out)  :: b
-      type(psb_desc_type), intent(in)     :: desc_a
+!!$      type(psb_desc_type), intent(in)     :: desc_a
-      integer, intent(out)                :: info
+!!$      integer, intent(out)                :: info
-    end subroutine psb_dspcnv
+!!$    end subroutine psb_dspcnv
-    subroutine psb_zspcnv(a,b,desc_a,info)
+!!$    subroutine psb_zspcnv(a,b,desc_a,info)
-      use psb_descriptor_type
+!!$      use psb_descriptor_type
-      use psb_spmat_type
+!!$      use psb_spmat_type
-      type(psb_zspmat_type), intent(in)   :: a
+!!$      type(psb_zspmat_type), intent(in)   :: a
-      type(psb_zspmat_type), intent(out)  :: b
+!!$      type(psb_zspmat_type), intent(out)  :: b
-      type(psb_desc_type), intent(in)     :: desc_a
+!!$      type(psb_desc_type), intent(in)     :: desc_a
-      integer, intent(out)                :: info
+!!$      integer, intent(out)                :: info
-    end subroutine psb_zspcnv
+!!$    end subroutine psb_zspcnv
-  end interface
+!!$  end interface
 
 
   interface psb_spfree
+    module procedure psb_dsp_free, psb_zsp_free
     subroutine psb_dspfree(a, desc_a,info)
       use psb_descriptor_type
       use psb_spmat_type

base/serial/Makefile

@@ -1,14 +1,14 @@
 include ../../Make.inc
 
 
-FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \
+FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \
 	psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \
 	psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \
 	psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtblk.o \
-	psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o\
+	psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o psb_dspcnv.o\
-	psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\
+	psb_regen_mod.o psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\
 	psb_zcsmm.o psb_zcsmv.o  psb_zspgtdiag.o psb_zspgtblk.o\
-	psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\
+	psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zspcnv.o\
 	psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \
 	psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\
 	psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\
@@ -26,7 +26,8 @@ lib: auxd cood csrd jadd f77d dpd lib1
 lib1:	$(FOBJS)
 
 psb_dcoins.o psb_zcoins.o: psb_update_mod.o
-psb_dspgetrow.o: psb_getrow_mod.o
+psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o
+psb_dspcnv.o pzb_zspcnv.o: psb_regen_mod.o
 
 auxd:
 	(cd aux; make lib)

base/serial/aux/Makefile

@@ -3,8 +3,12 @@ include ../../../Make.inc
 # The object files
 #
 
-FOBJS  = isr.o isrx.o msort_up.o msort_dw.o\
+FOBJS  = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\
-	isaperm.o ibsrch.o issrch.o  imsr.o imsrx.o imsru.o
+	isaperm.o ibsrch.o issrch.o  imsr.o imsrx.o imsru.o\
+	dsr.o dsrx.o dasr.o dasrx.o \
+	zlcmp_mod.o zlsr.o zlsrx.o  \
+	zalcmp_mod.o zalsr.o zalsrx.o \
+	zacmp_mod.o zasr.o zasrx.o 
 
 
 OBJS=$(FOBJS)
@@ -26,9 +30,12 @@ default: lib
 lib: $(OBJS)
 	$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
 	$(RANLIB) $(LIBDIR)/$(LIBNAME)
+zlsr.o  zlsrx.o:  zlcmp_mod.o
+zalsr.o zalsrx.o: zalcmp_mod.o
+zasr.o  zasrx.o:  zacmp_mod.o
 
 clean: 
-	/bin/rm -f $(OBJS)
+	/bin/rm -f $(OBJS) *$(.mod)
 
 veryclean: clean
 

base/serial/aux/dasr.f90

@@ -0,0 +1,361 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine dasr(n,x,dir)
+  use psb_serial_mod
+  implicit none
+      !
+  !  Quicksort on absolute value.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  real(kind(1.d0)) ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  real(kind(1.d0)) :: xx, piv, xt, xk
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_asort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv < abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(j))) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call disr_up(n,x)
+    endif
+
+  case(psb_asort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv > abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(j))) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call disr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine disr_up(n,x)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: i,j
+    real(kind(1.d0)) :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) < abs(x(j))) then
+        xx = x(j)
+        xax = abs(xx)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) >= xax) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine disr_up
+
+  subroutine disr_dw(n,x)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: i,j
+    real(kind(1.d0)) :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) > abs(x(j))) then
+        xx = x(j)
+        xax = abs(xx) 
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) <= xax) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine disr_dw
+
+end subroutine dasr

base/serial/aux/dasrx.f90

@@ -0,0 +1,409 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine dasrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  implicit none
+      !
+  !  Quicksort on absolute value with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  real(kind(1.d0)) ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  real(kind(1.d0)) :: xx, piv, xt, xk
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_asort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv < abs(x(i))) then
+          xt   = x(i)
+          ixt  = indx(i)
+          x(i) = x(lpiv)
+          indx(i) = indx(lpiv)
+          x(lpiv) = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(j))) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call idasrx_up(n,x,indx)
+    endif
+
+  case(psb_asort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv > abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(j))) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call idasrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine idasrx_up(n,x,indx)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    real(kind(1.d0)) :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) < abs(x(j))) then
+        xx = x(j)
+        ix = indx(j) 
+        xax = abs(xx)
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) >= xax) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine idasrx_up
+
+  subroutine idasrx_dw(n,x,indx)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    real(kind(1.d0)) :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) > abs(x(j))) then
+        xx = x(j)
+        ix = indx(j) 
+        xax = abs(xx) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) <= xax) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine idasrx_dw
+
+end subroutine dasrx

base/serial/aux/dsr.f90

@@ -0,0 +1,359 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine dsr(n,x,dir)
+  use psb_serial_mod
+  implicit none
+  !
+  !  Quicksort.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  real(kind(1.d0)) ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  real(kind(1.d0)) :: xx, piv, xt, xk
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_sort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call disr_up(n,x)
+    endif
+
+  case(psb_sort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call disr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call disr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call disr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine disr_up(n,x)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: i,j
+    real(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine disr_up
+
+  subroutine disr_dw(n,x)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: i,j
+    real(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine disr_dw
+
+end subroutine dsr

base/serial/aux/dsrx.f90

@@ -0,0 +1,409 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine dsrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  implicit none
+  !
+  !  Quicksort with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  real(kind(1.d0)) ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  real(kind(1.d0)) :: xx, piv, xk, xt
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_sort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call idsrx_up(n,x,indx)
+    endif
+
+  case(psb_sort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call idsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call idsrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine idsrx_up(n,x,indx)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    real(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine idsrx_up
+
+  subroutine idsrx_dw(n,x,indx)
+    implicit none
+    integer :: n
+    real(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    real(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine idsrx_dw
+
+end subroutine dsrx

base/serial/aux/iasr.f90

@@ -0,0 +1,361 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine iasr(n,x,dir)
+  use psb_serial_mod
+  implicit none
+      !
+  !  Quicksort on absolute value.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  integer ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  integer :: xx, piv, xt, xk
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_asort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv < abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(j))) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iaisr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iaisr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iaisr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iaisr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call iaisr_up(n,x)
+    endif
+
+  case(psb_asort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv > abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(j))) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(i))) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iaisr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iaisr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iaisr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iaisr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call iaisr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine iaisr_up(n,x)
+    implicit none
+    integer :: n
+    integer :: x(n)
+    integer :: i,j
+    integer :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) < abs(x(j))) then
+        xx = x(j)
+        xax = abs(xx)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) >= xax) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine iaisr_up
+
+  subroutine iaisr_dw(n,x)
+    implicit none
+    integer :: n
+    integer :: x(n)
+    integer :: i,j
+    integer :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) > abs(x(j))) then
+        xx = x(j)
+        xax = abs(xx) 
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) <= xax) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine iaisr_dw
+
+end subroutine iasr

base/serial/aux/iasrx.f90

@@ -0,0 +1,409 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine iasrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  implicit none
+      !
+  !  Quicksort on absolute value with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  integer ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  integer :: xx, piv, xt, xk
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_asort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv < abs(x(i))) then
+          xt   = x(i)
+          ixt  = indx(i)
+          x(i) = x(lpiv)
+          indx(i) = indx(lpiv)
+          x(lpiv) = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(j))) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iiasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iiasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call iiasrx_up(n,x,indx)
+    endif
+
+  case(psb_asort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = abs(x(lpiv))
+        if (piv > abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv < abs(x(j))) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        if (piv > abs(x(i))) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv = abs(x(lpiv))
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = abs(x(i))
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = x(i)
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = abs(x(j))
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iiasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call iiasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call iiasrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine iiasrx_up(n,x,indx)
+    implicit none
+    integer :: n
+    integer :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    integer :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) < abs(x(j))) then
+        xx = x(j)
+        ix = indx(j) 
+        xax = abs(xx)
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) >= xax) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine iiasrx_up
+
+  subroutine iiasrx_dw(n,x,indx)
+    implicit none
+    integer :: n
+    integer :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    integer :: xx,xax
+
+    do j=n-1,1,-1
+      if (abs(x(j+1)) > abs(x(j))) then
+        xx = x(j)
+        ix = indx(j) 
+        xax = abs(xx) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (abs(x(i)) <= xax) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine iiasrx_dw
+
+end subroutine iasrx

base/serial/aux/zacmp_mod.f90

@@ -0,0 +1,44 @@
+module zacmp_mod
+  interface operator(<)
+    module procedure zalt
+  end interface
+  interface operator(<=)
+    module procedure zale
+  end interface
+  interface operator(>)
+    module procedure zagt
+  end interface
+  interface operator(>=)
+    module procedure zage
+  end interface
+
+contains
+
+  function zalt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zalt
+    
+    zalt = ((abs(real(a))+abs(aimag(a))) < (abs(real(b))+abs(aimag(b))))
+  end function zalt
+  function zale(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zale
+    
+    zale = ((abs(real(a))+abs(aimag(a))) <= (abs(real(b))+abs(aimag(b))))
+  end function zale
+
+  function zagt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zagt
+    
+    zagt = ((abs(real(a))+abs(aimag(a))) > (abs(real(b))+abs(aimag(b))))
+  end function zagt
+  function zage(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zage
+    
+    zage = ((abs(real(a))+abs(aimag(a))) >= (abs(real(b))+abs(aimag(b))))
+  end function zage
+
+end module zacmp_mod
+  

base/serial/aux/zalcmp_mod.f90

@@ -0,0 +1,48 @@
+module zalcmp_mod
+  interface operator(<)
+    module procedure zallt
+  end interface
+  interface operator(<=)
+    module procedure zalle
+  end interface
+  interface operator(>)
+    module procedure zalgt
+  end interface
+  interface operator(>=)
+    module procedure zalge
+  end interface
+
+contains
+
+  function zallt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zallt
+    
+    zallt = (abs(real(a))<abs(real(b))).or. &
+         & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))<abs(aimag(b))))
+  end function zallt
+  function zalle(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zalle
+    
+    zalle = (abs(real(a))<abs(real(b))).or. &
+         & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))<=abs(aimag(b))))
+  end function zalle
+
+  function zalgt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zalgt
+    
+    zalgt = (abs(real(a))>abs(real(b))).or. &
+         & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b))))
+  end function zalgt
+  function zalge(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zalge
+    
+    zalge = (abs(real(a))>abs(real(b))).or. &
+         & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b))))
+  end function zalge
+
+end module zalcmp_mod
+  

base/serial/aux/zalsr.f90

@@ -0,0 +1,362 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine zalsr(n,x,dir)
+  use psb_serial_mod
+  use zalcmp_mod
+  implicit none
+  !
+  !  Quicksort on lexicographic comparison of complex numbers.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  complex(kind(1.d0)) ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, xk, piv, xt
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_alsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izalsr_up(n,x)
+    endif
+
+  case(psb_alsort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izalsr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izalsr_up(n,x)
+    use zalcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izalsr_up
+
+  subroutine izalsr_dw(n,x)
+    use zalcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izalsr_dw
+
+end subroutine zalsr

base/serial/aux/zalsrx.f90

@@ -0,0 +1,413 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine zalsrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  use zalcmp_mod
+  implicit none
+  !
+  !  Quicksort with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  complex(kind(1.d0)) ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, piv, xk, xt
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_alsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izalsrx_up(n,x,indx)
+    endif
+
+  case(psb_alsort_down_) 
+
+
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izalsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izalsrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izalsrx_up(n,x,indx)
+    use zalcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izalsrx_up
+
+  subroutine izalsrx_dw(n,x,indx)
+    use zalcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izalsrx_dw
+
+end subroutine zalsrx

base/serial/aux/zasr.f90

@@ -0,0 +1,362 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine zasr(n,x,dir)
+  use psb_serial_mod
+  use zacmp_mod
+  implicit none
+  !
+  !  Quicksort on lexicographic comparison of complex numbers.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  complex(kind(1.d0)) ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, xk, piv, xt
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_alsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izasr_up(n,x)
+    endif
+
+  case(psb_alsort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izasr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izasr_up(n,x)
+    use zacmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izasr_up
+
+  subroutine izasr_dw(n,x)
+    use zacmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izasr_dw
+
+end subroutine zasr

base/serial/aux/zasrx.f90

@@ -0,0 +1,413 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine zasrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  use zacmp_mod
+  implicit none
+  !
+  !  Quicksort with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  complex(kind(1.d0)) ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, piv, xk, xt
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_alsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izasrx_up(n,x,indx)
+    endif
+
+  case(psb_alsort_down_) 
+
+
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izasrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izasrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izasrx_up(n,x,indx)
+    use zacmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izasrx_up
+
+  subroutine izasrx_dw(n,x,indx)
+    use zacmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izasrx_dw
+
+end subroutine zasrx

base/serial/aux/zlcmp_mod.f90

@@ -0,0 +1,44 @@
+module zlcmp_mod
+  interface operator(<)
+    module procedure zllt
+  end interface
+  interface operator(<=)
+    module procedure zlle
+  end interface
+  interface operator(>)
+    module procedure zlgt
+  end interface
+  interface operator(>=)
+    module procedure zlge
+  end interface
+
+contains
+
+  function zllt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zllt
+    
+    zllt = (real(a)<real(b)).or.((real(a)==real(b)).and.(aimag(a)<aimag(b)))
+  end function zllt
+  function zlle(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zlle
+    
+    zlle = (real(a)<real(b)).or.((real(a)==real(b)).and.(aimag(a)<=aimag(b)))
+  end function zlle
+
+  function zlgt(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zlgt
+    
+    zlgt = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b)))
+  end function zlgt
+  function zlge(a,b)
+    complex(kind(1.d0)), intent(in) :: a,b
+    logical :: zlge
+    
+    zlge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b)))
+  end function zlge
+
+end module zlcmp_mod
+  

base/serial/aux/zlsr.f90

@@ -0,0 +1,362 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+
+subroutine zlsr(n,x,dir)
+  use psb_serial_mod
+  use zlcmp_mod
+  implicit none
+  !
+  !  Quicksort on lexicographic comparison of complex numbers.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir 
+  complex(kind(1.d0)) ::  x(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, xk, piv, xt
+  integer i, j, ilx, iux, istp, lpiv
+  integer n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_lsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsr_up(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsr_up(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsr_up(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsr_up(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izlsr_up(n,x)
+    endif
+
+  case(psb_lsort_down_) 
+   
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt = x(j)
+          x(j) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt = x(i)
+          x(i) = x(lpiv)
+          x(lpiv) = xt
+          piv = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+
+        xt = x(i)
+        x(i) = x(lpiv)
+        x(lpiv) = xt
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt  = x(i)
+            x(i) = x(j)
+            x(j) = xt 
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsr_dw(n1,x(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsr_dw(n2,x(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsr_dw(n2,x(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsr_dw(n1,x(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izlsr_dw(n,x)
+    endif
+
+  case default
+    write(0,*) 'isr error !',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izlsr_up(n,x)
+    use zlcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izlsr_up
+
+  subroutine izlsr_dw(n,x)
+    use zlcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: i,j
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        i=j+1
+        do 
+          x(i-1) = x(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1) = xx
+      endif
+    enddo
+  end subroutine izlsr_dw
+
+end subroutine zlsr

base/serial/aux/zlsrx.f90

@@ -0,0 +1,413 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+subroutine zlsrx(n,x,indx,dir,flag)
+  use psb_serial_mod
+  use zlcmp_mod
+  implicit none
+  !
+  !  Quicksort with indices into original positions.
+  !  Adapted from a number of sources, including Don Knuth's TAOCP.
+  !
+  !     .. Scalar Arguments ..
+  integer, intent(in) :: n, dir, flag
+  complex(kind(1.d0)) ::  x(n)
+  integer ::  indx(n)
+  !     ..
+  !     .. Local Scalars ..
+  complex(kind(1.d0)) :: xx, piv, xk, xt
+  integer i, j, ii, ilx, iux, istp, lpiv
+  integer ixt, n1, n2
+
+  integer, parameter :: maxstack=64,nparms=3,ithrs=16
+  integer            :: istack(nparms,maxstack)
+  !     ..
+
+  select case(flag)
+  case(psb_sort_ovw_idx_)
+    do i=1, n
+      indx(i) = i
+    enddo
+  case(psb_sort_keep_idx_)
+    ! do nothing
+  case default
+    write(0,*) 'Error in isrx: invalid flag',flag
+  end select
+  !
+
+  !
+  !     small inputs will only get through insertion sort. 
+  !
+  select case(dir) 
+
+  case(psb_lsort_up_)
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_up: do
+          in_up1: do
+            i = i + 1
+            xk = x(i)
+            if (xk >= piv) exit in_up1
+          end do in_up1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_up2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk <= piv) exit in_up2
+          end do in_up2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt 
+            indx(j) = ixt  
+          else
+            exit outer_up
+          end if
+        end do outer_up
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsrx_up(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izlsrx_up(n,x,indx)
+    endif
+
+  case(psb_lsort_down_) 
+
+
+
+    if (n > ithrs) then          
+      !
+      !     Init stack pointer
+      !
+      istp = 1
+      istack(1,istp) = 1
+      istack(2,istp) = n
+
+      do 
+        if (istp <= 0) exit
+        ilx  = istack(1,istp)
+        iux  = istack(2,istp)
+        istp = istp - 1
+        !$$$            write(0,*) 'Debug 1: ',ilx,iux
+        !
+        !       Choose a pivot with median-of-three heuristics, leave it 
+        !       in the LPIV location
+        !            
+        i = ilx
+        j = iux 
+        lpiv = (i+j)/2
+        piv  = x(lpiv)
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv < x(j)) then
+          xt        = x(j)
+          ixt        = indx(j)
+          x(j)       = x(lpiv)
+          indx(j)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        if (piv > x(i)) then
+          xt        = x(i)
+          ixt        = indx(i)
+          x(i)       = x(lpiv)
+          indx(i)    = indx(lpiv)
+          x(lpiv)    = xt
+          indx(lpiv) = ixt
+          piv        = x(lpiv)
+        endif
+        !
+        !     now piv is correct;  place it into first location
+        xt        = x(i)
+        ixt        = indx(i)
+        x(i)       = x(lpiv)
+        indx(i)    = indx(lpiv)
+        x(lpiv)    = xt
+        indx(lpiv) = ixt
+        piv        = x(lpiv)
+
+        i = ilx - 1 
+        j = iux + 1 
+
+        outer_dw: do
+          in_dw1: do
+            i = i + 1
+            xk = x(i)
+            if (xk <= piv) exit in_dw1
+          end do in_dw1
+          !
+          !     Ensure finite termination for next loop
+          !
+          xt  = xk
+          x(i) = piv
+          in_dw2:do 
+            j = j - 1
+            xk = x(j)
+            if (xk >= piv) exit in_dw2
+          end do in_dw2
+          x(i) = xt  
+
+          if (j > i) then
+            xt     = x(i)
+            ixt     = indx(i)
+            x(i)    = x(j)
+            indx(i) = indx(j)
+            x(j)    = xt  
+            indx(j) = ixt  
+          else
+            exit outer_dw
+          end if
+        end do outer_dw
+        if (i == ilx) then 
+          if (x(i) /= piv) then
+            write(0,*) 'Should never ever get here????!!!!'
+            stop
+          endif
+          i = i + 1 
+        endif
+
+        n1 = (i-1)-ilx+1
+        n2 = iux-(i)+1
+        if (n1 > n2) then
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+        else
+          if (n2 > ithrs) then
+            istp = istp + 1
+            istack(1,istp) = i
+            istack(2,istp) = iux
+          else
+            call izlsrx_dw(n2,x(i:iux),indx(i:iux))
+          endif
+          if (n1 > ithrs) then 
+            istp = istp + 1
+            istack(1,istp) = ilx
+            istack(2,istp) = i-1
+          else
+            call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
+          endif
+        endif
+      enddo
+    else
+      call izlsrx_dw(n,x,indx)
+    endif
+
+  case default
+    write(0,*) 'isrx error  dir ',dir
+  end select
+
+
+  return
+
+contains
+
+  subroutine izlsrx_up(n,x,indx)
+    use zlcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) < x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) >= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izlsrx_up
+
+  subroutine izlsrx_dw(n,x,indx)
+    use zlcmp_mod
+    implicit none
+    integer :: n
+    complex(kind(1.d0)) :: x(n)
+    integer :: indx(n)
+    integer :: i,j,ix
+    complex(kind(1.d0)) :: xx
+
+    do j=n-1,1,-1
+      if (x(j+1) > x(j)) then
+        xx = x(j)
+        ix = indx(j) 
+        i=j+1
+        do 
+          x(i-1)    = x(i)
+          indx(i-1) = indx(i)
+          i = i+1
+          if (i>n) exit          
+          if (x(i) <= xx) exit
+        end do
+        x(i-1)    = xx
+        indx(i-1) = ix
+      endif
+    enddo
+  end subroutine izlsrx_dw
+
+end subroutine zlsrx

base/serial/dp/dcoco.f

@@ -36,6 +36,7 @@ c
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       implicit none
 
 c     .. scalar arguments ..
@@ -74,8 +75,8 @@ c
 
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
       
-      if (trans.eq.'N') then
+      if (toupper(trans).eq.'N') then
-        scale  = (unitd.eq.'L') ! meaningless
+        scale  = (toupper(unitd).eq.'L') ! meaningless
         p1(1) = 0
         p2(1) = 0
 
@@ -114,7 +115,7 @@ c
           goto 9999
         end if
 
-        if (descra(1:1).eq.'G') then
+        if (toupper(descra(1:1)).eq.'G') then
 c
 c     sort COO data structure
 c     
@@ -245,26 +246,29 @@ c     ... add the duplicated element ...
           
           if (debug) write(*,*)'done rebuild COO',infon(1)
           
-        else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
+        else if (toupper(descra(1:1)).eq.'S' .and.
+     +      toupper(descra(2:2)).eq.'U') then
 
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
 
-        else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
+        else if (toupper(descra(1:1)).eq.'T' .and.
+     +      toupper(descra(2:2)).eq.'U') then
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
 
           
-        else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
+        else if (toupper(descra(1:1)).eq.'T' .and.
+     +      toupper(descra(2:2)).eq.'L') then
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
           
         end if
 c
-      else if (trans.ne.'N') then
+      else if (toupper(trans).ne.'N') then
 c
 c           to do
 c

base/serial/dp/dcocr.f

@@ -37,6 +37,7 @@ C
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -51,18 +52,19 @@ C     .. Array Arguments ..
      *  INFON(*), P1(*), P2(*)
       CHARACTER          DESCRA*11, DESCRN*11
 C     .. Local Scalars ..
-      INTEGER            NNZ, K, ROW, I, J, NZL, IRET
+      integer            nnz, k, row, i, j, nzl, iret
-      integer            ipx, ip1, ip2, CHECK_FLAG, err_act
+      integer            ipx, ip1, ip2, check_flag, err_act
-      INTEGER            ELEM, ELEM_CSR
+      integer            elem, elem_csr,regen_flag
-      LOGICAL            SCALE
+      logical            scale
-      INTEGER MAX_NNZERO
+      integer            max_nnzero
       logical     debug
       parameter   (debug=.false.)
-c     .. Local Arrays ..
+      integer, allocatable :: itmp(:)
-      CHARACTER*20       NAME
+c     .. local arrays ..
-      INTEGER            INT_VAL(5)
+      character*20       name
+      integer            int_val(5)
 
-C
+c
 C     ...Common variables...
 
 C     .. External Subroutines ..
@@ -75,14 +77,15 @@ C
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
+      call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
 
-      IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
+      IF (toupper(TRANS).EQ.'N') THEN
 
-        SCALE  = (UNITD.EQ.'L') ! meaningless
+        SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
         P1(1) = 0
         P2(1) = 0
 
-        NNZ = INFO(1)
+        nnz = info(1)
         if (debug) then 
           write(0,*) 'On entry to DCOCR: NNZ LAUX ',
      +      nnz,laux,larn,lian1,lian2
@@ -117,25 +120,35 @@ C
           GOTO 9999
         END IF
 
-        IF (DESCRA(1:1).EQ.'G') THEN
+        allocate(itmp(nnz),stat=iret)
+        if (iret /= 0) then 
+          call fcpsb_errpush(4010,name,int_val)
+          goto 9999
+        end if
+        
+        do k=1, nnz
+          arn(k)  = ar(k)
+          ian1(k) = ja(k)
+          itmp(k) = ia(k)
+        enddo
+        ! Mark as unavailable by default.
+        infon(psb_upd_pnt_)  = 0
+
+        
+        IF (toupper(descra(1:1)).EQ.'G') THEN
 C
 C        Sort COO data structure
 C
           if (debug) write(0,*)'First sort',nnz
-c$$$          if (debug) then
-c$$$            do k=1,nnz
-c$$$              write(*,*) k,ia(k),ja(k),ar(k)
-c$$$            enddo
-c$$$          endif
 c$$$          write(0,*) 'DCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1),
 c$$$     +      m+1,nnz,psb_ireg_flgs_,
 c$$$     +      laux,2*(2+nnz)
-          if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+          if ((regen_flag==psb_upd_perm_).and.
+     +      (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
      +      .and.(laux.ge.2*(2+nnz))) then 
 C
 C       Prepare for smart regeneration
 c             
-            
             ipx = nnz+3            
             do i=1, nnz
               aux(ipx+i-1) = i
@@ -149,182 +162,167 @@ c
             ian2(ip1+psb_nnz_)   = 0
             ian2(ip1+psb_ichk_)  = nnz+check_flag
 
-c$$$            write(0,*)'DCOCR Check: ',ip2,ian2(ip1+psb_iflag_),
-c$$$     +        ian2(ip1+psb_nnzt_), ian2(ip1+psb_nnz_),
-c$$$     +        ian2(ip1+psb_ichk_)
-
-c$$$     +        ip1,ip2,nnz,ian2(ip1+nnzt_) 
-
             if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) 
 C       .... Order with key IA ...
-            CALL MSORT_UP(NNZ,IA,AUX,IRET)
+            call msort_up(nnz,itmp,aux,iret)
-            IF (IRET.EQ.0) CALL REORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
+            if (iret.eq.0) call reordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
             if (debug) then 
               do i=1, nnz-1
-                if (ia(i).gt.ia(i+1)) then 
+                if (itmp(i).gt.itmp(i+1)) then 
-                  write(0,*) 'Sorting error:',i,ia(i),ia(i+1)
+                  write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1)
                 endif
               enddo
-              write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz)
+              write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
             endif
 
-C       .... Order with key IA2N ...
+C       .... Order with key JA ...
             
             I    = 1
             J    = I
-c$$$            DO WHILE (I.LE.NNZ)
+            do 
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+              if (i>nnz) exit
-c$$$     +          (J.LE.NNZ))
+              do
-            DO 
-              if (I>NNZ) exit
-              DO
                 if (j>nnz) exit
-                if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-                J = J+1
+                j = j+1
-              ENDDO
+              enddo
-              NZL = J - I
+              nzl = j - i
-              CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-              IF (IRET.EQ.0) CALL REORDVN3(NZL,AR(I),IA(I),JA(I),
+              if (iret.eq.0) call reordvn3(nzl,arn(i),itmp(i),ian1(i),
-     +          AUX(IPX+I-1),AUX)
+     +          aux(ipx+i-1),aux)
-              I = J
+              i = j
-            ENDDO
+            enddo
 
-C        ... Construct CSR Representation...
+c        ... Construct CSR Representation...
-            ELEM = 1
+            elem = 1
-            ELEM_CSR = 1
+            elem_csr = 1
-C        ... Insert first element ...
+c        ... Insert first element ...
-            DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-              IAN2(ROW) = 1
+              ian2(row) = 1
-            ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-            IAN1(ELEM_CSR) = JA(ELEM)
+            ian1(elem_csr) = ian1(elem)
-            ARN(ELEM_CSR)  = AR(ELEM)
+            arn(elem_csr)  = arn(elem)
             ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-            ELEM           = ELEM+1
+            elem           = elem+1
-            ELEM_CSR       = ELEM_CSR+1
+            elem_csr       = elem_csr+1
-C        ... Insert remaining element ...
+c        ... insert remaining element ...
-            DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-              DO 
                 if (elem > nnz) exit
-                if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-                IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C                 ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR)  = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
                   ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-                  ELEM_CSR       = ELEM_CSR+1
+                  elem_csr       = elem_csr+1
-                ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
+                else if (ian1(elem).ne.ian1(elem-1)) then
-C                 ... Insert other element of row ...
+c                 ... insert other element of row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR)  = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
                   ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE
+                else
-                  IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                  if (check_flag.eq.psb_dupl_err_) then
-C                    ... Error, there are duplicated elements ...
+c                    ... error, there are duplicated elements ...
-                    IERROR = 130
+                    ierror = 130
-                    CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                    call fcpsb_errpush(ierror,name,int_val)
-                    GOTO 9999
+                    goto 9999
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-C                    ... Insert only the last duplicated element ...
+c                    ... insert only the last duplicated element ...
-                    ARN(ELEM_CSR-1) = AR(ELEM)
+                    arn(elem_csr-1) = arn(elem)
                     ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
-                    if (debug) write(0,*) 'Duplicated overwrite perm ',
+                    if (debug) write(0,*) 'duplicated overwrite perm ',
      +                elem_csr-1,elem
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C                    ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
                     ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
-                    if (debug) write(0,*) 'Duplicated add perm ',
+                    if (debug) write(0,*) 'duplicated add perm ',
      +                elem_csr-1,elem
-                  END IF
+                  end if
-                ENDIF
+                endif
-                ELEM = ELEM + 1
+                elem = elem + 1
-              ENDDO
+              enddo
-              IAN2(ROW+1) = ELEM_CSR
+              ian2(row+1) = elem_csr
-            ENDDO
+            enddo
 
             
-          ELSE
+          else
-c$$$            write(0,*) 'Going for ELSE !!!?'
 C       .... Order with key IA ...
-            CALL MSORT_UP(NNZ,IA,AUX,IRET)
+
-            IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
+            call msort_up(nnz,itmp,aux,iret)
-C       .... Order with key IA2N ...
+            if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
-            I    = 1
+C       .... Order with key JA ...
-            J    = I
+            i    = 1
-c$$$            DO WHILE (I.LE.NNZ)
+            j    = i
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+            do 
-c$$$     +          (J.LE.NNZ))
+              if (i>nnz) exit
-            DO 
+              do
-              if (I>NNZ) exit
-              DO
                 if (j>nnz) exit
-                if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-                J = J+1
+                j = j+1
-              ENDDO
+              enddo
-              NZL = J - I
+              nzl = j - i
-              CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-              IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
+              if (iret.eq.0)
-              I = J
+     +          call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
-            ENDDO
+              i = j
+            enddo
 
 
 
 C        ... Construct CSR Representation...
-            ELEM = 1
+            elem = 1
-            ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-            DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-              IAN2(ROW) = 1
+              ian2(row) = 1
-            ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-            IAN1(ELEM_CSR) = JA(ELEM)
+            ian1(elem_csr) = ian1(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ELEM = ELEM+1
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
 C        ... Insert remaining element ...
-            DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-              DO 
                 if (elem > nnz) exit
-                if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-                IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C                 ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
+                else if (ian1(elem).ne.ian1(elem-1)) then
 C                 ... Insert other element of row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE
+                else
-                  IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                  if (check_flag.eq.psb_dupl_err_) then
-C     ... Error, there are duplicated elements ...
+c     ... error, there are duplicated elements ...
-                    IERROR = 130
+                    ierror = 130
-                    CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                    call fcpsb_errpush(ierror,name,int_val)
-                    GOTO 9999
+                    goto 9999
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-C                    ... Insert only the last duplicated element ...
+c                    ... insert only the last duplicated element ...
-                    ARN(ELEM_CSR-1) = AR(ELEM)
+                    arn(elem_csr-1) = arn(elem)
                     if (debug) write(0,*) 'Duplicated overwrite srch',
      +                elem_csr-1,elem
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C                    ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
                     if (debug) write(0,*) 'Duplicated add srch',
      +                elem_csr-1,elem
-                  END IF
+                  end if
-                ENDIF
+                endif
-                ELEM = ELEM + 1
+                elem = elem + 1
-              ENDDO
+              enddo
-              IAN2(ROW+1) = ELEM_CSR
+              ian2(row+1) = elem_csr
-            ENDDO
+            enddo
-          ENDIF
+          endif
 
           if (debug) write(0,*)'Done Rebuild CSR',
      +      ian2(m+1),ia(elem)
@@ -334,199 +332,161 @@ c$$$              write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
 c$$$            enddo
 c$$$          endif
 
-        ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
-          DO 20 K = 1, M
+          do 20 k = 1, m
-            P2(K) = K
+            p2(k) = k
- 20       CONTINUE
+ 20       continue
 
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
+        else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
-C       .... Order with key IA ...
+
-          CALL MSORT_UP(NNZ,IA,AUX,IRET)
+            call msort_up(nnz,itmp,aux,iret)
-          IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
+            if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
-C       .... Order with key IA2N ...
+C       .... Order with key JA ...
-          I    = 1
+            i    = 1
-          J    = I
+            j    = i
-c$$$            DO WHILE (I.LE.NNZ)
+            do 
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+              if (i>nnz) exit
-c$$$     +          (J.LE.NNZ))
+              do
-          DO 
-            if (I>NNZ) exit
-            DO
                 if (j>nnz) exit
-              if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-              J = J+1
+                j = j+1
-            ENDDO
+              enddo
-            NZL = J - I
+              nzl = j - i
-            CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-            IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
+              if (iret.eq.0)
-            I = J
+     +          call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
-          ENDDO
+              i = j
+            enddo
+
 
 
 C        ... Construct CSR Representation...
-          ELEM = 1
+            elem = 1
-          ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-          DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-            IAN2(ROW) = 1
+              ian2(row) = 1
-          ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-          IF(JA(ELEM).GT.IA(ELEM)) THEN
+            ian1(elem_csr) = ian1(elem)
-            IAN1(ELEM_CSR) = JA(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
-          ENDIF
-
-          ELEM = ELEM+1
-
 C        ... Insert remaining element ...
-          DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$  if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-            DO 
                 if (elem > nnz) exit
-              if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-              IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C     ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else if (ian1(elem).ne.ian1(elem-1)) then
-                ENDIF
-              ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
 C                 ... Insert other element of row ...
-                IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else
-                ENDIF
+                  if (check_flag.eq.psb_dupl_err_) then
-              ELSE
+c     ... error, there are duplicated elements ...
-                IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                    ierror = 130
-C     ... Error, there are duplicated elements ...
+                    call fcpsb_errpush(ierror,name,int_val)
-                  IERROR = 130
+                    goto 9999
-                  CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-                  GOTO 9999
+c                    ... insert only the last duplicated element ...
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                    arn(elem_csr-1) = arn(elem)
-C     ... Insert only the last duplicated element ...
+                    if (debug) write(0,*) 'Duplicated overwrite srch',
-                  IF(JA(ELEM).GT.IA(ELEM)) THEN                   
-                    ARN(ELEM_CSR-1) = AR(ELEM)
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated overwrite',
      +                elem_csr-1,elem
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C     ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                  IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    if (debug) write(0,*) 'Duplicated add srch',
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated add',
      +                elem_csr-1,elem
-                END IF
-              ENDIF
-              ELEM = ELEM + 1
-            ENDDO
-            IAN2(ROW+1) = ELEM_CSR
-          ENDDO
-
-          
-          if (debug) write(0,*)'Done Rebuild CSR',
-     +      ian2(m+1),ia(elem)
-          if (debug) then 
-            do i=ian2(m+1), nnz
-              write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
-            enddo
                   end if
+                endif
+                elem = elem + 1
+              enddo
+              ian2(row+1) = elem_csr
+            enddo
           
+        else if (toupper(descra(1:1)).EQ.'T' .AND.
+     +        toupper(DESCRA(2:2)).EQ.'L') THEN
+
+            call msort_up(nnz,itmp,aux,iret)
+            if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
+C       .... Order with key JA ...
+            i    = 1
+            j    = i
+            do 
+              if (i>nnz) exit
+              do
+                if (j>nnz) exit
+                if (itmp(j) /= itmp(i)) exit
+                j = j+1
+              enddo
+              nzl = j - i
+              call msort_up(nzl,ian1(i),aux,iret)
+              if (iret.eq.0)
+     +          call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
+              i = j
+            enddo
 
 
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
-
-C       .... Order with key IA ...
-          CALL MSORT_UP(NNZ,IA,AUX,IRET)
-          IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
-C       .... Order with key IA2N ...
-          I    = 1
-          J    = I
-c$$$            DO WHILE (I.LE.NNZ)
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
-c$$$     +          (J.LE.NNZ))
-          DO 
-            if (I>NNZ) exit
-            DO
-              if (j>nnz) exit
-              if (ia(j) /= ia(i)) exit
-              J = J+1
-            ENDDO
-            NZL = J - I
-            CALL MSORT_UP(NZL,JA(I),AUX,IRET)
-            IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
-            I = J
-          ENDDO
 
 C        ... Construct CSR Representation...
-          ELEM = 1
+            elem = 1
-          ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-          DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-            IAN2(ROW) = 1
+              ian2(row) = 1
-          ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-          IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+            ian1(elem_csr) = ian1(elem)
-            IAN1(ELEM_CSR) = JA(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
-          ENDIF
-          ELEM = ELEM+1
-          
 C        ... Insert remaining element ...
-          DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-            DO 
                 if (elem > nnz) exit
-              if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-              IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C     ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else if (ian1(elem).ne.ian1(elem-1)) then
-                ENDIF
-              ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
 C                 ... Insert other element of row ...
-                IF(JA(ELEM).LT.IA(ELEM)) THEN                               
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else
-                ENDIF
+                  if (check_flag.eq.psb_dupl_err_) then
-              ELSE
+c     ... error, there are duplicated elements ...
-                IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                    ierror = 130
-C                    ... Error, there are duplicated elements ...
+                    call fcpsb_errpush(ierror,name,int_val)
-                  IERROR = 130
+                    goto 9999
-                  CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-                  GOTO 9999
+c                    ... insert only the last duplicated element ...
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                    arn(elem_csr-1) = arn(elem)
-C                    ... Insert only the last duplicated element ...
+                    if (debug) write(0,*) 'Duplicated overwrite srch',
-                  IF(JA(ELEM).LT.IA(ELEM)) THEN                   
-                    ARN(ELEM_CSR-1) = AR(ELEM)
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated overwrite',
      +                elem_csr-1,elem
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C                    ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                  IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    if (debug) write(0,*) 'Duplicated add srch',
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated add',
      +                elem_csr-1,elem
-                END IF
+                  end if
-              ENDIF
+                endif
-              ELEM = ELEM + 1
+                elem = elem + 1
-            ENDDO
+              enddo
-            IAN2(ROW+1) = ELEM_CSR
+              ian2(row+1) = elem_csr
-          ENDDO
+            enddo
-
           
           if (debug) write(0,*)'Done Rebuild CSR',
      +      ian2(m+1),ia(elem)
@@ -537,29 +497,29 @@ C                    ... Sum the duplicated element ...
           endif
 
 
-        END IF
+        end if
-C
+c
-      ELSE IF (TRANS.NE.'N') THEN
+      else if (toupper(TRANS).NE.'N') then
-C
+c
-C           TO DO
+c           to do
-C
+c
-        IERROR = 3021
+        ierror = 3021
-        CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+        call fcpsb_errpush(ierror,name,int_val)
-        GOTO 9999
+        goto 9999
 
-      END IF
+      end if
-      INFON(1)=ELEM_CSR-1
+      infon(1)=elem_csr-1
 
-      CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
+      call fcpsb_erractionrestore(err_act)
-      RETURN
+      return
 
- 9999 CONTINUE
+ 9999 continue
-      CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
+      call fcpsb_erractionrestore(err_act)
 
-      IF ( ERR_ACT .NE. 0 ) THEN 
+      if ( err_act .ne. 0 ) then 
-        CALL FCPSB_SERROR()
+        call fcpsb_serror()
-        RETURN
+        return
-      ENDIF
+      endif
 
-      RETURN
+      return
-      END
+      end

base/serial/dp/dcrco.f

@@ -34,6 +34,7 @@ C
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -63,8 +64,8 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF (TRANS.EQ.'N') THEN
+      IF (toupper(TRANS).EQ.'N') THEN
-         SCALE  = (UNITD.EQ.'L') ! meaningless
+         SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
          IP1(1) = 0
          IP2(1) = 0
          NNZ = IA2(M+1)-1
@@ -92,7 +93,7 @@ C
             GOTO 9999
          END IF
          
-         IF (DESCRA(1:1).EQ.'G') THEN
+         IF (toupper(DESCRA(1:1)).EQ.'G') THEN
 C        ... Construct COO Representation...
             ELEM = 0
 
@@ -106,19 +107,27 @@ C        ... Construct COO Representation...
             ENDDO
             INFON(psb_nnz_) = elem
             if (debug) write(0,*) 'CRCO endloop',m,elem
-         ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+         ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +        toupper(DESCRA(2:2)).EQ.'U') THEN
 
             DO 20 K = 1, M
                IP2(K) = K
  20         CONTINUE
 
+            ierror = 3021
+            call fcpsb_errpush(ierror,name,int_val)
+            goto 9999
 c$$$            CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
 c$$$     *                 AUX(IWORK1))
 c$$$            CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
 c$$$     *                 IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
 c$$$     *                 AUX(IWORK2),NJA,IER,SCALE)
 C
-         ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
+         ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +        toupper(DESCRA(2:2)).EQ.'U') THEN
+           ierror = 3021
+           call fcpsb_errpush(ierror,name,int_val)
+           goto 9999
 
 c$$$            CALL DVTFG('U',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
 c$$$c    *                 AUX(IWORK1),AUX(IWORK2),IAN1(M+1))
@@ -127,23 +136,36 @@ c$$$            CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2,
 c$$$     *                 IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE)
 C
 
-         ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
+         ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +       toupper(DESCRA(2:2)).EQ.'L') THEN
+           ierror = 3021
+           call fcpsb_errpush(ierror,name,int_val)
+           goto 9999
 
 c$$$            CALL DVTFG('L',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
 c$$$c     *                 AUX(IWORK1),AUX(IWORK2),IAN1(M+1))
 c$$$     *                 AUX(IWORK1),IAN1(1),IAN1(M+5))
 c$$$            CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2,
 c$$$     *                 IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE)
+         else
+           ierror = 3021
+           call fcpsb_errpush(ierror,name,int_val)
+           goto 9999
 
          END IF
 C
-      ELSE IF (TRANS.NE.'N') THEN
+      ELSE IF (toupper(TRANS).NE.'N') THEN
 C
 C           TO DO
 C     
          IERROR = 3021
          CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
          GOTO 9999
+       else
+         ierror = 3021
+         call fcpsb_errpush(ierror,name,int_val)
+         goto 9999
+
 
       END IF
 

base/serial/dp/dcrcr.f

@@ -163,6 +163,7 @@ C
       SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1,
      *                 DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2,
      *                 WORK,LWORK,IERROR)
+      use psb_string_mod
       IMPLICIT NONE                                                      
 C
 C     .. Scalar Arguments ..
@@ -177,6 +178,7 @@ C     .. Local Scalars ..
       INTEGER          I, J, ERR_ACT
       LOGICAL          EXIT
 c     .. Local Arrays ..
+      character        idescra*11
       CHARACTER*20       NAME
       INTEGER            INT_VAL(5)
 
@@ -192,11 +194,12 @@ C
 C
 C       Check for argument errors
 C
-      IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      idescra=toupper(descra)
-     &   DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B'))  .OR.
+      IF(((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
-     &   (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR.
+     &   idescra(1:1) .EQ. 'A') .AND. (toupper(unitd) .NE. 'B'))  .OR.
-     +  (DESCRA(3:3).EQ.'U'))) .OR.
+     &   (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR.
-     +  TRANS.NE.'N') THEN
+     +  (idescra(3:3).EQ.'U'))) .OR.
+     +  toupper(TRANS).NE.'N') THEN
          IERROR = 20
       ENDIF
       IF(LAN.LT.(IA2(M+1)-1)) THEN
@@ -223,8 +226,8 @@ C
             IERROR = 23
          ENDIF
       ENDIF
-      IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
-     &     DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
+     &     idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
          IF (LWORK.LT.M) THEN
             IF     (LWORK.LE.0) THEN
                EXIT=.TRUE.
@@ -250,7 +253,7 @@ C
 C
 C     Set DESCRN, IP1, IP2
 C
-      DESCRN(1:3) = DESCRA(1:3)
+      DESCRN(1:3) = idescra(1:3)
 
       IP1(1)=0
       IP2(1)=0
@@ -260,8 +263,8 @@ C
       DO 20 I = 1, M+1
          IAN2(I) = IA2(I)
  20   CONTINUE
-      IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
-     &     DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
+     &     idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
          DO 30 I = 1, M
             WORK(I) = DSQRT(D(I))
  30      CONTINUE
@@ -271,21 +274,21 @@ C
                IAN1(J) = IA1(J)
  50         CONTINUE
  40      CONTINUE
-      ELSE IF (UNITD .EQ. 'L') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'L') THEN
             DO 60 I = 1, M
                DO 70 J = IA2(I), IA2(I+1)-1
                   AN(J)   = D(I) * A(J)
                   IAN1(J) = IA1(J)
  70            CONTINUE
  60         CONTINUE
-      ELSE IF (UNITD .EQ. 'R') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'R') THEN
             DO 80 I = 1, M
                DO 90 J = IA2(I), IA2(I+1)-1
                   AN(J)   = A(J) * D(IA1(J))
                   IAN1(J) = IA1(J)
  90            CONTINUE
  80         CONTINUE
-      ELSE IF (UNITD .EQ. 'U') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'U') THEN
          DO 100 J = 1, IA2(M+1)-1
             AN(J)   = A(J)
             IAN1(J) = IA1(J)

base/serial/dp/dcrjd.f

@@ -61,6 +61,7 @@ C     IAN2,INFON, IP1, IP2
 C   
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -69,9 +70,9 @@ C     .. Scalar Arguments ..
      *     SIZE_REQ, IERROR
       CHARACTER          TRANS,UNITD
 C     .. Array Arguments ..
-      DOUBLE PRECISION   AR(*), ARN(*), D(*), AUX(LAUX)
+      DOUBLE PRECISION   AR(*), ARN(LARN), D(*), AUX(LAUX)
-      INTEGER            IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*),
+      INTEGER            IA1(*), IA2(*), INFO(*), IAN1(LIAN1),
-     *  INFON(*), IP1(*), IP2(*)
+     +  IAN2(LIAN2), INFON(*), IP1(*), IP2(*)
       CHARACTER          DESCRA*11, DESCRN*11
 C     .. Local Scalars ..
       INTEGER            IOFF, ISTROW, NJA, NZ, PIA,
@@ -103,10 +104,10 @@ C
          GOTO 9999
       ENDIF
 
-      IF (TRANS.EQ.'N') THEN
+      IF (toupper(TRANS).EQ.'N') THEN
 C
         NJA    = 3*M
-        SCALE  = (UNITD.EQ.'L') ! meaningless
+        SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
         IOFF   = 5
 C
 C        SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX
@@ -115,7 +116,7 @@ C
         PIA    = PNG + 1
         PJA    = PIA + 3*(M+2)
 
-        IF (DESCRA(1:1).EQ.'G') THEN
+        IF (toupper(DESCRA(1:1)).EQ.'G') THEN
 
 C
 C        CHECK ON DIMENSION OF IAN2 AND AUX
@@ -169,9 +170,10 @@ C
           ENDIF
 
           LJA = LIAN2-PJA
-          CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), 
+          CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,info,
-     +         IAN2(PJA), INFON, LARN,LIAN1,
+     +      ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON,
-     +         LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR)
+     +      LARN,LIAN1, LJA,IP1,
+     +      AUX, LAUX*2, SIZE_REQ,IERROR)
           
           IF (IERROR.NE.0) THEN
              CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
@@ -182,7 +184,8 @@ C
           DESCRN(2:2) = 'U'
           DESCRN(3:3) = 'N'
 
-        ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 C
           ISTROW = 1
           NZ     = 2*(IA2(M+1)-1) - M
@@ -218,13 +221,13 @@ c$$$            CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
 c$$$     *                 IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
 c$$$     *                 AUX(IWORK2),NJA,IER,SCALE)
 C
-        ELSE IF (DESCRA(1:1).EQ.'T') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN
 C
 C  Only unit diagonal so far for triangular matrices. 
 C
 
 
-          IF (DESCRA(3:3).NE.'U') THEN 
+          IF (toupper(DESCRA(3:3)).NE.'U') THEN 
             IERROR=3022
             CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
             GOTO 9999
@@ -273,8 +276,7 @@ c$$$                write(0,*) "error 2",ierrv(1)
           ENDIF
           
           DESCRN(1:1) = 'T'
-          DESCRN(2:2) = DESCRA(2:2)
+          DESCRN(2:3) = toupper(DESCRA(2:3))
-          DESCRN(3:3) = DESCRA(3:3)
 
         END IF
 C
@@ -288,7 +290,7 @@ C
         LIAN2   = 3*M + 10
         LAUX2   = 4*M + 2
 C
-      ELSE IF (TRANS.NE.'N') THEN
+      ELSE IF (toupper(TRANS).NE.'N') THEN
 C
 C           TO BE DONE
 C

base/serial/dp/dcsrp1.f

@@ -118,6 +118,7 @@ C
      +   P,WORK,IWORK,LWORK,IERROR)
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 C     .. Scalar Arguments ..
       INTEGER          LWORK,M, N, IERROR
@@ -140,14 +141,14 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF(TRANS.EQ.'N') THEN
+      IF(toupper(TRANS).EQ.'N') THEN
          DO 30 I=1,M
             DO 10 J=IA(I),IA(I+1)-1
                JA(J) = P(JA(J))
  10         CONTINUE
  30      CONTINUE
          WORK(1) = 0.D0
-      ELSE IF(TRANS.EQ.'T') THEN
+      ELSE IF(toupper(TRANS).EQ.'T') THEN
 C
 C        LWORK refers here to INTEGER IWORK (alias for WORK)
 C

base/serial/dp/dcsrrp.f

@@ -121,6 +121,7 @@ C
 C                                                                        
       SUBROUTINE DCSRRP(TRANS,M,N,DESCRA,JA,IA,                          
      +   P,WORK,LWORK,IERROR)
+      use psb_string_mod
       IMPLICIT NONE                                                      
 C     .. Scalar Arguments ..
       INTEGER          LWORK, M, N, IERROR
@@ -143,7 +144,8 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF (DESCRA(1:1).EQ.'S' .OR. DESCRA(1:1).EQ.'T') THEN
+      IF (toupper(DESCRA(1:1)).EQ.'S' .OR.
+     +   toupper(DESCRA(1:1)).EQ.'T') THEN
          IERROR=3023
          CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
          GOTO 9999

base/serial/dp/dgindex.f

@@ -28,7 +28,7 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 C POSSIBILITY OF SUCH DAMAGE.
 C
 C 
-      SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON,
+      SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON,
      +  LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
 
       use psb_const_mod
@@ -41,14 +41,14 @@ C     ... Scalar arguments ...
 
 C     ... Array arguments ...
 
-      DOUBLE PRECISION A(*), ARN(*)
+      DOUBLE PRECISION A(*), ARN(LARN)
-      INTEGER          IA1(*), IA2(*), KA(*), 
+      INTEGER          IA1(*), IA2(*), KA(LKA), 
-     +     IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*)
+     +  IA(3,*), IPERM(*), JA(LJA), WORK(*),INFON(*), infoa(*)
       
 C     .... Local scalars ...
       INTEGER          I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1,
      +  IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
-     +     ERR_ACT
+     +  ERR_ACT, ix, regen_flag
       LOGICAL          CSR
 c     .. Local Arrays ..
       CHARACTER*20       NAME
@@ -60,8 +60,8 @@ c     .. Local Arrays ..
 
       POINT_AR = 1
       POINT_JA = 0
-
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
+      call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
 
 
       IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
@@ -83,7 +83,9 @@ C     .... Invert Permutation Matrix...
         ENDDO
       ENDIF
 
-      IF ( (LKA .GE.( SIZE_REQ ))  
+      size_Req=0
+
+      IF ( (regen_flag == psb_upd_perm_)
      +  .AND. (LWORK .GE. (M + NNZ+2))) THEN
 C     
 C     Prepare for smart regeneration
@@ -100,15 +102,21 @@ C
         KA(IP1+PSB_NNZT_)    = NNZ
         KA(IP1+PSB_NNZ_)     = 0
         KA(IP1+PSB_ICHK_)    = NNZ+CHECK_FLAG
-         I                = M+2
-         IPX              = IA2(I+PSB_IP2_)
 
+        if (infoa(psb_upd_pnt_) > 0) then 
+          I                    = infoa(psb_upd_pnt_)
+          IPX                  = IA2(I+PSB_IP2_)
 C     Invert permutation for smart regeneration
           
           DO I = 1, NNZ
             WORK(IPW + IA2(IPX + I -1) - 1) = I
           ENDDO
-
+        else
+          ! No permutation available before, set identity.
+          DO I = 1, NNZ
+            WORK(IPW + I  - 1) = I
+          ENDDO
+        endif
 C     Construct JAD matrix...
 
         DO BLOCK = 1, N_BLOCKS
@@ -272,9 +280,19 @@ C     ... For each nnzero elements belonging to current row ...
           ENDDO
         ENDDO
         
+        IA(2,N_BLOCKS+1) = POINT_JA
+        KA(IP1 + PSB_ZERO_) = COUNT
+        
+        IF (POINT_AR.GE.IP1) THEN
+          SIZE_REQ=NNZ+COUNT
+        ELSE
+          SIZE_REQ=0
+        ENDIF        
         
       ELSE
 c$$$  c      write(*,*)'inizio a ciclare sui blocchi'
+        IP1 = LKA - PSB_ZERO_ 
+
         DO BLOCK = 1, N_BLOCKS
           COL = 1
           DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
@@ -417,16 +435,15 @@ C     ... For each nnzero elements belonging to current row ...
         
         
         
-         
-      ENDIF
         IA(2,N_BLOCKS+1) = POINT_JA
-      KA(IP1 + PSB_ZERO_) = COUNT
         
-      IF(POINT_AR.GE.IP1) THEN
+        IF (POINT_AR.GE.lka) THEN
           SIZE_REQ=NNZ+COUNT
         ELSE
           SIZE_REQ=0
         ENDIF        
+      ENDIF
+
       infon(1)=point_ar-1
 
       CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)

base/serial/dp/djadrp.f

@@ -116,6 +116,7 @@ C
 C
       SUBROUTINE DJADRP(TRANS,M,N,DESCRA,JA,IA,
      +   P,WORK,LWORK,IERROR)
+      use psb_string_mod
       IMPLICIT NONE                                                      
 C     .. Scalar Arguments ..
       INTEGER          LWORK, M, N, IERROR
@@ -146,7 +147,7 @@ C
       PIA    = PNG + 1
       PJA    = PIA + 3*(IA(PNG)+1)
 
-      IF (DESCRA(1:1).EQ.'G') THEN
+      IF (toupper(DESCRA(1:1)).EQ.'G') THEN
          CALL DJADRP1(TRANS,M,N,DESCRA,IA(PNG),
      +      JA,IA(PIA),IA(PJA),P,WORK,LWORK*2)
       ELSE

base/serial/dp/djadrp1.f

@@ -102,6 +102,7 @@ C
 C
       SUBROUTINE DJADRP1(TRANS,M,N,DESCRA,NG,KA,IA,JA,
      +   P,IWORK,LWORK,IERROR)
+      use psb_string_mod
       IMPLICIT NONE                                                      
 C     .. Scalar Arguments ..
       INTEGER          LWORK,M, N, NG, IERROR
@@ -125,7 +126,7 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF(TRANS.EQ.'N') THEN
+      IF(toupper(TRANS).EQ.'N') THEN
         IF (DEBUG) WRITE(0,*)'DJADRP1:',NG
         DO IPG = 1, NG                                                    
           DO  K = IA(2,IPG), IA(3,IPG)-1                                   
@@ -143,7 +144,7 @@ C        Permute CSR
         ENDDO
         
         IWORK(1) = 0
-      ELSE IF(TRANS.EQ.'T') THEN
+      ELSE IF(toupper(TRANS).EQ.'T') THEN
 C
 C        LWORK refers here to INTEGER IWORK (alias for WORK)
 C

base/serial/dp/djdcox.f

@@ -37,6 +37,7 @@ C
      *  LIA2N,AUX,LAUX,IERROR)
 
       use psb_const_mod
+      use psb_string_mod
       IMPLICIT NONE
 
 C     
@@ -66,7 +67,7 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF (TRANS.EQ.'N') THEN
+      IF (toupper(TRANS).EQ.'N') THEN
 C     SCALE  = (UNITD.EQ.'L') ! meaningless
         IP1(1) = 0
         IP2(1) = 0
@@ -105,7 +106,7 @@ C     SCALE  = (UNITD.EQ.'L') ! meaningless
           INT_VAL(3) = LAUX
         ENDIF
         
-         IF (DESCRA(1:1).EQ.'G') THEN
+        IF (toupper(DESCRA(1:1)).EQ.'G') THEN
           
           DO 200 IPG = 1, NG                                                  
             DO 50 K = IA(2,IPG), IA(3,IPG)-1                                
@@ -151,19 +152,24 @@ C     .... Order with key IA2N ...
           ENDDO
           INFON(1)=nnz
           
-         ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
           DO 20 K = 1, M
             IP2(K) = K
  20       CONTINUE
 
-         ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
+c$$$        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
-
+c$$$
-         ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
+c$$$        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
+        else
+          IERROR = 3021
+          CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+          GOTO 9999
           
         END IF
 C     
-      ELSE IF (TRANS.NE.'N') THEN 
+      ELSE IF (toupper(TRANS).NE.'N') THEN 
 C     
 C     TO DO
 C     

base/serial/dp/dvtfg.f

@@ -33,6 +33,8 @@ C  Compute level numbers for the triangular matrix.
 C                                                                               
       SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2,            
      *  IWORK3)                                                 
+      use psb_string_mod
+      implicit none
 C     .. Scalar Arguments ..                                                    
       INTEGER           M, NG                                                   
       CHARACTER         UPLO                                                    
@@ -72,7 +74,7 @@ C
           IWORK1(I) = 0                                                       
           IWORK3(I) = 0                                                    
  40     CONTINUE                                                               
-         IF (UPLO.EQ.'L') THEN                                                  
+        IF (toupper(UPLO).EQ.'L') THEN                                                  
 C                                                                               
 C           LOWER TRIANGULAR SPARSE MATRIX                                      
 C                                                                               
@@ -82,7 +84,7 @@ C
               IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1)                    
  60         CONTINUE                                                         
  80       CONTINUE                                                            
-         ELSE IF (UPLO.EQ.'U') THEN                                             
+        ELSE IF (toupper(UPLO).EQ.'U') THEN                                             
 C                                                                               
 C           UPPER TRIANGULAR SPARSE MATRIX                                      
 C                                                                               

base/serial/dp/zcoco.f

@@ -36,6 +36,7 @@ c
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       implicit none
 
 c     .. scalar arguments ..
@@ -73,8 +74,8 @@ c
       call fcpsb_erractionsave(err_act)
 
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
-      if (trans.eq.'N') then
+      if (toupper(trans).eq.'N') then
-        scale  = (unitd.eq.'L') ! meaningless
+        scale  = (toupper(unitd).eq.'L') ! meaningless
         p1(1) = 0
         p2(1) = 0
 
@@ -113,7 +114,7 @@ c
           goto 9999
         end if
 
-        if (descra(1:1).eq.'G') then
+        if (toupper(descra(1:1)).eq.'G') then
 c
 c     sort COO data structure
 c     
@@ -245,26 +246,29 @@ c     ... sum the duplicated element ...
           
           if (debug) write(*,*)'done rebuild COO',infon(1)
           
-        else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
+        else if (toupper(descra(1:1)).eq.'S' .and.
+     +      toupper(descra(2:2)).eq.'U') then
 
           do 20 k = 1, m
             p2(k) = k
  20       continue
 
-        else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
+        else if (toupper(descra(1:1)).eq.'T' .and.
+     +      toupper(descra(2:2)).eq.'U') then
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
 
           
-        else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
+        else if (toupper(descra(1:1)).eq.'T' .and.
+     +      toupper(descra(2:2)).eq.'L') then
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
           
         end if
 c
-      else if (trans.ne.'N') then
+      else if (toupper(trans).ne.'N') then
 c
 c           to do
 c

base/serial/dp/zcocr.f

@@ -37,6 +37,7 @@ C
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -51,16 +52,17 @@ C     .. Array Arguments ..
      *  INFON(*), P1(*), P2(*)
       CHARACTER          DESCRA*11, DESCRN*11
 C     .. Local Scalars ..
-      INTEGER            NNZ, K, ROW, I, J, NZL, IRET
+      integer            nnz, k, row, i, j, nzl, iret
-      integer            ipx, ip1, ip2, CHECK_FLAG, err_act
+      integer            ipx, ip1, ip2, check_flag, err_act
-      INTEGER            ELEM, ELEM_CSR
+      integer            elem, elem_csr,regen_flag
-      LOGICAL            SCALE
+      logical            scale
-      INTEGER MAX_NNZERO
+      integer max_nnzero
       logical     debug
       parameter   (debug=.false.)
-c     .. Local Arrays ..
+      integer, allocatable :: itmp(:)
-      CHARACTER*20       NAME
+c     .. local arrays ..
-      INTEGER            INT_VAL(5)
+      character*20       name
+      integer            int_val(5)
 
 C
 C     ...Common variables...
@@ -75,14 +77,15 @@ C
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
+      call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
 
-      IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
+      IF (toupper(TRANS).EQ.'N') THEN
 
-        SCALE  = (UNITD.EQ.'L') ! meaningless
+        SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
         P1(1) = 0
         P2(1) = 0
 
-        NNZ = INFO(1)
+        nnz = info(1)
         if (debug) then 
           write(0,*) 'On entry to ZCOCR: NNZ LAUX ',
      +      nnz,laux,larn,lian1,lian2
@@ -95,18 +98,18 @@ C
         ELSE IF (LARN.LT.NNZ) THEN
           IERROR = 60
           INT_VAL(1) = 18
-          INT_VAL(2) = NNZ+2
+          INT_VAL(2) = NNZ
-          INT_VAL(3) = LAUX
+          INT_VAL(3) = LARN
         ELSE IF (LIAN1.LT.NNZ) THEN
           IERROR = 60
           INT_VAL(1) = 19
-          INT_VAL(2) = NNZ+2
+          INT_VAL(2) = NNZ
-          INT_VAL(3) = LAUX
+          INT_VAL(3) = LIAN1
         ELSE IF (LIAN2.LT.M+1) THEN
           IERROR = 60
           INT_VAL(1) = 20
-          INT_VAL(2) = NNZ+2
+          INT_VAL(2) = M+1
-          INT_VAL(3) = LAUX
+          INT_VAL(3) = LIAN2
         ENDIF
         
 C
@@ -117,25 +120,32 @@ C
           GOTO 9999
         END IF
 
-        IF (DESCRA(1:1).EQ.'G') THEN
+        allocate(itmp(nnz),stat=iret)
+        if (iret /= 0) then 
+          call fcpsb_errpush(4010,name,int_val)
+          goto 9999
+        end if
+        
+        do k=1, nnz
+          arn(k)  = ar(k)
+          ian1(k) = ja(k)
+          itmp(k) = ia(k)
+        enddo
+        
+        IF (toupper(descra(1:1)).EQ.'G') THEN
 C
 C        Sort COO data structure
 C
           if (debug) write(0,*)'First sort',nnz
-c$$$          if (debug) then
-c$$$            do k=1,nnz
-c$$$              write(*,*) k,ia(k),ja(k),ar(k)
-c$$$            enddo
-c$$$          endif
 c$$$          write(0,*) 'ZCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1),
 c$$$     +      m+1,nnz,psb_ireg_flgs_,
 c$$$     +      laux,2*(2+nnz)
-          if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+          if ((regen_flag==psb_upd_perm_).and.
+     +      (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
      +      .and.(laux.ge.2*(2+nnz))) then 
 C
 C       Prepare for smart regeneration
 c             
-            
             ipx = nnz+3            
             do i=1, nnz
               aux(ipx+i-1) = i
@@ -157,370 +167,330 @@ c$$$     +        ip1,ip2,nnz,ian2(ip1+nnzt_)
 
             if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) 
 C       .... Order with key IA ...
-            CALL MSORT_UP(NNZ,IA,AUX,IRET)
+            call msort_up(nnz,itmp,aux,iret)
-            IF (IRET.EQ.0) CALL ZREORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
+            if (iret.eq.0)
+     +         call zreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
             if (debug) then 
               do i=1, nnz-1
-                if (ia(i).gt.ia(i+1)) then 
+                if (itmp(i).gt.itmp(i+1)) then 
-                  write(0,*) 'Sorting error:',i,ia(i),ia(i+1)
+                  write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1)
                 endif
               enddo
-              write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz)
+              write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
             endif
 
-C       .... Order with key IA2N ...
+C       .... Order with key JA ...
             
             I    = 1
             J    = I
-c$$$            DO WHILE (I.LE.NNZ)
+            do 
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+              if (i>nnz) exit
-c$$$     +          (J.LE.NNZ))
+              do
-            DO 
-              if (I>NNZ) exit
-              DO
                 if (j>nnz) exit
-                if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-                J = J+1
+                j = j+1
-              ENDDO
+              enddo
-              NZL = J - I
+              nzl = j - i
-              CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-              IF (IRET.EQ.0) CALL ZREORDVN3(NZL,AR(I),IA(I),JA(I),
+              if (iret.eq.0) call zreordvn3(nzl,arn(i),itmp(i),ian1(i),
-     +          AUX(IPX+I-1),AUX)
+     +          aux(ipx+i-1),aux)
-              I = J
+              i = j
-            ENDDO
+            enddo
 
-C        ... Construct CSR Representation...
+c        ... Construct CSR Representation...
-            ELEM = 1
+            elem = 1
-            ELEM_CSR = 1
+            elem_csr = 1
-C        ... Insert first element ...
+c        ... Insert first element ...
-            DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-              IAN2(ROW) = 1
+              ian2(row) = 1
-            ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-            IAN1(ELEM_CSR) = JA(ELEM)
+            ian1(elem_csr) = ian1(elem)
-            ARN(ELEM_CSR)  = AR(ELEM)
+            arn(elem_csr)  = arn(elem)
             ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-            ELEM           = ELEM+1
+            elem           = elem+1
-            ELEM_CSR       = ELEM_CSR+1
+            elem_csr       = elem_csr+1
-C        ... Insert remaining element ...
+c        ... insert remaining element ...
-            DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-              DO 
                 if (elem > nnz) exit
-                if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-                IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C                 ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR)  = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
                   ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-                  ELEM_CSR       = ELEM_CSR+1
+                  elem_csr       = elem_csr+1
-                ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
+                else if (ian1(elem).ne.ian1(elem-1)) then
-C                 ... Insert other element of row ...
+c                 ... insert other element of row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR)  = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
                   ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE
+                else
-                  IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                  if (check_flag.eq.psb_dupl_err_) then
-C                    ... Error, there are duplicated elements ...
+c                    ... error, there are duplicated elements ...
-                    IERROR = 130
+                    ierror = 130
-                    CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                    call fcpsb_errpush(ierror,name,int_val)
-                    GOTO 9999
+                    goto 9999
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-C                    ... Insert only the last duplicated element ...
+c                    ... insert only the last duplicated element ...
-                    ARN(ELEM_CSR-1) = AR(ELEM)
+                    arn(elem_csr-1) = arn(elem)
                     ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                    if (debug) write(0,*) 'duplicated overwrite perm ',
-C                    ... Sum the duplicated element ...
+     +                elem_csr-1,elem
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                  else if (check_flag.eq.psb_dupl_add_) then 
+c                    ... sum the duplicated element ...
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
                     ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
-                  END IF
+                    if (debug) write(0,*) 'duplicated add perm ',
-                ENDIF
+     +                elem_csr-1,elem
-                ELEM = ELEM + 1
+                  end if
-              ENDDO
+                endif
-              IAN2(ROW+1) = ELEM_CSR
+                elem = elem + 1
-            ENDDO
+              enddo
-          ELSE
+              ian2(row+1) = elem_csr
-c$$$            write(0,*) 'Going for ELSE !!!?'
+            enddo
+
+            
+          else
 C       .... Order with key IA ...
-            CALL MSORT_UP(NNZ,IA,AUX,IRET)
+
-            IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
+            call msort_up(nnz,itmp,aux,iret)
-C       .... Order with key IA2N ...
+            if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
-            I    = 1
+C       .... Order with key JA ...
-            J    = I
+            i    = 1
-c$$$            DO WHILE (I.LE.NNZ)
+            j    = i
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+            do 
-c$$$     +          (J.LE.NNZ))
+              if (i>nnz) exit
-            DO 
+              do
-              if (I>NNZ) exit
-              DO
                 if (j>nnz) exit
-                if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-                J = J+1
+                j = j+1
-              ENDDO
+              enddo
-              NZL = J - I
+              nzl = j - i
-              CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-              IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
+              if (iret.eq.0)
-              I = J
+     +          call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
-            ENDDO
+              i = j
+            enddo
 
 
 
 C        ... Construct CSR Representation...
-            ELEM = 1
+            elem = 1
-            ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-            DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-              IAN2(ROW) = 1
+              ian2(row) = 1
-            ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-            IAN1(ELEM_CSR) = JA(ELEM)
+            ian1(elem_csr) = ian1(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ELEM = ELEM+1
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
 C        ... Insert remaining element ...
-            DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-              DO 
                 if (elem > nnz) exit
-                if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-                IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C                 ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
+                else if (ian1(elem).ne.ian1(elem-1)) then
 C                 ... Insert other element of row ...
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  ian1(elem_csr) = ian1(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ELEM_CSR = ELEM_CSR+1
+                  elem_csr = elem_csr+1
-                ELSE
+                else
-                  IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                  if (check_flag.eq.psb_dupl_err_) then
-C     ... Error, there are duplicated elements ...
+c     ... error, there are duplicated elements ...
-                    IERROR = 130
+                    ierror = 130
-                    CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                    call fcpsb_errpush(ierror,name,int_val)
-                    GOTO 9999
+                    goto 9999
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-C                    ... Insert only the last duplicated element ...
+c                    ... insert only the last duplicated element ...
-                    ARN(ELEM_CSR-1) = AR(ELEM)
+                    arn(elem_csr-1) = arn(elem)
-                    if (debug) write(0,*) 'Duplicated overwrite',
+                    if (debug) write(0,*) 'Duplicated overwrite srch',
      +                elem_csr-1,elem
-                  ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C                    ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
-                    if (debug) write(0,*) 'Duplicated add',
+                    if (debug) write(0,*) 'Duplicated add srch',
      +                elem_csr-1,elem
-                  END IF
+                  end if
-                ENDIF
+                endif
-                ELEM = ELEM + 1
+                elem = elem + 1
-              ENDDO
+              enddo
-              IAN2(ROW+1) = ELEM_CSR
+              ian2(row+1) = elem_csr
-            ENDDO
+            enddo
-          ENDIF
+          endif
 
           if (debug) write(0,*)'Done Rebuild CSR',
      +      ian2(m+1),ia(elem)
-          if (debug) then 
+c$$$          if (debug) then 
-            do i=ian2(m+1), nnz
+c$$$            do i=ian2(m+1), nnz
-              write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
+c$$$              write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
-            enddo
+c$$$            enddo
-          endif
+c$$$          endif
 
-        ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
-          DO 20 K = 1, M
+          do 20 k = 1, m
-            P2(K) = K
+            p2(k) = k
- 20       CONTINUE
+ 20       continue
 
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
+        else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
-C       .... Order with key IA ...
+
-          CALL MSORT_UP(NNZ,IA,AUX,IRET)
+            call msort_up(nnz,itmp,aux,iret)
-          IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
+            if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
-C       .... Order with key IA2N ...
+C       .... Order with key JA ...
-          I    = 1
+            i    = 1
-          J    = I
+            j    = i
-c$$$            DO WHILE (I.LE.NNZ)
+            do 
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
+              if (i>nnz) exit
-c$$$     +          (J.LE.NNZ))
+              do
-          DO 
-            if (I>NNZ) exit
-            DO
                 if (j>nnz) exit
-              if (ia(j) /= ia(i)) exit
+                if (itmp(j) /= itmp(i)) exit
-              J = J+1
+                j = j+1
-            ENDDO
+              enddo
-            NZL = J - I
+              nzl = j - i
-            CALL MSORT_UP(NZL,JA(I),AUX,IRET)
+              call msort_up(nzl,ian1(i),aux,iret)
-            IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
+              if (iret.eq.0)
-            I = J
+     +          call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
-          ENDDO
+              i = j
+            enddo
+
 
 
 C        ... Construct CSR Representation...
-          ELEM = 1
+            elem = 1
-          ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-          DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-            IAN2(ROW) = 1
+              ian2(row) = 1
-          ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-          IF(JA(ELEM).GT.IA(ELEM)) THEN
+            ian1(elem_csr) = ian1(elem)
-            IAN1(ELEM_CSR) = JA(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
-          ENDIF
-
-          ELEM = ELEM+1
-
 C        ... Insert remaining element ...
-          DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$  if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-            DO 
                 if (elem > nnz) exit
-              if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-              IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C     ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else if (ian1(elem).ne.ian1(elem-1)) then
-                ENDIF
-              ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
 C                 ... Insert other element of row ...
-                IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else
-                ENDIF
+                  if (check_flag.eq.psb_dupl_err_) then
-              ELSE
+c     ... error, there are duplicated elements ...
-                IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                    ierror = 130
-C     ... Error, there are duplicated elements ...
+                    call fcpsb_errpush(ierror,name,int_val)
-                  IERROR = 130
+                    goto 9999
-                  CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-                  GOTO 9999
+c                    ... insert only the last duplicated element ...
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                    arn(elem_csr-1) = arn(elem)
-C     ... Insert only the last duplicated element ...
+                    if (debug) write(0,*) 'Duplicated overwrite srch',
-                  IF(JA(ELEM).GT.IA(ELEM)) THEN                   
-                    ARN(ELEM_CSR-1) = AR(ELEM)
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated overwrite',
      +                elem_csr-1,elem
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C     ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                  IF(JA(ELEM).GT.IA(ELEM)) THEN                   
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    if (debug) write(0,*) 'Duplicated add srch',
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated add',
      +                elem_csr-1,elem
-                END IF
-              ENDIF
-              ELEM = ELEM + 1
-            ENDDO
-            IAN2(ROW+1) = ELEM_CSR
-          ENDDO
-
-          
-          if (debug) write(0,*)'Done Rebuild CSR',
-     +      ian2(m+1),ia(elem)
-          if (debug) then 
-            do i=ian2(m+1), nnz
-              write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
-            enddo
                   end if
+                endif
+                elem = elem + 1
+              enddo
+              ian2(row+1) = elem_csr
+            enddo
           
+        else if (toupper(descra(1:1)).EQ.'T' .AND.
+     +        toupper(DESCRA(2:2)).EQ.'L') THEN
+
+            call msort_up(nnz,itmp,aux,iret)
+            if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
+C       .... Order with key JA ...
+            i    = 1
+            j    = i
+            do 
+              if (i>nnz) exit
+              do
+                if (j>nnz) exit
+                if (itmp(j) /= itmp(i)) exit
+                j = j+1
+              enddo
+              nzl = j - i
+              call msort_up(nzl,ian1(i),aux,iret)
+              if (iret.eq.0)
+     +          call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
+              i = j
+            enddo
 
 
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
-
-C       .... Order with key IA ...
-          CALL MSORT_UP(NNZ,IA,AUX,IRET)
-          IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
-C       .... Order with key IA2N ...
-          I    = 1
-          J    = I
-c$$$            DO WHILE (I.LE.NNZ)
-c$$$              DO WHILE ((IA(J).EQ.IA(I)).AND.
-c$$$     +          (J.LE.NNZ))
-          DO 
-            if (I>NNZ) exit
-            DO
-              if (j>nnz) exit
-              if (ia(j) /= ia(i)) exit
-              J = J+1
-            ENDDO
-            NZL = J - I
-            CALL MSORT_UP(NZL,JA(I),AUX,IRET)
-            IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
-            I = J
-          ENDDO
 
 C        ... Construct CSR Representation...
-          ELEM = 1
+            elem = 1
-          ELEM_CSR = 1
+            elem_csr = 1
 C        ... Insert first element ...
-          DO ROW = 1, IA(1)
+            do row = 1, itmp(1)
-            IAN2(ROW) = 1
+              ian2(row) = 1
-          ENDDO
+            enddo
             if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
-          IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+            ian1(elem_csr) = ian1(elem)
-            IAN1(ELEM_CSR) = JA(ELEM)
+            arn(elem_csr)  = arn(elem)
-            ARN(ELEM_CSR) = AR(ELEM)
+            elem = elem+1
-            ELEM_CSR = ELEM_CSR+1
+            elem_csr = elem_csr+1
-          ENDIF
-          ELEM = ELEM+1
-          
 C        ... Insert remaining element ...
-          DO ROW = IA(1), M
+            do row = itmp(1), m
-c$$$              if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
+              do 
-c$$$              DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
-            DO 
                 if (elem > nnz) exit
-              if (ia(elem) /= row) exit
+                if (itmp(elem) /= row) exit
-              IF (IA(ELEM).NE.IA(ELEM-1)) THEN
+                if (itmp(elem).ne.itmp(elem-1)) then
-C     ... Insert first element of a row ...
+c                 ... insert first element of a row ...
-                IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else if (ian1(elem).ne.ian1(elem-1)) then
-                ENDIF
-              ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
 C                 ... Insert other element of row ...
-                IF(JA(ELEM).LT.IA(ELEM)) THEN                               
+                  ian1(elem_csr) = ian1(elem)
-                  IAN1(ELEM_CSR) = JA(ELEM)
+                  arn(elem_csr)  = arn(elem)
-                  ARN(ELEM_CSR) = AR(ELEM)
+                  elem_csr = elem_csr+1
-                  ELEM_CSR = ELEM_CSR+1
+                else
-                ENDIF
+                  if (check_flag.eq.psb_dupl_err_) then
-              ELSE
+c     ... error, there are duplicated elements ...
-                IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
+                    ierror = 130
-C                    ... Error, there are duplicated elements ...
+                    call fcpsb_errpush(ierror,name,int_val)
-                  IERROR = 130
+                    goto 9999
-                  CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+                  else if (check_flag.eq.psb_dupl_ovwrt_) then
-                  GOTO 9999
+c                    ... insert only the last duplicated element ...
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
+                    arn(elem_csr-1) = arn(elem)
-C                    ... Insert only the last duplicated element ...
+                    if (debug) write(0,*) 'Duplicated overwrite srch',
-                  IF(JA(ELEM).LT.IA(ELEM)) THEN                   
-                    ARN(ELEM_CSR-1) = AR(ELEM)
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated overwrite',
      +                elem_csr-1,elem
-                ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN 
+                  else if (check_flag.eq.psb_dupl_add_) then 
-C                    ... Sum the duplicated element ...
+c                    ... sum the duplicated element ...
-                  IF(JA(ELEM).LT.IA(ELEM)) THEN                   
+                    arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
-                    ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
+                    if (debug) write(0,*) 'Duplicated add srch',
-                  ENDIF
-                  if (debug) write(0,*) 'Duplicated add',
      +                elem_csr-1,elem
-                END IF
+                  end if
-              ENDIF
+                endif
-              ELEM = ELEM + 1
+                elem = elem + 1
-            ENDDO
+              enddo
-            IAN2(ROW+1) = ELEM_CSR
+              ian2(row+1) = elem_csr
-          ENDDO
+            enddo
-
           
           if (debug) write(0,*)'Done Rebuild CSR',
      +      ian2(m+1),ia(elem)
@@ -531,29 +501,29 @@ C                    ... Sum the duplicated element ...
           endif
 
 
-        END IF
+        end if
-C
+c
-      ELSE IF (TRANS.NE.'N') THEN
+      else if (toupper(TRANS).NE.'N') then
-C
+c
-C           TO DO
+c           to do
-C
+c
-        IERROR = 3021
+        ierror = 3021
-        CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
+        call fcpsb_errpush(ierror,name,int_val)
-        GOTO 9999
+        goto 9999
 
-      END IF
+      end if
-      INFON(1)=ELEM_CSR-1
+      infon(1)=elem_csr-1
 
-      CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
+      call fcpsb_erractionrestore(err_act)
-      RETURN
+      return
 
- 9999 CONTINUE
+ 9999 continue
-      CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
+      call fcpsb_erractionrestore(err_act)
 
-      IF ( ERR_ACT .NE. 0 ) THEN 
+      if ( err_act .ne. 0 ) then 
-        CALL FCPSB_SERROR()
+        call fcpsb_serror()
-        RETURN
+        return
-      ENDIF
+      endif
 
-      RETURN
+      return
-      END
+      end

base/serial/dp/zcrco.f

@@ -34,6 +34,7 @@ C
 
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -63,8 +64,8 @@ C
       IERROR = 0
       CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
 
-      IF (TRANS.EQ.'N') THEN
+      IF (toupper(TRANS).EQ.'N') THEN
-        SCALE  = (UNITD.EQ.'L') ! meaningless
+        SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
         IP1(1) = 0
         IP2(1) = 0
         NNZ = IA2(M+1)-1
@@ -90,7 +91,7 @@ C
           GOTO 9999
         END IF
         
-        IF (DESCRA(1:1).EQ.'G') THEN
+        IF (toupper(DESCRA(1:1)).EQ.'G') THEN
 C        ... Construct COO Representation...
           ELEM = 1
 
@@ -103,7 +104,8 @@ C        ... Construct COO Representation...
             ENDDO
           ENDDO
           INFON(psb_nnz_) = IA2(M+1)-1
-        ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
           DO 20 K = 1, M
             IP2(K) = K
@@ -113,14 +115,16 @@ C        ... Construct COO Representation...
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
 C
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 
 C
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
           goto 9999
 
-        ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'L') THEN
 
           ierror = 3021
           call fcpsb_errpush(ierror,name,int_val)
@@ -128,7 +132,7 @@ C
 
         END IF
 C
-      ELSE IF (TRANS.NE.'N') THEN
+      ELSE IF (toupper(TRANS).NE.'N') THEN
 C
 C           TO DO
 C     

base/serial/dp/zcrcr.f

@@ -163,6 +163,7 @@ C
       SUBROUTINE ZCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1,
      *  DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2,
      *  WORK,LWORK,IERROR)
+      use psb_string_mod
       IMPLICIT NONE                                                      
 C
 C     .. Scalar Arguments ..
@@ -177,6 +178,7 @@ C     .. Local Scalars ..
       INTEGER          I, J, ERR_ACT
       LOGICAL          EXIT
 c     .. Local Arrays ..
+      character  idescra*11
       CHARACTER*20       NAME
       INTEGER            INT_VAL(5)
 
@@ -192,11 +194,12 @@ C
 C
 C       Check for argument errors
 C
-      IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      idescra=toupper(descra)
-     &   DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B'))  .OR.
+      IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
-     &   (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR.
+     &  IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .NE. 'B'))  .OR.
-     +  (DESCRA(3:3).EQ.'U'))) .OR.
+     &  (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR.
-     +  TRANS.NE.'N') THEN
+     +  (IDESCRA(3:3).EQ.'U'))) .OR.
+     +  toupper(TRANS).NE.'N') THEN
         IERROR = 20
       ENDIF
       IF(LAN.LT.(IA2(M+1)-1)) THEN
@@ -223,8 +226,8 @@ C
           IERROR = 23
         ENDIF
       ENDIF
-      IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
-     &     DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
+     &  IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
         IF (LWORK.LT.M) THEN
           IF     (LWORK.LE.0) THEN
             EXIT=.TRUE.
@@ -250,7 +253,7 @@ C
 C
 C     Set DESCRN, IP1, IP2
 C
-      DESCRN(1:3) = DESCRA(1:3)
+      DESCRN(1:3) = IDESCRA(1:3)
 
       IP1(1)=0
       IP2(1)=0
@@ -260,8 +263,8 @@ C
       DO 20 I = 1, M+1
         IAN2(I) = IA2(I)
  20   CONTINUE
-      IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
+      IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
-     &     DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
+     &  IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
         DO 30 I = 1, M
           WORK(I) = DBLE(DSQRT(ABS(D(I))))
  30     CONTINUE
@@ -271,21 +274,21 @@ C
             IAN1(J) = IA1(J)
  50       CONTINUE
  40     CONTINUE
-      ELSE IF (UNITD .EQ. 'L') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'L') THEN
         DO 60 I = 1, M
           DO 70 J = IA2(I), IA2(I+1)-1
             AN(J)   = D(I) * A(J)
             IAN1(J) = IA1(J)
  70       CONTINUE
  60     CONTINUE
-      ELSE IF (UNITD .EQ. 'R') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'R') THEN
         DO 80 I = 1, M
           DO 90 J = IA2(I), IA2(I+1)-1
             AN(J)   = A(J) * D(IA1(J))
             IAN1(J) = IA1(J)
  90       CONTINUE
  80     CONTINUE
-      ELSE IF (UNITD .EQ. 'U') THEN
+      ELSE IF (toupper(UNITD) .EQ. 'U') THEN
         DO 100 J = 1, IA2(M+1)-1
           AN(J)   = A(J)
           IAN1(J) = IA1(J)

base/serial/dp/zcrjd.f

@@ -61,6 +61,7 @@ C     IAN2,INFON, IP1, IP2
 C   
       use psb_const_mod
       use psb_spmat_type
+      use psb_string_mod
       IMPLICIT NONE
 
 C
@@ -103,10 +104,10 @@ C
          GOTO 9999
       ENDIF
 
-      IF (TRANS.EQ.'N') THEN
+      IF (toupper(TRANS).EQ.'N') THEN
 C
         NJA    = 3*M
-        SCALE  = (UNITD.EQ.'L') ! meaningless
+        SCALE  = (toupper(UNITD).EQ.'L') ! meaningless
         IOFF   = 5
 C
 C        SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX
@@ -115,7 +116,7 @@ C
         PIA    = PNG + 1
         PJA    = PIA + 3*(M+2)
 
-        IF (DESCRA(1:1).EQ.'G') THEN
+        IF (toupper(DESCRA(1:1)).EQ.'G') THEN
 
 C
 C        CHECK ON DIMENSION OF IAN2 AND AUX
@@ -169,9 +170,10 @@ C
           ENDIF
 
           LJA = LIAN2-PJA
-          CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), 
+          CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,info,
-     +         IAN2(PJA), INFON, LARN,LIAN1,
+     +      ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON,
-     +         LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR)
+     +      LARN,LIAN1, LJA,IP1,
+     +      AUX, LAUX*2, SIZE_REQ,IERROR)
           
           IF (IERROR.NE.0) THEN
              CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
@@ -182,7 +184,8 @@ C
           DESCRN(2:2) = 'U'
           DESCRN(3:3) = 'N'
 
-        ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+     +      toupper(DESCRA(2:2)).EQ.'U') THEN
 C
           ISTROW = 1
           NZ     = 2*(IA2(M+1)-1) - M
@@ -218,13 +221,13 @@ c$$$            CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
 c$$$     *                 IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
 c$$$     *                 AUX(IWORK2),NJA,IER,SCALE)
 C
-        ELSE IF (DESCRA(1:1).EQ.'T') THEN
+        ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN
 C
 C  Only unit diagonal so far for triangular matrices. 
 C
 
 
-          IF (DESCRA(3:3).NE.'U') THEN 
+          IF (toupper(DESCRA(3:3)).NE.'U') THEN 
             IERROR=3022
             CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
             GOTO 9999
@@ -273,8 +276,7 @@ c$$$                write(0,*) "error 2",ierrv(1)
           ENDIF
           
           DESCRN(1:1) = 'T'
-          DESCRN(2:2) = DESCRA(2:2)
+          DESCRN(2:3) = toupper(DESCRA(2:3))
-          DESCRN(3:3) = DESCRA(3:3)
 
         END IF
 C
@@ -288,7 +290,7 @@ C
         LIAN2   = 3*M + 10
         LAUX2   = 4*M + 2
 C
-      ELSE IF (TRANS.NE.'N') THEN
+      ELSE IF (toupper(TRANS).NE.'N') THEN
 C
 C           TO BE DONE
 C

base/serial/dp/zgindex.f

@@ -28,7 +28,7 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 C POSSIBILITY OF SUCH DAMAGE.
 C
 C 
-      SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON,
+      SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON,
      +  LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
 
       use psb_const_mod
@@ -43,12 +43,12 @@ C     ... Array arguments ...
 
       complex(kind(1.d0))  A(*), ARN(*)
       INTEGER          IA1(*), IA2(*), KA(*), 
-     +  IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*)
+     +  IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*), infoa(*)
       
 C     .... Local scalars ...
       INTEGER          I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1,
      +  IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
-     +  ERR_ACT
+     +  ERR_ACT, ix, regen_flag
       LOGICAL          CSR
 c     .. Local Arrays ..
       CHARACTER*20       NAME
@@ -61,6 +61,8 @@ c     .. Local Arrays ..
       POINT_AR = 1
       POINT_JA = 0
       call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
+      call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
+
 
       IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
         IERROR = 60
@@ -81,7 +83,9 @@ C     .... Invert Permutation Matrix...
         ENDDO
       ENDIF
 
-      IF ( (LKA .GE.( SIZE_REQ ))  
+      size_Req=0
+
+      IF ( (regen_flag == psb_upd_perm_)
      +  .AND. (LWORK .GE. (M + NNZ+2))) THEN
 C     
 C     Prepare for smart regeneration
@@ -98,15 +102,21 @@ C
         KA(IP1+PSB_NNZT_)    = NNZ
         KA(IP1+PSB_NNZ_)     = 0
         KA(IP1+PSB_ICHK_)    = NNZ+CHECK_FLAG
-        I                = M+2
-        IPX              = IA2(I+PSB_IP2_)
 
+        if (infoa(psb_upd_pnt_) > 0) then 
+          I                    = infoa(psb_upd_pnt_)
+          IPX                  = IA2(I+PSB_IP2_)
 C     Invert permutation for smart regeneration
           
           DO I = 1, NNZ
             WORK(IPW + IA2(IPX + I -1) - 1) = I
           ENDDO
-
+        else
+          ! No permutation available before, set identity.
+          DO I = 1, NNZ
+            WORK(IPW + I  - 1) = I
+          ENDDO
+        endif
 C     Construct JAD matrix...
 
         DO BLOCK = 1, N_BLOCKS
@@ -270,9 +280,19 @@ C     ... For each nnzero elements belonging to current row ...
           ENDDO
         ENDDO
         
+        IA(2,N_BLOCKS+1) = POINT_JA
+        KA(IP1 + PSB_ZERO_) = COUNT
+        
+        IF (POINT_AR.GE.IP1) THEN
+          SIZE_REQ=NNZ+COUNT
+        ELSE
+          SIZE_REQ=0
+        ENDIF        
         
       ELSE
 c$$$  c      write(*,*)'inizio a ciclare sui blocchi'
+        IP1 = LKA - PSB_ZERO_ 
+
         DO BLOCK = 1, N_BLOCKS
           COL = 1
           DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
@@ -415,16 +435,15 @@ C     ... For each nnzero elements belonging to current row ...
         
         
         
-        
-      ENDIF
         IA(2,N_BLOCKS+1) = POINT_JA
-      KA(IP1 + PSB_ZERO_) = COUNT
         
-      IF(POINT_AR.GE.IP1) THEN
+        IF (POINT_AR.GE.lka) THEN
           SIZE_REQ=NNZ+COUNT
         ELSE
           SIZE_REQ=0
         ENDIF        
+      ENDIF
+
       infon(1)=point_ar-1
 
       CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)

base/serial/psb_cest.f90

@@ -34,13 +34,14 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
   use psb_const_mod
   use psb_string_mod
   use psb_spmat_type
+
   implicit none
 
   !     .. scalar arguments ..
   integer, intent(in) ::  m,n,nnz,iup
   integer, intent(out) :: lia1, lia2, lar, info
+  character(len=*), intent(inout)  ::  afmt
   !     .. array arguments..
-  character(len=5)  ::  afmt
   integer           ::  int_val(5), err_act
   character(len=20) ::  name
 
@@ -51,17 +52,19 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
     afmt = psb_fidef_
   endif
   
+  afmt = toupper(afmt)
+
   select case(iup)
   case (psb_upd_perm_)
-    if (toupper(afmt) == 'JAD') then 
+    if (afmt == 'JAD') then 
-      lia1 = 2*(nnz + nnz/5) +1000
+      lia1 = 2*(nnz) + 1000
-      lia2 = 2*(nnz + nnz/5) +1000 +m
+      lia2 = (3*nnz)/2 + 1000 + m
-      lar = nnz + nnz/5
+      lar  = (3*nnz)/2 
-    else if (toupper(afmt) == 'COO') then 
+    else if (afmt == 'COO') then 
       lia1 = nnz
       lia2 = 2*nnz + 1000
       lar = nnz
-    else if(toupper(afmt) == 'CSR') then
+    else if(afmt  == 'CSR') then
       lia1 = nnz
       lia2 = 2*nnz + 1000 + m + 1
       lar = nnz
@@ -71,17 +74,17 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
       goto 9999
     endif
 
-  case (psb_upd_dflt_, psb_upd_srch_)
+  case (psb_upd_srch_)
 
-    if (toupper(afmt) == 'JAD') then 
+    if (afmt == 'JAD') then 
-      lia1 = nnz + nnz/5
+      lia1 = (3*nnz)/2 
-      lia2 = nnz + nnz/5
+      lia2 = (3*nnz)/2 
-      lar = nnz + nnz/5
+      lar  = (3*nnz)/2 
-    else if (toupper(afmt) == 'COO') then 
+    else if (afmt == 'COO') then 
       lia1 = nnz
       lia2 = nnz
       lar = nnz
-    else if(toupper(afmt) == 'CSR') then
+    else if(afmt == 'CSR') then
       lia1 = nnz
       lia2 = max(nnz,m+1)
       lar = nnz

base/serial/psb_dcoins.f90

@@ -38,7 +38,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
   use psb_realloc_mod
   use psb_string_mod
   use psb_error_mod
-  use psb_serial_mod, only : psb_csdp
+  use psb_serial_mod, psb_protect_name => psb_dcoins
   use psb_update_mod
   implicit none 
 
@@ -156,8 +156,12 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
       case (psb_upd_perm_)
         ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)      
         nzl = psb_sp_getifld(psb_del_bnd_,a,info)      
+        select case(ufida)
+        case ('JAD')
+          nza = a%ia1(ip1+psb_nnz_)
+        case default
           nza = a%ia2(ip1+psb_nnz_)
-
+        end select
 
         call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
              & imin,imax,jmin,jmax,nzl,info,gtl,ng)
@@ -172,11 +176,17 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
             write(0,*) 'PSB_COINS: update discarded items '
           end if
         end if
+
+        select case(ufida)
+        case ('JAD')
+          a%ia1(ip1+psb_nnz_) = nza
+        case default
           a%ia2(ip1+psb_nnz_) = nza
+        end select
 
         if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
 
-      case (psb_upd_dflt_, psb_upd_srch_)
+      case (psb_upd_srch_)
 
         call  psb_srch_upd(nz,ia,ja,val,nza,a,&
              & imin,imax,jmin,jmax,nzl,info,gtl,ng)
@@ -187,8 +197,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
                  &  'COINS: Going through rebuild_ fingers crossed!'
             irst = info
             call psb_nullify_sp(tmp)
-            tmp%fida='COO'
+            call psb_spcnv(a,tmp,info,afmt='coo')
-            call psb_csdp(a,tmp,info)
             if(info /= izero) then
               info=4010
               ch_err='psb_csdp'
@@ -349,7 +358,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
 
         if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
 
-      case (psb_upd_dflt_, psb_upd_srch_)
+      case (psb_upd_srch_)
 
         call  psb_srch_upd(nz,ia,ja,val,nza,a,&
              & imin,imax,jmin,jmax,nzl,info)
@@ -360,8 +369,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
                  &  'COINS: Going through rebuild_ fingers crossed!'
             irst = info
             call psb_nullify_sp(tmp)
-            tmp%fida='COO'
+            call psb_spcnv(a,tmp,info,afmt='coo')
-            call psb_csdp(a,tmp,info)
             call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
             if (debug) then
               write(0,*) 'COINS  Rebuild: size',tmp%infoa(psb_nnz_) ,irst            
@@ -429,7 +437,6 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
   endif
 
 
-  return
 
   call psb_erractionrestore(err_act)
   return

base/serial/psb_dcsdp.f90

@@ -1,515 +0,0 @@
-!!$ 
-!!$              Parallel Sparse BLAS  v2.0
-!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
-!!$                       Alfredo Buttari        University of Rome Tor Vergata
-!!$ 
-!!$  Redistribution and use in source and binary forms, with or without
-!!$  modification, are permitted provided that the following conditions
-!!$  are met:
-!!$    1. Redistributions of source code must retain the above copyright
-!!$       notice, this list of conditions and the following disclaimer.
-!!$    2. Redistributions in binary form must reproduce the above copyright
-!!$       notice, this list of conditions, and the following disclaimer in the
-!!$       documentation and/or other materials provided with the distribution.
-!!$    3. The name of the PSBLAS group or the names of its contributors may
-!!$       not be used to endorse or promote products derived from this
-!!$       software without specific written permission.
-!!$ 
-!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
-!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!!$  POSSIBILITY OF SUCH DAMAGE.
-!!$ 
-!!$  
-! File:  psb_dcsdp.f90 
-!
-! Subroutine: psb_dcsdp
-!    This subroutine performs the assembly of
-!    the local part of a sparse distributed matrix
-!
-! Parameters:
-!   a      -  type(<psb_spmat_type>).         The input matrix to be assembled.
-!   b      -  type(<psb_spmat_type>).         The assembled output matrix.
-!   info   -  integer.                        Eventually returns an error code.
-!   ifc    -  integer(optional).              ???
-!   check  -  character(optional).            ???
-!   trans  -  character(optional).            ???
-!   unitd  -  character(optional).            ???
-!
-subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl)
-  use psb_const_mod
-  use psb_error_mod
-  use psb_spmat_type
-  use psb_string_mod
-  use psb_serial_mod, psb_protect_name => psb_dcsdp
-  implicit none
-  !....Parameters...
-  Type(psb_dspmat_type), intent(in)    :: A
-  Type(psb_dspmat_type), intent(inout) :: B
-  Integer, intent(out)                 :: info
-  Integer, intent(in), optional        :: ifc,upd,dupl
-  character, intent(in), optional      :: check,trans,unitd
-
-  !...Locals...
-  real(kind(1.d0))              :: d(1)
-  real(kind(1.d0)), allocatable :: work(:)
-  type(psb_dspmat_type)         :: temp_a
-  Integer                       :: nzr, ntry, ifc_, ia1_size,&
-       & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
-  integer                       :: ip1, ip2, nnz, iflag, ichk, nnzt,&
-       & ipc, i, count, err_act, i1, i2, ia
-  character                     :: check_,trans_,unitd_
-  Integer, Parameter            :: maxtry=8
-  logical, parameter            :: debug=.false.
-  character(len=20)             :: name, ch_err
-
-  name='psb_csdp'
-  info  = 0
-  call psb_erractionsave(err_act)
-
-  ntry=0
-  if (present(ifc)) then 
-    ifc_  = max(1,ifc)
-  else 
-    ifc_ = 1
-  endif
-  if (present(check)) then 
-    check_ = toupper(check)
-  else 
-    check_ = 'N'
-  endif
-  if (present(trans)) then 
-    trans_ = toupper(trans)
-  else 
-    trans_ = 'N'
-  endif
-  if (present(unitd)) then 
-    unitd_ = toupper(unitd)
-  else 
-    unitd_ = 'U'
-  endif
-
-
-  if (check_=='R') then 
-    allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info)
-  else
-    allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
-  endif
-
-  if (info /= 0) then
-    info=2040
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-  if (ifc_<1) then 
-    write(0,*) 'csdp90 Error: invalid ifc ',ifc_
-    info = -4
-    call psb_errpush(info,name)
-    goto 9999
-  endif
-
-  if((check_=='Y').or.(check_=='C')) then
-    if(toupper(a%fida(1:3))=='CSR') then
-      call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
-      if(info /= 0) then
-        info=4010
-        ch_err='dcsrck'
-        call psb_errpush(info,name,a_err=ch_err)
-        goto 9999
-      end if
-
-    else
-      write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3)
-    end if
-
-  end if
-
-  if (check_/='R') then
-    
-    if (present(upd)) then 
-      call psb_sp_setifld(upd,psb_upd_,b,info)    
-    end if
-    if (present(dupl)) then 
-      call psb_sp_setifld(dupl,psb_dupl_,b,info)    
-    end if
-    
-    upd_ = psb_sp_getifld(psb_upd_,b,info)
-    select case(upd_)
-    case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_)
-      ! Legal value, do nothing
-    case default
-      ! Fix bad value
-      upd_ = psb_upd_dflt_
-      call psb_sp_setifld(upd_,psb_upd_,b,info)    
-    end select
-    dupl_ = psb_sp_getifld(psb_dupl_,b,info)
-    select case(dupl_)
-    case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
-      ! Legal value, do nothing
-    case default
-      ! Fix bad value
-      dupl_ = psb_dupl_def_
-      call psb_sp_setifld(dupl_,psb_dupl_,b,info)    
-    end select
-    
-    !  ...matrix conversion...
-    b%m=a%m
-    b%k=a%k
-    size_req = psb_sp_get_nnzeros(a)
-    if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
-    !
-    
-    n_row=b%m 
-    n_col=b%k
-    call psb_cest(b%fida, n_row,n_col,size_req,&
-         & ia1_size, ia2_size, aspk_size, upd_,info)
-
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_cest'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-    if (.not.allocated(b%aspk).or.&
-         &.not.allocated(b%ia1).or.&
-         &.not.allocated(b%ia2).or.&
-         &.not.allocated(b%pl).or.&
-         &.not.allocated(b%pr)) then
-      call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
-    else if ((size(b%aspk)  < aspk_size) .or.&
-         &(size(b%ia1) < ia1_size) .or.&
-         &(size(b%ia2) < ia2_size) .or.&
-         &(size(b%pl)  < b%m) .or.&
-         &(size(b%pr) < b%k )) then 
-      call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
-    endif
-
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_sp_reall'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-
-    b%pl(:)  = 0
-    b%pr(:)  = 0
-
-    b%descra = a%descra
-
-    select case (toupper(a%fida(1:3)))
-
-    case ('CSR')
-
-      select case (toupper(b%fida(1:3)))
-
-      case ('CSR')
-
-        call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, size(work), info)
-
-
-        if (info/=0) then
-          info=4010
-          ch_err='dcrcr'
-          call psb_errpush(info,name,a_err=ch_err)
-          goto 9999
-        end if
-
-      case ('JAD')
-
-        !...converting to JAD
-        !...output matrix may not be big enough
-        do
-
-          call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-               & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-               & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-               & size(b%ia2), work, size(work), nzr, info)
-          if (info /= 0) then
-            call psb_errpush(4010,name,a_err='dcrjd')
-            goto 9999
-          endif
-
-          ntry = ntry + 1
-          if (debug) then 
-            write(0,*) 'On out from dcrjad ',nzr,info
-          end if
-          if (nzr == 0) exit
-          if (ntry > maxtry ) then 
-            write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-          call psb_sp_reall(b,nzr,info,ifc=ifc_)
-          if (info /= 0) then
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-        end do
-
-        if (info/=0) then
-          call psb_errpush(info,name)
-          goto 9999
-        end if
-
-      case ('COO')
-        if (debug) write(0,*) 'Calling CRCO ',a%descra
-        call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcrco')
-          goto 9999
-        end if
-      case default
-        info=4010
-        call psb_errpush(info,name)
-        goto 9999
-        
-      end select
-
-    case ('COO','COI')
-
-      select case (toupper(b%fida(1:3)))
-
-      case ('CSR')
-
-        call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, 2*size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcocr')
-          goto 9999
-        end if
-
-      case ('JAD')
-
-        call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
-        if (info /= 0) then
-          info=2040
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-        temp_a%m = a%m
-        temp_a%k = a%k
-
-        !...Dirty trick: converting to CSR and then to JAD
-
-        call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
-             & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
-             & size(temp_a%aspk), size(temp_a%ia1),&
-             & size(temp_a%ia2), work, 2*size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcocr')
-          goto 9999
-        end if
-
-        do
-          call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
-               & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
-               & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
-               & size(b%aspk), size(b%ia1),&
-               & size(b%ia2), work, size(work), nzr, info)
-          if (info/=0) then
-            call psb_errpush(4010,name,a_err='dcrjd')
-            goto 9999
-          end if
-
-          ntry = ntry + 1
-          if (debug) then 
-            write(0,*) 'On out from dcrjad ',nzr,info
-          end if
-          if (nzr == 0) exit
-          if (ntry > maxtry ) then 
-            write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
-                 & ': giving up now.'
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-          call psb_sp_reall(b,nzr,info,ifc=ifc_)
-          if (info /= 0) then
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-        end do
-
-      case ('COO')
-
-        call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, 2*size(work), info)
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcoco')
-          goto 9999
-        end if
-
-      case default
-        info=4010
-        call psb_errpush(info,name)
-        goto 9999
-      end select
-
-    case default
-      info=4010
-      call psb_errpush(info,name)
-      goto 9999
-
-    end select
-
-    if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
-         &      call psb_sp_trim(b,info)
-
-  else if (check_=='R') then
-
-    !...Regenerating matrix    
-
-    if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then 
-      info = 8888
-      call psb_errpush(info,name)
-      goto 9999
-    endif
-
-    !
-    !   dupl_ and upd_ fields should not be changed. 
-    !
-    select case(psb_sp_getifld(psb_upd_,b,info))
-
-    case(psb_upd_perm_)
-      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
-      if (toupper(b%fida(1:3))/='JAD') then
-        ip1   = psb_sp_getifld(psb_upd_pnt_,b,info) 
-        ip2   = b%ia2(ip1+psb_ip2_)
-        nnz   = b%ia2(ip1+psb_nnz_)
-        iflag = b%ia2(ip1+psb_iflag_)
-        ichk  = b%ia2(ip1+psb_ichk_)
-        nnzt  = b%ia2(ip1+psb_nnzt_)
-        if (debug) write(*,*) 'Regeneration start: ',&
-             &   b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
-
-        if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
-          info = 8889
-          write(*,*) 'Regeneration start error: ',&
-               &   b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk                    
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-        do i= 1, nnz
-          work(i) = 0.d0
-        enddo
-        select case(iflag) 
-        case(psb_dupl_ovwrt_,psb_dupl_err_) 
-          do i=1, nnz 
-            work(b%ia2(ip2+i-1)) = b%aspk(i) 
-          enddo
-        case(psb_dupl_add_) 
-          do i=1, nnz 
-            work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) 
-          enddo
-        case default
-          info = 8887
-          call psb_errpush(info,name)
-          goto 9999          
-        end select
-
-        do i=1, nnz
-          b%aspk(i) = work(i)
-        enddo
-
-      else if (toupper(b%fida(1:3)) == 'JAD') then
-
-
-        ip1   = psb_sp_getifld(psb_upd_pnt_,b,info) 
-        ip2   = b%ia1(ip1+psb_ip2_)
-        count = b%ia1(ip1+psb_zero_)
-        ipc   = b%ia1(ip1+psb_ipc_)
-        nnz   = b%ia1(ip1+psb_nnz_)
-        iflag = b%ia1(ip1+psb_iflag_)
-        ichk  = b%ia1(ip1+psb_ichk_)
-        nnzt  = b%ia1(ip1+psb_nnzt_)
-        if (debug) write(*,*) 'Regeneration start: ',&
-             &  b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
-             &  iflag,info
-
-        if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
-          info = 10
-          write(*,*) 'Regeneration start error: ',&
-               &  b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk     
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-
-        do i= 1, nnz+count
-          work(i) = 0.d0
-        enddo
-        select case(iflag) 
-        case(psb_dupl_ovwrt_,psb_dupl_err_) 
-          do i=1, nnz 
-            work(b%ia1(ip2+i-1)) = b%aspk(i) 
-          enddo
-        case(psb_dupl_add_) 
-          do i=1, nnz 
-            work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) 
-          enddo
-        case default
-          info = 8887
-          call psb_errpush(info,name)
-          goto 9999          
-        end select
-
-        do i=1, nnz+count 
-          b%aspk(i) = work(i)
-        enddo
-        do i=1, count
-          b%aspk(b%ia1(ipc+i-1)) = 0.d0
-        end do
-      endif
-
-    case(psb_upd_dflt_,psb_upd_srch_)
-      ! Nothing to be done  here. 
-      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
-    case default
-      ! Wrong value
-      info = 8888
-      call psb_errpush(info,name)
-      goto 9999
-
-    end select
-  end if
-  call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_erractionrestore(err_act)
-  if (err_act.eq.psb_act_abort_) then
-    call psb_error()
-    return
-  end if
-  return
-
-end subroutine psb_dcsdp

base/serial/psb_dfixcoo.f90

@@ -32,10 +32,12 @@
 ! Subroutine: 
 ! Parameters:
 
-Subroutine psb_dfixcoo(A,INFO,idir)
+subroutine psb_dfixcoo(a,info,idir)
   use psb_spmat_type
   use psb_const_mod
   use psb_string_mod
+  use psb_serial_mod, psb_protect_name => psb_dfixcoo
+  use psb_error_mod
   implicit none
 
   !....Parameters...
@@ -45,11 +47,14 @@ Subroutine psb_dfixcoo(A,INFO,idir)
 
   integer, allocatable :: iaux(:)
   !locals
-  Integer              :: nza, nzl,iret,idir_
+  Integer              :: nza, nzl,iret,idir_, dupl_
-  integer              :: i,j, irw, icl
+  integer              :: i,j, irw, icl, err_act
   logical, parameter   :: debug=.false.
+  character(len=20)    :: name = 'psb_fixcoo'
 
   info  = 0
+  call psb_erractionsave(err_act)
+
   if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2)
   if (toupper(a%fida) /= 'COO') then 
     write(0,*) 'Fixcoo Invalid input ',a%fida
@@ -62,9 +67,11 @@ Subroutine psb_dfixcoo(A,INFO,idir)
     idir_ = 0
   endif
 
-  nza = a%infoa(psb_nnz_)
+  nza = psb_sp_getifld(psb_nnz_,a,info)
   if (nza < 2) return
 
+  dupl_ = psb_sp_getifld(psb_dupl_,a,info)
+
   allocate(iaux(nza+2),stat=info) 
   if (info /= 0) return
 
@@ -92,6 +99,27 @@ Subroutine psb_dfixcoo(A,INFO,idir)
     irw = a%ia1(i)
     icl = a%ia2(i)
     j = 1
+
+    select case(dupl_)
+    case(psb_dupl_ovwrt_)
+
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          a%aspk(i) = a%aspk(j)
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    case(psb_dupl_add_)
+
       do 
         j = j + 1
         if (j > nza) exit
@@ -106,8 +134,26 @@ Subroutine psb_dfixcoo(A,INFO,idir)
           icl = a%ia2(i) 
         endif
       enddo
-    a%infoa(psb_nnz_) = i    
+
-    a%infoa(psb_srtd_) = psb_isrtdcoo_
+    case(psb_dupl_err_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          call psb_errpush(130,name)          
+          goto 9999
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    end select
+
 
     if(debug) write(0,*)'FIXCOO: end second loop'
 
@@ -133,6 +179,26 @@ Subroutine psb_dfixcoo(A,INFO,idir)
     irw = a%ia1(i)
     icl = a%ia2(i)
     j = 1
+
+
+    select case(dupl_)
+    case(psb_dupl_ovwrt_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          a%aspk(i) = a%aspk(j)
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    case(psb_dupl_add_)
       do 
         j = j + 1
         if (j > nza) exit
@@ -147,14 +213,45 @@ Subroutine psb_dfixcoo(A,INFO,idir)
           icl = a%ia2(i) 
         endif
       enddo
-    a%infoa(psb_nnz_) = i    
-    a%infoa(psb_srtd_) = psb_isrtdcoo_
 
+    case(psb_dupl_err_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          call psb_errpush(130,name)
+          goto 9999
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+    end select
     if(debug) write(0,*)'FIXCOO: end second loop'
   case default
     write(0,*) 'Fixcoo: unknown direction ',idir_
   end select
-  a%infoa(psb_upd_) = psb_upd_srch_
+
+  call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info)
+  call psb_sp_setifld(i,psb_nnz_,a,info)
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
+  call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info)
+
   deallocate(iaux)
+
+  call psb_erractionrestore(err_act)
   return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
 end Subroutine psb_dfixcoo

base/serial/psb_dipcoo2csc.f90

@@ -35,7 +35,7 @@
 subroutine psb_dipcoo2csc(a,info,clshr)
   use psb_spmat_type
   use psb_const_mod
-  use psb_serial_mod, only : psb_fixcoo
+  use psb_serial_mod, psb_protect_name => psb_dipcoo2csc
   use psb_error_mod
   use psb_string_mod
   use psb_realloc_mod

base/serial/psb_dipcoo2csr.f90

@@ -36,7 +36,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr)
   use psb_spmat_type
   use psb_const_mod
   use psb_realloc_mod
-  use psb_serial_mod, only : psb_fixcoo
+  use psb_serial_mod, psb_protect_name => psb_dipcoo2csr
   use psb_error_mod
   use psb_string_mod
   implicit none

base/serial/psb_dipcsr2coo.f90

@@ -38,6 +38,7 @@ Subroutine psb_dipcsr2coo(a,info)
   use psb_error_mod
   use psb_string_mod
   use psb_realloc_mod
+  use psb_serial_mod, psb_protect_name => psb_dipcsr2coo
   implicit none
 
   !....Parameters...
@@ -86,6 +87,7 @@ Subroutine psb_dipcsr2coo(a,info)
   a%infoa(psb_upd_) = psb_upd_srch_
 
   deallocate(itemp)
+  call psb_fixcoo(a,info) 
 
   call psb_erractionrestore(err_act)
   return

base/serial/psb_dnumbmm.f90

@@ -71,6 +71,7 @@ subroutine psb_dnumbmm(a,b,c)
       write(0,*) 'Error ',info,' from inner numbmm'
     end if
   end if
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,c,info)
   deallocate(temp) 
   return
 

base/serial/psb_drwextd.f90

@@ -41,6 +41,7 @@ subroutine psb_drwextd(nr,a,info,b,rowscale)
   use psb_spmat_type
   use psb_error_mod
   use psb_string_mod
+  use psb_serial_mod, psb_protect_name => psb_drwextd
   implicit none
 
   ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes)
@@ -66,11 +67,11 @@ subroutine psb_drwextd(nr,a,info,b,rowscale)
 
   if (nr > a%m) then 
     if (toupper(a%fida) == 'CSR') then 
-      call psb_realloc(nr+1,a%ia2,info)
+      call psb_ensure_size(nr+1,a%ia2,info)
       if (present(b)) then 
         nzb = psb_sp_get_nnzeros(b)
-        call psb_realloc(size(a%ia1)+nzb,a%ia1,info)
+        call psb_ensure_size(size(a%ia1)+nzb,a%ia1,info)
-        call psb_realloc(size(a%aspk)+nzb,a%aspk,info)
+        call psb_ensure_size(size(a%aspk)+nzb,a%aspk,info)
         if (toupper(b%fida)=='CSR') then 
 
           do i=1, min(nr-a%m,b%m)

base/serial/psb_dspcnv.f90

@@ -0,0 +1,553 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+! File:  psb_dcsdp.f90 
+!
+! Subroutine: psb_dcsdp
+!    This subroutine performs the assembly of
+!    the local part of a sparse distributed matrix
+!
+! Parameters:
+!   a      -  type(<psb_spmat_type>).         The input matrix to be assembled.
+!   b      -  type(<psb_spmat_type>).         The assembled output matrix.
+!   info   -  integer.                        Eventually returns an error code.
+!   ifc    -  integer(optional).              ???
+!   check  -  character(optional).            ???
+!   trans  -  character(optional).            ???
+!   unitd  -  character(optional).            ???
+!
+subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl)
+  use psb_const_mod
+  use psb_error_mod
+  use psb_spmat_type
+  use psb_string_mod
+  use psb_serial_mod, psb_protect_name => psb_dspcnv2
+  implicit none
+  !....Parameters...
+  Type(psb_dspmat_type), intent(in)      :: A
+  Type(psb_dspmat_type), intent(out)     :: B
+  Integer, intent(out)                   :: info
+  Integer, intent(in), optional          :: upd,dupl
+  character(len=*), optional, intent(in) :: afmt
+
+  !...Locals...
+  real(kind(1.d0))              :: d(1)
+  real(kind(1.d0)), allocatable :: work(:)
+  type(psb_dspmat_type)         :: temp_a
+  Integer                       :: nzr, ntry, ifc_, ia1_size,&
+       & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
+  integer                       :: ip1, ip2, nnz, iflag, ichk, nnzt,&
+       & ipc, i, count, err_act, i1, i2, ia
+  character                     :: check_,trans_,unitd_
+  character(len=5)              :: afmt_
+  Integer, Parameter            :: maxtry=8
+  logical, parameter            :: debug=.false.
+  character(len=20)             :: name, ch_err
+
+  name='psb_spcnv'
+  info  = 0
+  call psb_erractionsave(err_act)
+
+  ntry=0
+  
+  ifc_ = 2
+
+
+  check_ = 'N'
+  trans_ = 'N'
+  unitd_ = 'U'
+  allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
+
+  if (info /= 0) then
+    info=2040
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+
+  if (present(upd)) then 
+    call psb_sp_setifld(upd,psb_upd_,b,info)    
+  end if
+  if (present(dupl)) then 
+    call psb_sp_setifld(dupl,psb_dupl_,b,info)    
+  end if
+  if (present(afmt)) then 
+    afmt_ = afmt
+  else
+    afmt_ = psb_fidef_
+  end if
+
+  upd_ = psb_sp_getifld(psb_upd_,b,info)
+  select case(upd_)
+  case(psb_upd_srch_,psb_upd_perm_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    upd_ = psb_upd_dflt_
+    call psb_sp_setifld(upd_,psb_upd_,b,info)    
+  end select
+
+  dupl_ = psb_sp_getifld(psb_dupl_,b,info)
+  select case(dupl_)
+  case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    dupl_ = psb_dupl_def_
+    call psb_sp_setifld(dupl_,psb_dupl_,b,info)    
+  end select
+
+  !  ...matrix conversion...
+  b%m=a%m
+  b%k=a%k
+  b%fida=afmt_
+  size_req = psb_sp_get_nnzeros(a)
+  if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
+  !
+  n_row=b%m 
+  n_col=b%k
+  call psb_cest(afmt_,n_row,n_col,size_req,&
+       & ia1_size, ia2_size, aspk_size, upd_,info)
+  b%fida=afmt_
+  
+  if (info /= psb_no_err_) then    
+    info=4010
+    ch_err='psb_cest'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  endif
+  if (.not.allocated(b%aspk).or.&
+       &.not.allocated(b%ia1).or.&
+       &.not.allocated(b%ia2).or.&
+       &.not.allocated(b%pl).or.&
+       &.not.allocated(b%pr)) then
+    call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+  else if ((size(b%aspk)  < aspk_size) .or.&
+       &(size(b%ia1) < ia1_size) .or.&
+       &(size(b%ia2) < ia2_size) .or.&
+       &(size(b%pl)  < b%m) .or.&
+       &(size(b%pr) < b%k )) then 
+    call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+  endif
+
+  if (info /= psb_no_err_) then    
+    info=4010
+    ch_err='psb_sp_reall'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  endif
+
+  b%pl(:)  = 0
+  b%pr(:)  = 0
+
+  b%descra = a%descra
+
+  select case (tolower(a%fida))
+
+  case ('csr')
+
+    select case (tolower(b%fida))
+
+    case ('csr')
+
+      call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, size(work), info)
+
+
+      if (info/=0) then
+        info=4010
+        ch_err='dcrcr'
+        call psb_errpush(info,name,a_err=ch_err)
+        goto 9999
+      end if
+
+    case ('jad')
+
+      !...converting to JAD
+      !...output matrix may not be big enough
+      do
+
+        call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+             & size(b%ia2), work, size(work), nzr, info)
+        if (info /= 0) then
+          call psb_errpush(4010,name,a_err='dcrjd')
+          goto 9999
+        endif
+
+        ntry = ntry + 1
+        if (debug) then 
+          write(0,*) 'On out from dcrjad ',nzr,info
+        end if
+        if (nzr == 0) exit
+        if (ntry > maxtry ) then 
+          write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+        call psb_cest(afmt_,n_row,n_col,nzr,&
+             & ia1_size, ia2_size, aspk_size, upd_,info)
+        call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+        if (info /= 0) then
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+      end do
+
+      if (info/=0) then
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+    case ('coo')
+      if (debug) write(0,*) 'Calling CRCO ',a%descra
+      call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcrco')
+        goto 9999
+      end if
+    case default
+      info=4010
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+  case ('coo','coi')
+
+    select case (tolower(b%fida))
+
+    case ('csr')
+
+      call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, 2*size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcocr')
+        goto 9999
+      end if
+
+    case ('jad')
+
+      call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      temp_a%m = a%m
+      temp_a%k = a%k
+      temp_a%infoa=b%infoa
+      !...Dirty trick: converting to CSR and then to JAD
+
+      call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
+           & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
+           & size(temp_a%aspk), size(temp_a%ia1),&
+           & size(temp_a%ia2), work, 2*size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcocr')
+        goto 9999
+      end if
+
+      do
+        call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
+             & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
+             & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
+             & size(b%aspk), size(b%ia1),&
+             & size(b%ia2), work, size(work), nzr, info)
+        if (info/=0) then
+          call psb_errpush(4010,name,a_err='dcrjd')
+          goto 9999
+        end if
+
+        ntry = ntry + 1
+        if (debug) then 
+          write(0,*) 'On out from dcrjad ',nzr,info
+        end if
+        if (nzr == 0) exit
+        if (ntry > maxtry ) then 
+          write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
+               & ': giving up now.'
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+        call psb_sp_reall(b,nzr,info,ifc=ifc_)
+        if (info /= 0) then
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+      end do
+
+    case ('coo')
+
+      call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, 2*size(work), info)
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcoco')
+        goto 9999
+      end if
+
+    case default
+      info=4010
+      call psb_errpush(info,name)
+      goto 9999
+    end select
+
+  case default
+    info=4010
+    call psb_errpush(info,name)
+    goto 9999
+
+  end select
+
+  if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
+       &      call psb_sp_trim(b,info)
+
+
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine psb_dspcnv2
+
+
+subroutine psb_dspcnv1(a, info, afmt, upd, dupl)
+
+  use psb_spmat_type
+  use psb_regen_mod
+  use psb_serial_mod, psb_protect_name => psb_dspcnv1
+  use psb_const_mod
+  use psi_mod
+  use psb_error_mod
+  use psb_string_mod
+  !use psb_penv_mod
+
+  implicit none
+
+
+  !...Parameters....
+  type(psb_dspmat_type), intent (inout)   :: a
+  integer, intent(out)                    :: info
+  integer,optional, intent(in)            :: dupl, upd
+  character(len=*), optional, intent(in)         :: afmt
+
+  integer               :: int_err(5)
+  type(psb_dspmat_type) :: atemp
+  integer               :: np,me,n_col,iout, err_act
+  integer               :: spstate
+  integer               :: upd_, dupl_
+  integer               :: ictxt,n_row
+  logical, parameter    :: debug=.false., debugwrt=.false.
+  character(len=20)     :: name, ch_err
+
+  info = 0
+  int_err(1)=0
+  name = 'psb_spcnv'
+  call psb_erractionsave(err_act)
+
+  if (present(upd)) then 
+    call psb_sp_setifld(upd,psb_upd_,a,info)    
+  end if
+  if (present(dupl)) then 
+    call psb_sp_setifld(dupl,psb_dupl_,a,info)    
+  end if
+
+  upd_ = psb_sp_getifld(psb_upd_,a,info)
+  select case(upd_)
+  case(psb_upd_srch_,psb_upd_perm_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    upd_ = psb_upd_dflt_
+    call psb_sp_setifld(upd_,psb_upd_,a,info)    
+  end select
+
+  dupl_ = psb_sp_getifld(psb_dupl_,a,info)
+  select case(dupl_)
+  case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    dupl_ = psb_dupl_def_
+    call psb_sp_setifld(dupl_,psb_dupl_,a,info)    
+  end select
+
+
+  spstate = psb_sp_getifld(psb_state_,a,info)
+  if (info /= 0) then 
+    goto 9999
+  endif
+  if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
+  if (spstate /= psb_spmat_upd_) then 
+    ! Should we first figure out if we can do it in place? 
+    if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_
+    if (upd_ == psb_upd_srch_) then 
+      if (present(afmt)) then 
+        select case (tolower(a%fida))
+        case('coo')
+          select case(tolower(afmt))
+          case('coo') 
+            call psb_fixcoo(a,info)
+            goto 9998
+          case('csr') 
+            call psb_ipcoo2csr(a,info)
+            goto 9998
+          case('csc')
+            call psb_ipcoo2csc(a,info)
+            goto 9998
+          end select
+        case('csr')
+          select case(tolower(afmt))
+          case('coo') 
+            call psb_ipcsr2coo(a,info)
+            goto 9998
+          end select
+        end select
+      end if
+    end if
+
+    call psb_sp_clone(a,atemp,info)
+    if(info /= psb_no_err_) then
+      info=4010
+      ch_err='psb_sp_clone'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+      ! convert to user requested format after the temp copy
+    end if
+
+    if (debugwrt) then
+      iout = 30+me
+      open(iout)
+      call psb_csprt(iout,atemp,head='Input mat')
+      close(iout)
+    endif
+
+    ! Do the real conversion into the requested storage format
+    ! result is put in A
+    call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl)
+
+    IF (debug) WRITE (*, *) me,'   ASB:  From SPCNV',info,' ',A%FIDA
+    if (info /= psb_no_err_) then    
+      info=4010
+      ch_err='psb_csdp'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    endif
+
+    if (debugwrt) then
+      iout = 60+me
+      open(iout)
+      call psb_csprt(iout,a,head='Output mat')
+      close(iout)
+    endif
+
+    call psb_sp_free(atemp,info)
+
+  else if (spstate == psb_spmat_upd_) then
+    !
+    ! Second  case: we come from an update loop.
+    ! 
+    select case(tolower(a%fida))
+    case('csr')
+      call csr_regen(a,info)
+    case ('coo','coi')
+      call coo_regen(a,info)
+    case('jad')
+      call jad_regen(a,info)
+    case default
+      info=136
+      ch_err=a%fida 
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    end select
+    
+    
+    ! check on error retuned by dcsdp
+    if (info /= psb_no_err_) then
+      info = 4010
+      ch_err='xx_regen'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    end if
+
+  else
+
+    info = 600
+    call psb_errpush(info,name)
+    goto 9999
+    if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
+
+  endif
+
+9998 continue
+
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+  
+end subroutine psb_dspcnv1

base/serial/psb_dspgetrow.f90

@@ -87,21 +87,19 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
     nzin_ = 0
   endif
 
-  if (toupper(a%fida) == 'CSR') then 
+  select case (tolower(a%fida))
+  case ('csr')
     call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-     
+  case ('coo')
-  else if (toupper(a%fida) == 'COO') then 
     call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-     
+  case ('jad')
-  else if (toupper(a%fida) == 'JAD') then 
     call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-
+  case default
-  else
     info=136
     ch_err=a%fida(1:3)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
-  end if
+  end select
   
   if (info /= 0) goto 9999
 !!$  call psb_erractionrestore(err_act)

base/serial/psb_dsymbmm.f90

@@ -93,6 +93,7 @@ subroutine psb_dsymbmm(a,b,c,info)
   c%k=b%k
   c%fida='CSR'
   c%descra='GUN'
+  
   deallocate(itemp) 
   call psb_erractionrestore(err_act)
   return

base/serial/psb_dtransp.f90

@@ -36,10 +36,11 @@ subroutine psb_dtransp(a,b,c,fmt)
   use psb_spmat_type
   use psb_tools_mod
   use psb_string_mod
-  use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
+  use psb_serial_mod, psb_protect_name => psb_dtransp
   implicit none
 
-  type(psb_dspmat_type)      :: a,b
+  type(psb_dspmat_type), intent(inout) :: a
+  type(psb_dspmat_type), intent(out)   :: b
   integer, optional          :: c
   character(len=*), optional :: fmt
 
@@ -59,55 +60,21 @@ subroutine psb_dtransp(a,b,c,fmt)
     fmt_='CSR'
   endif
 
-  if (.true.) then 
+  call psb_nullify_sp(b)
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
+  
-    b%fida   = 'COO'
+  call psb_spcnv(a,b,info,afmt='coo')
-    b%descra = 'GUN'
+  
-    call psb_csdp(a,b,info)
-!!$    write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
   if (info /= 0) then 
     write(0,*) 'transp: info from CSDP ',info
     return
   end if
-  else
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
-    call psb_sp_clone(a,b,info)
-    
-    if (b%fida=='CSR') then 
-      call psb_ipcsr2coo(b,info)
-    else if (b%fida=='COO') then 
-      ! do nothing 
-    else
-      write(0,*) 'Unimplemented case in TRANSP '
-    endif
-!!$    write(0,*) 'Check from CLONE',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
-  endif
-!!$  nz = b%infoa(nnz_)
-!!$  write(0,*) 'TRANSP CHECKS:',a%m,a%k,&
-!!$       &minval(b%ia1(1:nz)),maxval(b%ia1(1:nz)),&
-!!$       &minval(b%ia2(1:nz)),maxval(b%ia2(1:nz))
   call psb_transfer(b%ia1,itmp,info)
   call psb_transfer(b%ia2,b%ia1,info)
   call psb_transfer(itmp,b%ia2,info)
 
   b%m = a%k 
   b%k = a%m
-!!$  write(0,*) 'Calling IPCOO2CSR from transp90 ',b%m,b%k
+  call psb_spcnv(b,info,afmt=fmt_)
-  if (fmt_=='CSR') then 
-    call psb_ipcoo2csr(b,info)
-    b%fida='CSR'
-  else if (fmt_=='COO') then 
-    call psb_fixcoo(b,info)
-    b%fida='COO'
-  else
-    call psb_nullify_sp(tmp)
-    call psb_sp_clone(b,tmp,info)
-    b%fida=fmt_
-    call psb_csdp(tmp,b,info)
-    !!!!!! ADD HERE ERRPUSH!!! 
-    call psb_sp_free(tmp,info)
-
-  endif
 
   return
 end subroutine psb_dtransp

base/serial/psb_regen_mod.f90

@@ -0,0 +1,613 @@
+module psb_regen_mod
+
+  interface csr_regen
+    module procedure csr_dsp_regen, csr_zsp_regen
+  end interface
+  interface coo_regen
+    module procedure coo_dsp_regen, coo_zsp_regen
+  end interface
+  interface jad_regen
+    module procedure jad_dsp_regen, jad_zsp_regen
+  end interface
+
+contains
+  
+  subroutine csr_dsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_dspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    real(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia2(ip1+psb_ip2_)
+      nnz   = a%ia2(ip1+psb_nnz_)
+      iflag = a%ia2(ip1+psb_iflag_)
+      ichk  = a%ia2(ip1+psb_ichk_)
+      nnzt  = a%ia2(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = dzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine csr_dsp_regen
+
+  subroutine coo_dsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_dspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    real(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia2(ip1+psb_ip2_)
+      nnz   = a%ia2(ip1+psb_nnz_)
+      iflag = a%ia2(ip1+psb_iflag_)
+      ichk  = a%ia2(ip1+psb_ichk_)
+      nnzt  = a%ia2(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = dzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine coo_dsp_regen
+
+  subroutine jad_dsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_dspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    real(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia1(ip1+psb_ip2_)
+      nnz   = a%ia1(ip1+psb_nnz_)
+      iflag = a%ia1(ip1+psb_iflag_)
+      ichk  = a%ia1(ip1+psb_ichk_)
+      nnzt  = a%ia1(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = dzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia1(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine jad_dsp_regen
+
+
+  
+  subroutine csr_zsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_zspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    complex(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia2(ip1+psb_ip2_)
+      nnz   = a%ia2(ip1+psb_nnz_)
+      iflag = a%ia2(ip1+psb_iflag_)
+      ichk  = a%ia2(ip1+psb_ichk_)
+      nnzt  = a%ia2(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = zzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine csr_zsp_regen
+
+  subroutine coo_zsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_zspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    complex(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia2(ip1+psb_ip2_)
+      nnz   = a%ia2(ip1+psb_nnz_)
+      iflag = a%ia2(ip1+psb_iflag_)
+      ichk  = a%ia2(ip1+psb_ichk_)
+      nnzt  = a%ia2(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = zzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine coo_zsp_regen
+
+  subroutine jad_zsp_regen(a,info)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_error_mod
+    implicit none
+
+    type(psb_zspmat_type), intent(inout)    :: a
+    integer                              :: info
+
+    integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
+    complex(kind(1.d0)), allocatable  :: work(:)
+    integer :: err_act
+    character(len=20)             :: name, ch_err
+    logical, parameter :: debug=.false.
+
+    name='psb_spcnv'
+    info = 0
+    call psb_erractionsave(err_act)
+
+
+    !
+    !   dupl_ and upd_ fields should not be changed. 
+    !
+    select case(psb_sp_getifld(psb_upd_,a,info))
+
+    case(psb_upd_perm_)
+
+      allocate(work(size(a%aspk)+1000),stat=info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
+      ip1   = psb_sp_getifld(psb_upd_pnt_,a,info) 
+      ip2   = a%ia1(ip1+psb_ip2_)
+      nnz   = a%ia1(ip1+psb_nnz_)
+      iflag = a%ia1(ip1+psb_iflag_)
+      ichk  = a%ia1(ip1+psb_ichk_)
+      nnzt  = a%ia1(ip1+psb_nnzt_)
+      if (debug) write(*,*) 'Regeneration start: ',&
+           &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
+
+      if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
+        info = 8889
+        write(*,*) 'Regeneration start error: ',&
+             &   a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk    
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      do i= 1, nnz
+        work(i) = zzero
+      enddo
+      select case(iflag) 
+      case(psb_dupl_ovwrt_,psb_dupl_err_) 
+        do i=1, nnz 
+          work(a%ia1(ip2+i-1)) = a%aspk(i) 
+        enddo
+      case(psb_dupl_add_) 
+        do i=1, nnz 
+          work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) 
+        enddo
+      case default
+        info = 8887
+        call psb_errpush(info,name)
+        goto 9999          
+      end select
+
+      do i=1, nnz
+        a%aspk(i) = work(i)
+      enddo
+
+
+    case(psb_upd_srch_)
+      ! Nothing to be done  here. 
+      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
+    case default
+      ! Wrong value
+      info = 8888
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    call psb_erractionrestore(err_act)
+    if (err_act.eq.psb_act_abort_) then
+      call psb_error()
+      return
+    end if
+    return
+
+  end subroutine jad_zsp_regen
+
+  
+
+end module psb_regen_mod

base/serial/psb_update_mod.f90

@@ -30,12 +30,6 @@
 !!$  
 module psb_update_mod
 
-
-  use psb_spmat_type
-  use psb_const_mod
-  use psb_realloc_mod
-  use psb_string_mod
-
   interface psb_srch_upd
     module procedure psb_d_srch_upd, psb_z_srch_upd
   end interface
@@ -48,11 +42,21 @@ module psb_update_mod
     module procedure d_csr_srch_upd, z_csr_srch_upd
   end interface
 
+  interface jad_srch_upd
+    module procedure d_jad_srch_upd, z_jad_srch_upd
+  end interface
+
 contains
 
 
   subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_dspmat_type), intent(inout) :: a
@@ -70,44 +74,34 @@ contains
         info = -1
         return
       endif
-      
+    end if
-      select case(toupper(a%fida))
+    select case(tolower(a%fida))
-      case ('CSR') 
+    case ('csr') 
-!!$      write(0,*) 'Calling csr_srch_upd'
       call  csr_srch_upd(nz,ia,ja,val,nza,a,&
            & imin,imax,jmin,jmax,nzl,info,gtl,ng)
-!!$      write(0,*) 'From csr_srch_upd:',info
+    case ('coo') 
-      case ('COO') 
       call  coo_srch_upd(nz,ia,ja,val,nza,a,&
            & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+    case ('jad') 
+      call  jad_srch_upd(nz,ia,ja,val,nza,a,&
+           & imin,imax,jmin,jmax,nzl,info,gtl,ng)
       
     case default
       
       info = -9
       
     end select
-    else
-      select case(toupper(a%fida))
-      case ('CSR') 
-!!$      write(0,*) 'Calling csr_srch_upd'
-        call  csr_srch_upd(nz,ia,ja,val,nza,a,&
-             & imin,imax,jmin,jmax,nzl,info)
-!!$      write(0,*) 'From csr_srch_upd:',info
-      case ('COO') 
-        call  coo_srch_upd(nz,ia,ja,val,nza,a,&
-             & imin,imax,jmin,jmax,nzl,info)
-        
-      case default
-        
-        info = -9
-        
-      end select
-    end if
 
   end subroutine psb_d_srch_upd
 
   subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_zspmat_type), intent(inout) :: a
@@ -164,6 +158,12 @@ contains
 
   subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_dspmat_type), intent(inout) :: a
@@ -387,6 +387,12 @@ contains
 
   subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_dspmat_type), intent(inout) :: a
@@ -583,9 +589,252 @@ contains
 
   end subroutine d_coo_srch_upd
 
+  subroutine d_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
+    
+    implicit none
+
+    type(psb_dspmat_type), intent(inout), target :: a
+    integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
+    integer, intent(in) :: ia(*),ja(*)
+    integer, intent(inout) :: nza
+    real(kind(1.d0)), intent(in) :: val(*)
+    integer, intent(out) :: info
+    integer, intent(in), optional  :: ng,gtl(*)
+
+    integer, pointer     :: ia1(:), ia2(:), ia3(:),&
+         & ja_(:), ka_(:)
+    integer, allocatable :: indices(:), blks(:), rows(:) 
+    integer  :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,&
+         & i,j,k,nr,dupl, ii, ir, ic
+
+    info = 0
+    dupl = psb_sp_getifld(psb_dupl_,a,info)
+
+    png = a%ia2(1) ! points to the number of blocks
+    pia = a%ia2(2) ! points to the beginning of ia(3,png)
+    pja = a%ia2(3) ! points to the beginning of ja(:)
+
+    ngr  =  a%ia2(png)              ! the number of blocks
+    ja_  => a%ia2(pja:)            ! the array containing the pointers to ka and aspk
+    ka_  => a%ia1(:)               ! the array containing the column indices
+    ia1 => a%ia2(pia:pja-1:3)      ! the array containing the first row index 
+    ! of each block
+    ia2 => a%ia2(pia+1:pja-1:3)    ! the array containing a pointer to the pos. 
+    ! in ja to the first jad column
+    ia3 => a%ia2(pia+2:pja-1:3)    ! the array containing a pointer to the pos. 
+    ! in ja to the first csr column
+
+
+    if (a%pl(1) /= 0) then
+
+      if (present(gtl)) then 
+        if (.not.present(ng)) then 
+          info = -1
+          return
+        endif
+
+
+        allocate(rows(nz),stat=info) 
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+        j=0
+        do i=1,nz
+          ir = ia(i)
+          if ((ir >=1).and.(ir<=ng)) then 
+            ir = gtl(ir)
+            j = j + 1
+            rows(j) = ir
+          endif
+        enddo
+        call psb_msort_unique(rows(1:j),nr)
+        allocate(indices(nr),blks(nr),stat=info)
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+
+        do i=1,nr
+          indices(i)=a%pl(rows(i))
+          j=0
+          blkfnd_gtl: do
+            j=j+1
+            if(ia1(j).eq.indices(i)) then
+              blks(i)=j
+              ipx = ia1(j)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j)+rb
+              exit blkfnd_gtl
+            else if(ia1(j).gt.indices(i)) then
+              blks(i)=j-1
+              ipx = ia1(j-1)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j-1)+rb
+              exit blkfnd_gtl
+            end if
+          end do blkfnd_gtl
+        end do
+
+
+        ! cycle over elements
+        update_gtl: do ii=1,nz
+          ir = ia(ii)
+          ic = ja(ii) 
+          if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then 
+            ir = gtl(ir)
+            if ((ir > 0).and.(ir <= a%m)) then 
+              ic = gtl(ic) 
+              call ibsrch(i,ir,nr,rows)
+
+              ! find which block the row belongs to
+              blk = blks(i)
+
+              ! extract first part of the row from the jad block
+              ipx = ia1(blk)             ! the first row index of the block
+              k_pt= ia2(blk)             ! the pointer to the beginning of a column in ja
+              rb  = indices(i)-ipx       ! the row offset within the block
+              npg = ja_(k_pt+1)-ja_(k_pt)  ! the number of rows in the block
+
+              do  col = ia2(blk), ia3(blk)-1 
+                if (ic ==  ka_(ja_(col)+rb)) then 
+                  select case(dupl)
+                  case(psb_dupl_ovwrt_,psb_dupl_err_)
+                    a%aspk(ja_(col)+rb) = val(ii)
+                  case(psb_dupl_add_)
+                    a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
+                  end select
+                  cycle update_gtl
+                endif
+              end do
+
+              ! extract second part of the row from the csr tail just in case
+              row=ia3(blk)+rb
+              do j=ja_(row), ja_(row+1)-1
+                if (ic ==  ka_(j)) then 
+                  select case(dupl)
+                  case(psb_dupl_ovwrt_,psb_dupl_err_)
+                    a%aspk(j) = val(ii)
+                  case(psb_dupl_add_)
+                    a%aspk(j) = a%aspk(j) + val(ii)
+                  end select
+                  cycle update_gtl
+                endif
+              end do
+            end if
+          end if
+        end do update_gtl
+
+      else
+
+        allocate(rows(nz),stat=info) 
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+        j=0
+        do i=1,nz
+          ir = ia(i)
+          if ((ir >=1).and.(ir<=a%m)) then 
+            j = j + 1
+            rows(j) = ir
+          endif
+        enddo
+        call psb_msort_unique(rows(1:j),nr)
+        allocate(indices(nr),blks(nr),stat=info)
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+
+        do i=1,nr
+          indices(i)=a%pl(rows(i))
+          j=0
+          blkfnd: do
+            j=j+1
+            if(ia1(j).eq.indices(i)) then
+              blks(i)=j
+              ipx = ia1(j)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j)+rb
+              exit blkfnd
+            else if(ia1(j).gt.indices(i)) then
+              blks(i)=j-1
+              ipx = ia1(j-1)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j-1)+rb
+              exit blkfnd
+            end if
+          end do blkfnd
+        end do
+
+
+        ! cycle over elements
+        update: do ii=1,nz
+          ir = ia(ii)
+          ic = ja(ii) 
+          if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then 
+            call ibsrch(i,ir,nr,rows)
+            ! find which block the row belongs to
+            blk = blks(i)
+
+            ! extract first part of the row from the jad block
+            ipx = ia1(blk)             ! the first row index of the block
+            k_pt= ia2(blk)             ! the pointer to the beginning of a column in ja
+            rb  = indices(i)-ipx       ! the row offset within the block
+            npg = ja_(k_pt+1)-ja_(k_pt)  ! the number of rows in the block
+
+            do  col = ia2(blk), ia3(blk)-1 
+              if (ic ==  ka_(ja_(col)+rb)) then 
+                select case(dupl)
+                case(psb_dupl_ovwrt_,psb_dupl_err_)
+                  a%aspk(ja_(col)+rb) = val(ii)
+                case(psb_dupl_add_)
+                  a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
+                end select
+                cycle update
+              endif
+            end do
+
+            ! extract second part of the row from the csr tail just in case
+            row=ia3(blk)+rb
+            do j=ja_(row), ja_(row+1)-1
+              if (ic ==  ka_(j)) then 
+                select case(dupl)
+                case(psb_dupl_ovwrt_,psb_dupl_err_)
+                  a%aspk(j) = val(ii)
+                case(psb_dupl_add_)
+                  a%aspk(j) = a%aspk(j) + val(ii)
+                end select
+                cycle update
+              endif
+            end do
+          end if
+        end do update
+
+      end if
+    else
+      ! There might be some problems
+      info=134
+    end if
+
+  end subroutine d_jad_srch_upd
+
 
   subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_zspmat_type), intent(inout) :: a
@@ -801,6 +1050,12 @@ contains
 
   subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,&
        & imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
     implicit none 
 
     type(psb_zspmat_type), intent(inout) :: a
@@ -997,5 +1252,245 @@ contains
 
   end subroutine z_coo_srch_upd
 
+
+
+  subroutine z_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng)
+
+    use psb_spmat_type
+    use psb_const_mod
+    use psb_realloc_mod
+    use psb_string_mod
+    use psb_serial_mod
+    
+    implicit none
+
+    type(psb_zspmat_type), intent(inout), target :: a
+    integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
+    integer, intent(in) :: ia(*),ja(*)
+    integer, intent(inout) :: nza
+    complex(kind(1.d0)), intent(in) :: val(*)
+    integer, intent(out) :: info
+    integer, intent(in), optional  :: ng,gtl(*)
+
+    integer, pointer     :: ia1(:), ia2(:), ia3(:),&
+         & ja_(:), ka_(:)
+    integer, allocatable :: indices(:), blks(:), rows(:) 
+    integer  :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,&
+         & i,j,k,nr,dupl, ii, ir, ic
+
+    info = 0
+    dupl = psb_sp_getifld(psb_dupl_,a,info)
+
+    png = a%ia2(1) ! points to the number of blocks
+    pia = a%ia2(2) ! points to the beginning of ia(3,png)
+    pja = a%ia2(3) ! points to the beginning of ja(:)
+
+    ngr  =  a%ia2(png)              ! the number of blocks
+    ja_  => a%ia2(pja:)            ! the array containing the pointers to ka and aspk
+    ka_  => a%ia1(:)               ! the array containing the column indices
+    ia1 => a%ia2(pia:pja-1:3)      ! the array containing the first row index 
+    ! of each block
+    ia2 => a%ia2(pia+1:pja-1:3)    ! the array containing a pointer to the pos. 
+    ! in ja to the first jad column
+    ia3 => a%ia2(pia+2:pja-1:3)    ! the array containing a pointer to the pos. 
+    ! in ja to the first csr column
+
+
+    if (a%pl(1) /= 0) then
+
+      if (present(gtl)) then 
+        if (.not.present(ng)) then 
+          info = -1
+          return
+        endif
+
+
+        allocate(rows(nz),stat=info) 
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+        j=0
+        do i=1,nz
+          ir = ia(i)
+          if ((ir >=1).and.(ir<=ng)) then 
+            ir = gtl(ir)
+            j = j + 1
+            rows(j) = ir
+          endif
+        enddo
+        call psb_msort_unique(rows(1:j),nr)
+        allocate(indices(nr),blks(nr),stat=info)
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+
+        do i=1,nr
+          indices(i)=a%pl(rows(i))
+          j=0
+          blkfnd_gtl: do
+            j=j+1
+            if(ia1(j).eq.indices(i)) then
+              blks(i)=j
+              ipx = ia1(j)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j)+rb
+              exit blkfnd_gtl
+            else if(ia1(j).gt.indices(i)) then
+              blks(i)=j-1
+              ipx = ia1(j-1)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j-1)+rb
+              exit blkfnd_gtl
+            end if
+          end do blkfnd_gtl
+        end do
+
+
+        ! cycle over elements
+        update_gtl: do ii=1,nz
+          ir = ia(ii)
+          ic = ja(ii) 
+          if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then 
+            ir = gtl(ir)
+            if ((ir > 0).and.(ir <= a%m)) then 
+              ic = gtl(ic) 
+              call ibsrch(i,ir,nr,rows)
+
+              ! find which block the row belongs to
+              blk = blks(i)
+
+              ! extract first part of the row from the jad block
+              ipx = ia1(blk)             ! the first row index of the block
+              k_pt= ia2(blk)             ! the pointer to the beginning of a column in ja
+              rb  = indices(i)-ipx       ! the row offset within the block
+              npg = ja_(k_pt+1)-ja_(k_pt)  ! the number of rows in the block
+
+              do  col = ia2(blk), ia3(blk)-1 
+                if (ic ==  ka_(ja_(col)+rb)) then 
+                  select case(dupl)
+                  case(psb_dupl_ovwrt_,psb_dupl_err_)
+                    a%aspk(ja_(col)+rb) = val(ii)
+                  case(psb_dupl_add_)
+                    a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
+                  end select
+                  cycle update_gtl
+                endif
+              end do
+
+              ! extract second part of the row from the csr tail just in case
+              row=ia3(blk)+rb
+              do j=ja_(row), ja_(row+1)-1
+                if (ic ==  ka_(j)) then 
+                  select case(dupl)
+                  case(psb_dupl_ovwrt_,psb_dupl_err_)
+                    a%aspk(j) = val(ii)
+                  case(psb_dupl_add_)
+                    a%aspk(j) = a%aspk(j) + val(ii)
+                  end select
+                  cycle update_gtl
+                endif
+              end do
+            end if
+          end if
+        end do update_gtl
+
+      else
+
+        allocate(rows(nz),stat=info) 
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+        j=0
+        do i=1,nz
+          ir = ia(i)
+          if ((ir >=1).and.(ir<=a%m)) then 
+            j = j + 1
+            rows(j) = ir
+          endif
+        enddo
+        call psb_msort_unique(rows(1:j),nr)
+        allocate(indices(nr),blks(nr),stat=info)
+        if (info /= 0) then 
+          info = -4010
+          return
+        endif
+
+        do i=1,nr
+          indices(i)=a%pl(rows(i))
+          j=0
+          blkfnd: do
+            j=j+1
+            if(ia1(j).eq.indices(i)) then
+              blks(i)=j
+              ipx = ia1(j)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j)+rb
+              exit blkfnd
+            else if(ia1(j).gt.indices(i)) then
+              blks(i)=j-1
+              ipx = ia1(j-1)         ! the first row index of the block
+              rb  = indices(i)-ipx   ! the row offset within the block
+              row = ia3(j-1)+rb
+              exit blkfnd
+            end if
+          end do blkfnd
+        end do
+
+
+        ! cycle over elements
+        update: do ii=1,nz
+          ir = ia(ii)
+          ic = ja(ii) 
+          if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then 
+            call ibsrch(i,ir,nr,rows)
+            ! find which block the row belongs to
+            blk = blks(i)
+
+            ! extract first part of the row from the jad block
+            ipx = ia1(blk)             ! the first row index of the block
+            k_pt= ia2(blk)             ! the pointer to the beginning of a column in ja
+            rb  = indices(i)-ipx       ! the row offset within the block
+            npg = ja_(k_pt+1)-ja_(k_pt)  ! the number of rows in the block
+
+            do  col = ia2(blk), ia3(blk)-1 
+              if (ic ==  ka_(ja_(col)+rb)) then 
+                select case(dupl)
+                case(psb_dupl_ovwrt_,psb_dupl_err_)
+                  a%aspk(ja_(col)+rb) = val(ii)
+                case(psb_dupl_add_)
+                  a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
+                end select
+                cycle update
+              endif
+            end do
+
+            ! extract second part of the row from the csr tail just in case
+            row=ia3(blk)+rb
+            do j=ja_(row), ja_(row+1)-1
+              if (ic ==  ka_(j)) then 
+                select case(dupl)
+                case(psb_dupl_ovwrt_,psb_dupl_err_)
+                  a%aspk(j) = val(ii)
+                case(psb_dupl_add_)
+                  a%aspk(j) = a%aspk(j) + val(ii)
+                end select
+                cycle update
+              endif
+            end do
+          end if
+        end do update
+
+      end if
+    else
+      ! There might be some problems
+      info=134
+    end if
+
+  end subroutine z_jad_srch_upd
+
+
 end module psb_update_mod
 

base/serial/psb_zcoins.f90

@@ -38,7 +38,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
   use psb_realloc_mod
   use psb_string_mod
   use psb_error_mod
-  use psb_serial_mod, only : psb_sp_info, psb_csdp
+  use psb_serial_mod, psb_protect_name => psb_zcoins
   use psb_update_mod
   implicit none 
 
@@ -156,8 +156,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
       case (psb_upd_perm_)
         ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)      
         nzl = psb_sp_getifld(psb_del_bnd_,a,info)      
+        select case(ufida)
+        case ('JAD')
+          nza = a%ia1(ip1+psb_nnz_)
+        case default
           nza = a%ia2(ip1+psb_nnz_)
-
+        end select
 
         call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
              & imin,imax,jmin,jmax,nzl,info,gtl,ng)
@@ -172,11 +176,17 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
             write(0,*) 'PSB_COINS: update discarded items '
           end if
         end if
+
+        select case(ufida)
+        case ('JAD')
+          a%ia1(ip1+psb_nnz_) = nza
+        case default
           a%ia2(ip1+psb_nnz_) = nza
+        end select
 
         if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
 
-      case (psb_upd_dflt_, psb_upd_srch_)
+      case (psb_upd_srch_)
 
         call  psb_srch_upd(nz,ia,ja,val,nza,a,&
              & imin,imax,jmin,jmax,nzl,info,gtl,ng)
@@ -187,8 +197,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
                  &  'COINS: Going through rebuild_ fingers crossed!'
             irst = info
             call psb_nullify_sp(tmp)
-            tmp%fida='COO'
+            call psb_spcnv(a,tmp,info,afmt='coo')
-            call psb_csdp(a,tmp,info)
             if(info /= izero) then
               info=4010
               ch_err='psb_csdp'
@@ -349,7 +358,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
 
         if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
 
-      case (psb_upd_dflt_, psb_upd_srch_)
+      case (psb_upd_srch_)
 
         call  psb_srch_upd(nz,ia,ja,val,nza,a,&
              & imin,imax,jmin,jmax,nzl,info)
@@ -360,8 +369,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
                  &  'COINS: Going through rebuild_ fingers crossed!'
             irst = info
             call psb_nullify_sp(tmp)
-            tmp%fida='COO'
+            call psb_spcnv(a,tmp,info,afmt='coo')
-            call psb_csdp(a,tmp,info)
             call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
             if (debug) then
               write(0,*) 'COINS  Rebuild: size',tmp%infoa(psb_nnz_) ,irst            
@@ -429,8 +437,6 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
   endif
 
 
-  return
-
   call psb_erractionrestore(err_act)
   return
 

base/serial/psb_zcsdp.f90

@@ -1,516 +0,0 @@
-!!$ 
-!!$              Parallel Sparse BLAS  v2.0
-!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
-!!$                       Alfredo Buttari        University of Rome Tor Vergata
-!!$ 
-!!$  Redistribution and use in source and binary forms, with or without
-!!$  modification, are permitted provided that the following conditions
-!!$  are met:
-!!$    1. Redistributions of source code must retain the above copyright
-!!$       notice, this list of conditions and the following disclaimer.
-!!$    2. Redistributions in binary form must reproduce the above copyright
-!!$       notice, this list of conditions, and the following disclaimer in the
-!!$       documentation and/or other materials provided with the distribution.
-!!$    3. The name of the PSBLAS group or the names of its contributors may
-!!$       not be used to endorse or promote products derived from this
-!!$       software without specific written permission.
-!!$ 
-!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
-!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!!$  POSSIBILITY OF SUCH DAMAGE.
-!!$ 
-!!$  
-! File:  psb_zcsdp.f90 
-!
-! Subroutine: psb_zcsdp
-!    This subroutine performs the assembly of
-!    the local part of a sparse distributed matrix
-!
-! Parameters:
-!   a      -  type(<psb_spmat_type>).         The input matrix to be assembled.
-!   b      -  type(<psb_spmat_type>).         The assembled output matrix.
-!   info   -  integer.                        Eventually returns an error code.
-!   ifc    -  integer(optional).              ???
-!   check  -  character(optional).            ???
-!   trans  -  character(optional).            ???
-!   unitd  -  character(optional).            ???
-!
-subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl)
-  use psb_const_mod
-  use psb_error_mod
-  use psb_spmat_type
-  use psb_string_mod
-  use psb_serial_mod, psb_protect_name => psb_zcsdp
-  implicit none
-  !....Parameters...
-  Type(psb_zspmat_type), intent(in)    :: A
-  Type(psb_zspmat_type), intent(inout) :: B
-  Integer, intent(out)                 :: info
-  Integer, intent(in), optional        :: ifc,upd,dupl
-  character, intent(in), optional      :: check,trans,unitd
-
-  !...Locals...
-  complex(kind(1.d0))              :: d(1)
-  complex(kind(1.d0)), allocatable :: work(:)
-  type(psb_zspmat_type)         :: temp_a
-  Integer                       :: nzr, ntry, ifc_, ia1_size,&
-       & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
-  integer                       :: ip1, ip2, nnz, iflag, ichk, nnzt,&
-       & ipc, i, count, err_act, i1, i2, ia
-  character                     :: check_,trans_,unitd_
-  Integer, Parameter            :: maxtry=8
-  logical, parameter            :: debug=.false.
-  character(len=20)             :: name, ch_err
-
-  name='psb_csdp'
-  info  = 0
-  call psb_erractionsave(err_act)
-
-  ntry=0
-  if (present(ifc)) then 
-    ifc_  = max(1,ifc)
-  else 
-    ifc_ = 1
-  endif
-  if (present(check)) then 
-    check_ = toupper(check)
-  else 
-    check_ = 'N'
-  endif
-  if (present(trans)) then 
-    trans_ = toupper(trans)
-  else 
-    trans_ = 'N'
-  endif
-  if (present(unitd)) then 
-    unitd_ = toupper(unitd)
-  else 
-    unitd_ = 'U'
-  endif
-
-
-  if (check_=='R') then 
-    allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info)
-  else
-    allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
-  endif
-
-  if (info /= 0) then
-    info=2040
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-  if (ifc_<1) then 
-    write(0,*) 'csdp90 Error: invalid ifc ',ifc_
-    info = -4
-    call psb_errpush(info,name)
-    goto 9999
-  endif
-
-  if((check_=='Y').or.(check_=='C')) then
-    if(toupper(a%fida(1:3))=='CSR') then
-      call zcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
-      if(info /= 0) then
-        info=4010
-        ch_err='dcsrck'
-        call psb_errpush(info,name,a_err=ch_err)
-        goto 9999
-      end if
-
-    else
-      write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3)
-    end if
-
-  end if
-
-  if (check_/='R') then
-    
-    if (present(upd)) then 
-      call psb_sp_setifld(upd,psb_upd_,b,info)    
-    end if
-    if (present(dupl)) then 
-      call psb_sp_setifld(dupl,psb_dupl_,b,info)    
-    end if
-    
-    upd_ = psb_sp_getifld(psb_upd_,b,info)
-    select case(upd_)
-    case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_)
-      ! Legal value, do nothing
-    case default
-      ! Fix bad value
-      upd_ = psb_upd_dflt_
-      call psb_sp_setifld(upd_,psb_upd_,b,info)    
-    end select
-    dupl_ = psb_sp_getifld(psb_dupl_,b,info)
-    select case(dupl_)
-    case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
-      ! Legal value, do nothing
-    case default
-      ! Fix bad value
-      dupl_ = psb_dupl_def_
-      call psb_sp_setifld(dupl_,psb_dupl_,b,info)    
-    end select
-    
-    !  ...matrix conversion...
-    b%m=a%m
-    b%k=a%k
-    size_req = psb_sp_get_nnzeros(a)
-    if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
-    !
-    
-    n_row=b%m 
-    n_col=b%k
-    call psb_cest(b%fida, n_row,n_col,size_req,&
-         & ia1_size, ia2_size, aspk_size, upd_,info)
-
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_cest'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-    if (.not.allocated(b%aspk).or.&
-         &.not.allocated(b%ia1).or.&
-         &.not.allocated(b%ia2).or.&
-         &.not.allocated(b%pl).or.&
-         &.not.allocated(b%pr)) then
-      call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
-    else if ((size(b%aspk)  < aspk_size) .or.&
-         &(size(b%ia1) < ia1_size) .or.&
-         &(size(b%ia2) < ia2_size) .or.&
-         &(size(b%pl)  < b%m) .or.&
-         &(size(b%pr) < b%k )) then 
-      call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
-    endif
-
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_sp_reall'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-
-    b%pl(:)  = 0
-    b%pr(:)  = 0
-
-    b%descra = a%descra
-
-    select case (toupper(a%fida(1:3)))
-
-    case ('CSR')
-
-      select case (toupper(b%fida(1:3)))
-
-      case ('CSR')
-
-
-        call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, size(work), info)
-
-
-        if (info/=0) then
-          info=4010
-          ch_err='dcrcr'
-          call psb_errpush(info,name,a_err=ch_err)
-          goto 9999
-        end if
-
-      case ('JAD')
-
-        !...converting to JAD
-        !...output matrix may not be big enough
-        do
-
-          call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-               & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-               & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-               & size(b%ia2), work, size(work), nzr, info)
-          if (info /= 0) then
-            call psb_errpush(4010,name,a_err='dcrjd')
-            goto 9999
-          endif
-
-          ntry = ntry + 1
-          if (debug) then 
-            write(0,*) 'On out from dcrjad ',nzr,info
-          end if
-          if (nzr == 0) exit
-          if (ntry > maxtry ) then 
-            write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-          call psb_sp_reall(b,nzr,info,ifc=ifc_)
-          if (info /= 0) then
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-        end do
-
-        if (info/=0) then
-          call psb_errpush(info,name)
-          goto 9999
-        end if
-
-      case ('COO')
-
-        call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcrco')
-          goto 9999
-        end if
-      case default
-        info=4010
-        call psb_errpush(info,name)
-        goto 9999
-        
-      end select
-
-    case ('COO','COI')
-
-      select case (toupper(b%fida(1:3)))
-
-      case ('CSR')
-
-        call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, 2*size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcocr')
-          goto 9999
-        end if
-
-      case ('JAD')
-
-        call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
-        if (info /= 0) then
-          info=2040
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-        temp_a%m = a%m
-        temp_a%k = a%k
-
-        !...Dirty trick: converting to CSR and then to JAD
-
-        call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
-             & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
-             & size(temp_a%aspk), size(temp_a%ia1),&
-             & size(temp_a%ia2), work, 2*size(work), info)
-
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcocr')
-          goto 9999
-        end if
-
-        do
-          call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
-               & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
-               & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
-               & size(b%aspk), size(b%ia1),&
-               & size(b%ia2), work, size(work), nzr, info)
-          if (info/=0) then
-            call psb_errpush(4010,name,a_err='dcrjd')
-            goto 9999
-          end if
-
-          ntry = ntry + 1
-          if (debug) then 
-            write(0,*) 'On out from dcrjad ',nzr,info
-          end if
-          if (nzr == 0) exit
-          if (ntry > maxtry ) then 
-            write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
-                 & ': giving up now.'
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-          call psb_sp_reall(b,nzr,info,ifc=ifc_)
-          if (info /= 0) then
-            info=2040
-            call psb_errpush(info,name)
-            goto 9999
-          endif
-
-        end do
-
-      case ('COO')
-
-        call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
-             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
-             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
-             & size(b%ia2), work, 2*size(work), info)
-        if (info/=0) then
-          call psb_errpush(4010,name,a_err='dcoco')
-          goto 9999
-        end if
-
-      case default
-        info=4010
-        call psb_errpush(info,name)
-        goto 9999
-      end select
-
-    case default
-      info=4010
-      call psb_errpush(info,name)
-      goto 9999
-
-    end select
-
-
-    if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
-         &      call psb_sp_trim(b,info)
-
-  else if (check_=='R') then
-    !...Regenerating matrix    
-
-    if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then 
-      info = 8888
-      call psb_errpush(info,name)
-      goto 9999
-    endif
-
-    !
-    !   dupl_ and upd_ fields should not be changed. 
-    !
-    select case(psb_sp_getifld(psb_upd_,b,info))
-
-    case(psb_upd_perm_)
-      if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
-      if (toupper(b%fida(1:3))/='JAD') then
-        ip1   = psb_sp_getifld(psb_upd_pnt_,b,info) 
-        ip2   = b%ia2(ip1+psb_ip2_)
-        nnz   = b%ia2(ip1+psb_nnz_)
-        iflag = b%ia2(ip1+psb_iflag_)
-        ichk  = b%ia2(ip1+psb_ichk_)
-        nnzt  = b%ia2(ip1+psb_nnzt_)
-        if (debug) write(*,*) 'Regeneration start: ',&
-             &   b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
-
-        if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
-          info = 8889
-          write(*,*) 'Regeneration start error: ',&
-               &   b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk                    
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-        do i= 1, nnz
-          work(i) = 0.d0
-        enddo
-        select case(iflag) 
-        case(psb_dupl_ovwrt_,psb_dupl_err_) 
-          do i=1, nnz 
-            work(b%ia2(ip2+i-1)) = b%aspk(i) 
-          enddo
-        case(psb_dupl_add_) 
-          do i=1, nnz 
-            work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) 
-          enddo
-        case default
-          info = 8887
-          call psb_errpush(info,name)
-          goto 9999          
-        end select
-
-        do i=1, nnz
-          b%aspk(i) = work(i)
-        enddo
-
-      else if (toupper(b%fida(1:3)) == 'JAD') then
-
-
-        ip1   = psb_sp_getifld(psb_upd_pnt_,b,info) 
-        ip2   = b%ia1(ip1+psb_ip2_)
-        count = b%ia1(ip1+psb_zero_)
-        ipc   = b%ia1(ip1+psb_ipc_)
-        nnz   = b%ia1(ip1+psb_nnz_)
-        iflag = b%ia1(ip1+psb_iflag_)
-        ichk  = b%ia1(ip1+psb_ichk_)
-        nnzt  = b%ia1(ip1+psb_nnzt_)
-        if (debug) write(*,*) 'Regeneration start: ',&
-             &  b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
-             &  iflag,info
-
-        if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then               
-          info = 10
-          write(*,*) 'Regeneration start error: ',&
-               &  b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk     
-          call psb_errpush(info,name)
-          goto 9999
-        endif
-
-        do i= 1, nnz+count
-          work(i) = 0.d0
-        enddo
-        select case(iflag) 
-        case(psb_dupl_ovwrt_,psb_dupl_err_) 
-          do i=1, nnz 
-            work(b%ia1(ip2+i-1)) = b%aspk(i) 
-          enddo
-        case(psb_dupl_add_) 
-          do i=1, nnz 
-            work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) 
-          enddo
-        case default
-          info = 8887
-          call psb_errpush(info,name)
-          goto 9999          
-        end select
-
-        do i=1, nnz+count 
-          b%aspk(i) = work(i)
-        enddo
-        do i=1, count
-          b%aspk(b%ia1(ipc+i-1)) = 0.d0
-        end do
-      endif
-
-    case(psb_upd_dflt_,psb_upd_srch_)
-      ! Nothing to be done  here. 
-      if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
-    case default
-      ! Wrong value
-      info = 8888
-      call psb_errpush(info,name)
-      goto 9999
-
-    end select
-  end if
-  call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_erractionrestore(err_act)
-  if (err_act.eq.psb_act_abort_) then
-    call psb_error()
-    return
-  end if
-  return
-
-end subroutine psb_zcsdp

base/serial/psb_zfixcoo.f90

@@ -32,10 +32,12 @@
 ! Subroutine: 
 ! Parameters:
 
-Subroutine psb_zfixcoo(A,INFO,idir)
+Subroutine psb_zfixcoo(a,info,idir)
   use psb_spmat_type
   use psb_const_mod
   use psb_string_mod
+  use psb_serial_mod, psb_protect_name => psb_zfixcoo
+  use psb_error_mod
   implicit none
 
   !....Parameters...
@@ -45,11 +47,14 @@ Subroutine psb_zfixcoo(A,INFO,idir)
 
   integer, allocatable :: iaux(:)
   !locals
-  Integer              :: nza, nzl,iret,idir_
+  Integer              :: nza, nzl,iret,idir_, dupl_
-  integer              :: i,j, irw, icl
+  integer              :: i,j, irw, icl, err_act
   logical, parameter   :: debug=.false.
+  character(len=20)    :: name = 'psb_fixcoo'
 
   info  = 0
+  call psb_erractionsave(err_act)
+
   if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2)
   if (toupper(a%fida) /= 'COO') then 
     write(0,*) 'Fixcoo Invalid input ',a%fida
@@ -62,9 +67,11 @@ Subroutine psb_zfixcoo(A,INFO,idir)
     idir_ = 0
   endif
 
-  nza = a%infoa(psb_nnz_)
+  nza = psb_sp_getifld(psb_nnz_,a,info)
   if (nza < 2) return
 
+  dupl_ = psb_sp_getifld(psb_dupl_,a,info)
+
   allocate(iaux(nza+2),stat=info) 
   if (info /= 0) return
 
@@ -92,6 +99,27 @@ Subroutine psb_zfixcoo(A,INFO,idir)
     irw = a%ia1(i)
     icl = a%ia2(i)
     j = 1
+
+    select case(dupl_)
+    case(psb_dupl_ovwrt_)
+
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          a%aspk(i) = a%aspk(j)
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    case(psb_dupl_add_)
+
       do 
         j = j + 1
         if (j > nza) exit
@@ -106,8 +134,26 @@ Subroutine psb_zfixcoo(A,INFO,idir)
           icl = a%ia2(i) 
         endif
       enddo
-    a%infoa(psb_nnz_) = i    
+
-    a%infoa(psb_srtd_) = psb_isrtdcoo_
+    case(psb_dupl_err_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          call psb_errpush(130,name)          
+          goto 9999
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    end select
+
 
     if(debug) write(0,*)'FIXCOO: end second loop'
 
@@ -133,6 +179,26 @@ Subroutine psb_zfixcoo(A,INFO,idir)
     irw = a%ia1(i)
     icl = a%ia2(i)
     j = 1
+
+
+    select case(dupl_)
+    case(psb_dupl_ovwrt_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          a%aspk(i) = a%aspk(j)
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+
+    case(psb_dupl_add_)
       do 
         j = j + 1
         if (j > nza) exit
@@ -147,15 +213,45 @@ Subroutine psb_zfixcoo(A,INFO,idir)
           icl = a%ia2(i) 
         endif
       enddo
-    a%infoa(psb_nnz_) = i    
-    a%infoa(psb_srtd_) = psb_isrtdcoo_
 
+    case(psb_dupl_err_)
+      do 
+        j = j + 1
+        if (j > nza) exit
+        if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then 
+          call psb_errpush(130,name)
+          goto 9999
+        else
+          i = i+1
+          a%aspk(i) = a%aspk(j)
+          a%ia1(i) = a%ia1(j)
+          a%ia2(i) = a%ia2(j)
+          irw = a%ia1(i) 
+          icl = a%ia2(i) 
+        endif
+      enddo
+    end select
     if(debug) write(0,*)'FIXCOO: end second loop'
   case default
     write(0,*) 'Fixcoo: unknown direction ',idir_
   end select
-  a%infoa(psb_upd_) = psb_upd_srch_
+
+  call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info)
+  call psb_sp_setifld(i,psb_nnz_,a,info)
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
+  call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info)
 
   deallocate(iaux)
+
+  call psb_erractionrestore(err_act)
   return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
 end Subroutine psb_zfixcoo

base/serial/psb_zipcoo2csc.f90

@@ -35,7 +35,7 @@
 subroutine psb_zipcoo2csc(a,info,clshr)
   use psb_spmat_type
   use psb_const_mod
-  use psb_serial_mod, only : psb_fixcoo
+  use psb_serial_mod, psb_protect_name => psb_zipcoo2csc
   use psb_error_mod
   use psb_string_mod
   use psb_realloc_mod
@@ -49,7 +49,7 @@ subroutine psb_zipcoo2csc(a,info,clshr)
   integer, allocatable :: iaux(:), itemp(:)
   !locals
   logical             :: clshr_
-  Integer             :: nza, i,j,irw, idl,err_act,nc,icl
+  Integer             :: nza, nr, i,j, idl,err_act,nc,icl
   Integer, Parameter  :: maxtry=8
   logical, parameter  :: debug=.false.
   character(len=20)   :: name
@@ -107,7 +107,6 @@ subroutine psb_zipcoo2csc(a,info,clshr)
 
     if (clshr_) then 
       
-      
       j = 1
       i = 1
       icl = itemp(j) 

base/serial/psb_zipcsr2coo.f90

@@ -38,6 +38,7 @@ Subroutine psb_zipcsr2coo(a,info)
   use psb_error_mod
   use psb_string_mod
   use psb_realloc_mod
+  use psb_serial_mod, psb_protect_name => psb_zipcsr2coo
   implicit none
 
   !....Parameters...
@@ -86,6 +87,7 @@ Subroutine psb_zipcsr2coo(a,info)
   a%infoa(psb_upd_) = psb_upd_srch_
 
   deallocate(itemp)
+  call psb_fixcoo(a,info) 
 
   call psb_erractionrestore(err_act)
   return

base/serial/psb_zspcnv.f90

@@ -0,0 +1,553 @@
+!!$ 
+!!$              Parallel Sparse BLAS  v2.0
+!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
+!!$                       Alfredo Buttari        University of Rome Tor Vergata
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the PSBLAS group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$  
+! File:  psb_dcsdp.f90 
+!
+! Subroutine: psb_dcsdp
+!    This subroutine performs the assembly of
+!    the local part of a sparse distributed matrix
+!
+! Parameters:
+!   a      -  type(<psb_spmat_type>).         The input matrix to be assembled.
+!   b      -  type(<psb_spmat_type>).         The assembled output matrix.
+!   info   -  integer.                        Eventually returns an error code.
+!   ifc    -  integer(optional).              ???
+!   check  -  character(optional).            ???
+!   trans  -  character(optional).            ???
+!   unitd  -  character(optional).            ???
+!
+subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl)
+  use psb_const_mod
+  use psb_error_mod
+  use psb_spmat_type
+  use psb_string_mod
+  use psb_serial_mod, psb_protect_name => psb_zspcnv2
+  implicit none
+  !....Parameters...
+  Type(psb_zspmat_type), intent(in)      :: A
+  Type(psb_zspmat_type), intent(out)     :: B
+  Integer, intent(out)                   :: info
+  Integer, intent(in), optional          :: upd,dupl
+  character(len=*), optional, intent(in) :: afmt
+
+  !...Locals...
+  complex(kind(1.d0))              :: d(1)
+  complex(kind(1.d0)), allocatable :: work(:)
+  type(psb_zspmat_type)         :: temp_a
+  Integer                       :: nzr, ntry, ifc_, ia1_size,&
+       & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
+  integer                       :: ip1, ip2, nnz, iflag, ichk, nnzt,&
+       & ipc, i, count, err_act, i1, i2, ia
+  character                     :: check_,trans_,unitd_
+  character(len=5)              :: afmt_
+  Integer, Parameter            :: maxtry=8
+  logical, parameter            :: debug=.false.
+  character(len=20)             :: name, ch_err
+
+  name='psb_spcnv'
+  info  = 0
+  call psb_erractionsave(err_act)
+
+  ntry=0
+  
+  ifc_ = 2
+
+
+  check_ = 'N'
+  trans_ = 'N'
+  unitd_ = 'U'
+  allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
+
+  if (info /= 0) then
+    info=2040
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+
+  if (present(upd)) then 
+    call psb_sp_setifld(upd,psb_upd_,b,info)    
+  end if
+  if (present(dupl)) then 
+    call psb_sp_setifld(dupl,psb_dupl_,b,info)    
+  end if
+  if (present(afmt)) then 
+    afmt_ = afmt
+  else
+    afmt_ = psb_fidef_
+  end if
+
+  upd_ = psb_sp_getifld(psb_upd_,b,info)
+  select case(upd_)
+  case(psb_upd_srch_,psb_upd_perm_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    upd_ = psb_upd_dflt_
+    call psb_sp_setifld(upd_,psb_upd_,b,info)    
+  end select
+
+  dupl_ = psb_sp_getifld(psb_dupl_,b,info)
+  select case(dupl_)
+  case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    dupl_ = psb_dupl_def_
+    call psb_sp_setifld(dupl_,psb_dupl_,b,info)    
+  end select
+
+  !  ...matrix conversion...
+  b%m=a%m
+  b%k=a%k
+  b%fida=afmt_
+  size_req = psb_sp_get_nnzeros(a)
+  if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
+  !
+  n_row=b%m 
+  n_col=b%k
+  call psb_cest(afmt_,n_row,n_col,size_req,&
+       & ia1_size, ia2_size, aspk_size, upd_,info)
+  b%fida=afmt_
+
+  if (info /= psb_no_err_) then    
+    info=4010
+    ch_err='psb_cest'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  endif
+  if (.not.allocated(b%aspk).or.&
+       &.not.allocated(b%ia1).or.&
+       &.not.allocated(b%ia2).or.&
+       &.not.allocated(b%pl).or.&
+       &.not.allocated(b%pr)) then
+    call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+  else if ((size(b%aspk)  < aspk_size) .or.&
+       &(size(b%ia1) < ia1_size) .or.&
+       &(size(b%ia2) < ia2_size) .or.&
+       &(size(b%pl)  < b%m) .or.&
+       &(size(b%pr) < b%k )) then 
+    call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+  endif
+
+  if (info /= psb_no_err_) then    
+    info=4010
+    ch_err='psb_sp_reall'
+    call psb_errpush(info,name,a_err=ch_err)
+    goto 9999
+  endif
+
+  b%pl(:)  = 0
+  b%pr(:)  = 0
+
+  b%descra = a%descra
+
+  select case (tolower(a%fida))
+
+  case ('csr')
+
+    select case (tolower(b%fida))
+
+    case ('csr')
+
+      call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, size(work), info)
+
+
+      if (info/=0) then
+        info=4010
+        ch_err='dcrcr'
+        call psb_errpush(info,name,a_err=ch_err)
+        goto 9999
+      end if
+
+    case ('jad')
+
+      !...converting to JAD
+      !...output matrix may not be big enough
+      do
+
+        call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+             & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+             & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+             & size(b%ia2), work, size(work), nzr, info)
+        if (info /= 0) then
+          call psb_errpush(4010,name,a_err='dcrjd')
+          goto 9999
+        endif
+
+        ntry = ntry + 1
+        if (debug) then 
+          write(0,*) 'On out from dcrjad ',nzr,info
+        end if
+        if (nzr == 0) exit
+        if (ntry > maxtry ) then 
+          write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+        call psb_cest(afmt_,n_row,n_col,nzr,&
+             & ia1_size, ia2_size, aspk_size, upd_,info)
+        call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
+        if (info /= 0) then
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+      end do
+
+      if (info/=0) then
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+
+    case ('coo')
+      if (debug) write(0,*) 'Calling CRCO ',a%descra
+      call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcrco')
+        goto 9999
+      end if
+    case default
+      info=4010
+      call psb_errpush(info,name)
+      goto 9999
+
+    end select
+
+  case ('coo','coi')
+
+    select case (tolower(b%fida))
+
+    case ('csr')
+
+      call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, 2*size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcocr')
+        goto 9999
+      end if
+
+    case ('jad')
+
+      call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
+      if (info /= 0) then
+        info=2040
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      temp_a%m = a%m
+      temp_a%k = a%k
+      temp_a%infoa=b%infoa
+      !...Dirty trick: converting to CSR and then to JAD
+
+      call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
+           & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
+           & size(temp_a%aspk), size(temp_a%ia1),&
+           & size(temp_a%ia2), work, 2*size(work), info)
+
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcocr')
+        goto 9999
+      end if
+
+      do
+        call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
+             & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
+             & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
+             & size(b%aspk), size(b%ia1),&
+             & size(b%ia2), work, size(work), nzr, info)
+        if (info/=0) then
+          call psb_errpush(4010,name,a_err='dcrjd')
+          goto 9999
+        end if
+
+        ntry = ntry + 1
+        if (debug) then 
+          write(0,*) 'On out from dcrjad ',nzr,info
+        end if
+        if (nzr == 0) exit
+        if (ntry > maxtry ) then 
+          write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
+               & ': giving up now.'
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+        call psb_sp_reall(b,nzr,info,ifc=ifc_)
+        if (info /= 0) then
+          info=2040
+          call psb_errpush(info,name)
+          goto 9999
+        endif
+
+      end do
+
+    case ('coo')
+
+      call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
+           & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
+           & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
+           & size(b%ia2), work, 2*size(work), info)
+      if (info/=0) then
+        call psb_errpush(4010,name,a_err='dcoco')
+        goto 9999
+      end if
+
+    case default
+      info=4010
+      call psb_errpush(info,name)
+      goto 9999
+    end select
+
+  case default
+    info=4010
+    call psb_errpush(info,name)
+    goto 9999
+
+  end select
+
+  if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
+       &      call psb_sp_trim(b,info)
+
+
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine psb_zspcnv2
+
+
+subroutine psb_zspcnv1(a, info, afmt, upd, dupl)
+
+  use psb_spmat_type
+  use psb_regen_mod
+  use psb_serial_mod, psb_protect_name => psb_zspcnv1
+  use psb_const_mod
+  use psi_mod
+  use psb_error_mod
+  use psb_string_mod
+  !use psb_penv_mod
+
+  implicit none
+
+
+  !...Parameters....
+  type(psb_zspmat_type), intent (inout)   :: a
+  integer, intent(out)                    :: info
+  integer,optional, intent(in)            :: dupl, upd
+  character(len=*), optional, intent(in)         :: afmt
+
+  integer               :: int_err(5)
+  type(psb_zspmat_type) :: atemp
+  integer               :: np,me,n_col,iout, err_act
+  integer               :: spstate
+  integer               :: upd_, dupl_
+  integer               :: ictxt,n_row
+  logical, parameter    :: debug=.false., debugwrt=.false.
+  character(len=20)     :: name, ch_err
+
+  info = 0
+  int_err(1)=0
+  name = 'psb_spcnv'
+  call psb_erractionsave(err_act)
+
+  if (present(upd)) then 
+    call psb_sp_setifld(upd,psb_upd_,a,info)    
+  end if
+  if (present(dupl)) then 
+    call psb_sp_setifld(dupl,psb_dupl_,a,info)    
+  end if
+
+  upd_ = psb_sp_getifld(psb_upd_,a,info)
+  select case(upd_)
+  case(psb_upd_srch_,psb_upd_perm_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    upd_ = psb_upd_dflt_
+    call psb_sp_setifld(upd_,psb_upd_,a,info)    
+  end select
+
+  dupl_ = psb_sp_getifld(psb_dupl_,a,info)
+  select case(dupl_)
+  case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
+    ! Legal value, do nothing
+  case default
+    ! Fix bad value
+    dupl_ = psb_dupl_def_
+    call psb_sp_setifld(dupl_,psb_dupl_,a,info)    
+  end select
+
+
+  spstate = psb_sp_getifld(psb_state_,a,info)
+  if (info /= 0) then 
+    goto 9999
+  endif
+  if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
+  if (spstate /= psb_spmat_upd_) then 
+    ! Should we first figure out if we can do it in place? 
+    if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_
+    if (upd_ == psb_upd_srch_) then 
+      if (present(afmt)) then 
+        select case (tolower(a%fida))
+        case('coo')
+          select case(tolower(afmt))
+          case('coo') 
+            call psb_fixcoo(a,info)
+            goto 9998
+          case('csr') 
+            call psb_ipcoo2csr(a,info)
+            goto 9998
+          case('csc')
+            call psb_ipcoo2csc(a,info)
+            goto 9998
+          end select
+        case('csr')
+          select case(tolower(afmt))
+          case('coo') 
+            call psb_ipcsr2coo(a,info)
+            goto 9998
+          end select
+        end select
+      end if
+    end if
+
+    call psb_sp_clone(a,atemp,info)
+    if(info /= psb_no_err_) then
+      info=4010
+      ch_err='psb_sp_clone'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+      ! convert to user requested format after the temp copy
+    end if
+
+    if (debugwrt) then
+      iout = 30+me
+      open(iout)
+      call psb_csprt(iout,atemp,head='Input mat')
+      close(iout)
+    endif
+
+    ! Do the real conversion into the requested storage format
+    ! result is put in A
+    call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl)
+
+    IF (debug) WRITE (*, *) me,'   ASB:  From SPCNV',info,' ',A%FIDA
+    if (info /= psb_no_err_) then    
+      info=4010
+      ch_err='psb_csdp'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    endif
+
+    if (debugwrt) then
+      iout = 60+me
+      open(iout)
+      call psb_csprt(iout,a,head='Output mat')
+      close(iout)
+    endif
+
+    call psb_sp_free(atemp,info)
+
+  else if (spstate == psb_spmat_upd_) then
+    !
+    ! Second  case: we come from an update loop.
+    ! 
+    select case(tolower(a%fida))
+    case('csr')
+      call csr_regen(a,info)
+    case ('coo','coi')
+      call coo_regen(a,info)
+    case('jad')
+      call jad_regen(a,info)
+    case default
+      info=136
+      ch_err=a%fida 
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    end select
+    
+    
+    ! check on error retuned by dcsdp
+    if (info /= psb_no_err_) then
+      info = 4010
+      ch_err='xx_regen'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    end if
+
+  else
+
+    info = 600
+    call psb_errpush(info,name)
+    goto 9999
+    if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
+
+  endif
+
+9998 continue
+
+  call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+  
+end subroutine psb_zspcnv1

base/serial/psb_zspgetrow.f90

@@ -87,21 +87,19 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
     nzin_ = 0
   endif
 
-  if (toupper(a%fida) == 'CSR') then 
+  select case (tolower(a%fida))
+  case ('csr')
     call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-     
+  case ('coo')
-  else if (toupper(a%fida) == 'COO') then 
     call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-     
+  case ('jad')
-  else if (toupper(a%fida) == 'JAD') then 
     call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
-
+  case default
-  else
     info=136
     ch_err=a%fida(1:3)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
-  end if
+  end select
   
   if (info /= 0) goto 9999
 !!$  call psb_erractionrestore(err_act)

base/serial/psb_ztransc.f90

@@ -36,11 +36,11 @@ subroutine psb_ztransc(a,b,c,fmt)
   use psb_spmat_type
   use psb_tools_mod
   use psb_string_mod
-  use psb_realloc_mod
+  use psb_serial_mod, psb_protect_name => psb_ztransc
-  use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
   implicit none
 
-  type(psb_zspmat_type)      :: a,b
+  type(psb_zspmat_type), intent(inout) :: a
+  type(psb_zspmat_type), intent(out)   :: b
   integer, optional          :: c
   character(len=*), optional :: fmt
 
@@ -59,55 +59,26 @@ subroutine psb_ztransc(a,b,c,fmt)
   else 
     fmt_='CSR'
   endif
-  if (.true.) then 
+
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
+  call psb_nullify_sp(b)
-    b%fida   = 'COO'
+  
-    b%descra = 'GUN'
+  call psb_spcnv(a,b,info,afmt='coo')
-    call psb_csdp(a,b,info)
+  
-!!$    write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
   if (info /= 0) then 
     write(0,*) 'transp: info from CSDP ',info
     return
   end if
-  else
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
-    call psb_sp_clone(a,b,info)
-    
-    if (b%fida=='CSR') then 
-      call psb_ipcsr2coo(b,info)
-    else if (b%fida=='COO') then 
-      ! do nothing 
-    else
-      write(0,*) 'Unimplemented case in TRANSC '
-    endif
-  endif
-
   call psb_transfer(b%ia1,itmp,info)
   call psb_transfer(b%ia2,b%ia1,info)
   call psb_transfer(itmp,b%ia2,info)
 
-  b%m = a%k 
-  b%k = a%m
-  
   do i=1, b%infoa(psb_nnz_) 
     b%aspk(i) = conjg(b%aspk(i))
   end do
 
-  if (fmt_=='CSR') then 
+  b%m = a%k 
-    call psb_ipcoo2csr(b,info)
+  b%k = a%m
-    b%fida='CSR'
+  call psb_spcnv(b,info,afmt=fmt_)
-  else if (fmt_=='COO') then 
-    call psb_fixcoo(b,info)
-    b%fida='COO'
-  else
-    call psb_nullify_sp(tmp)
-    call psb_sp_clone(b,tmp,info)
-    b%fida=fmt_
-    call psb_csdp(tmp,b,info)
-    !!!!!! ADD HERE ERRPUSH!!! 
-    call psb_sp_free(tmp,info)
-
-  endif
 
   return
 end subroutine psb_ztransc

base/serial/psb_ztransp.f90

@@ -36,11 +36,11 @@ subroutine psb_ztransp(a,b,c,fmt)
   use psb_spmat_type
   use psb_tools_mod
   use psb_string_mod
-  use psb_realloc_mod
+  use psb_serial_mod, psb_protect_name => psb_ztransp
-  use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
   implicit none
 
-  type(psb_zspmat_type)      :: a,b
+  type(psb_zspmat_type), intent(inout) :: a
+  type(psb_zspmat_type), intent(out)   :: b
   integer, optional          :: c
   character(len=*), optional :: fmt
 
@@ -60,51 +60,21 @@ subroutine psb_ztransp(a,b,c,fmt)
     fmt_='CSR'
   endif
 
-  if (.true.) then 
+  call psb_nullify_sp(b)
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
+  
-    b%fida   = 'COO'
+  call psb_spcnv(a,b,info,afmt='coo')
-    b%descra = 'GUN'
+  
-    call psb_csdp(a,b,info)
-!!$    write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
   if (info /= 0) then 
     write(0,*) 'transp: info from CSDP ',info
     return
   end if
-  else
-    if (allocated(b%aspk)) call psb_sp_free(b,info)
-    call psb_sp_clone(a,b,info)
-    
-    if (b%fida=='CSR') then 
-      call psb_ipcsr2coo(b,info)
-    else if (b%fida=='COO') then 
-      ! do nothing 
-    else
-      write(0,*) 'Unimplemented case in TRANSP '
-    endif
-  endif
-
   call psb_transfer(b%ia1,itmp,info)
   call psb_transfer(b%ia2,b%ia1,info)
   call psb_transfer(itmp,b%ia2,info)
 
   b%m = a%k 
   b%k = a%m
-
+  call psb_spcnv(b,info,afmt=fmt_)
-  if (fmt_=='CSR') then 
-    call psb_ipcoo2csr(b,info)
-    b%fida='CSR'
-  else if (fmt_=='COO') then 
-    call psb_fixcoo(b,info)
-    b%fida='COO'
-  else
-    call psb_nullify_sp(tmp)
-    call psb_sp_clone(b,tmp,info)
-    b%fida=fmt_
-    call psb_csdp(tmp,b,info)
-    !!!!!! ADD HERE ERRPUSH!!! 
-    call psb_sp_free(tmp,info)
-
-  endif
 
   return
 end subroutine psb_ztransp

base/tools/Makefile

@@ -6,11 +6,11 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \
 	psb_cdfree.o psb_cdins.o  \
 	psb_cdren.o psb_cdrep.o psb_cdtransfer.o psb_get_overlap.o\
 	psb_dspalloc.o psb_dspasb.o \
-	psb_dspcnv.o psb_dspfree.o psb_dspins.o psb_dsprn.o \
+	psb_dspfree.o psb_dspins.o psb_dsprn.o \
 	psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \
 	psb_ifree.o psb_iins.o psb_loc_to_glob.o\
 	psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \
-	psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\
+	psb_zspalloc.o psb_zspasb.o psb_zspfree.o\
 	psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o
 
 MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_icdasb.o psb_dcdovr.o psb_zcdovr.o

base/tools/psb_dspalloc.f90

@@ -117,16 +117,6 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
     goto 9999
   end if
 
-  ! set permutation matrices
-  a%pl(1)=0
-  a%pr(1)=0
-  ! set infoa fields
-  a%fida   = 'COO'
-  a%descra = 'GUN'
-  a%infoa(psb_nnz_)  = 0
-  a%infoa(psb_srtd_) = 0
-  a%infoa(psb_state_) = psb_spmat_bld_
-
   if (debug) write(0,*) 'spall: ',  &
        & psb_cd_get_dectype(desc_a),psb_desc_bld_
 

base/tools/psb_dspasb.f90

@@ -60,12 +60,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
   type(psb_desc_type), intent(in)         :: desc_a
   integer, intent(out)                    :: info
   integer,optional, intent(in)            :: dupl, upd
-  character, optional, intent(in)         :: afmt*5
+  character(len=*), optional, intent(in)         :: afmt
   !....Locals....
   integer               :: int_err(5)
   type(psb_dspmat_type) :: atemp
   integer               :: np,me,n_col,iout, err_act
-  integer               :: dscstate, spstate
+  integer               :: spstate
   integer               :: upd_, dupl_
   integer               :: ictxt,n_row
   logical, parameter    :: debug=.false., debugwrt=.false.
@@ -77,7 +77,6 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
   call psb_erractionsave(err_act)
 
   ictxt    = psb_cd_get_context(desc_a)
-  dscstate = psb_cd_get_dectype(desc_a)
   n_row    = psb_cd_get_local_rows(desc_a)
   n_col    = psb_cd_get_local_cols(desc_a)
 
@@ -89,9 +88,9 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
     goto 9999
   endif
 
-  if (.not.psb_is_asb_dec(dscstate)) then 
+  if (.not.psb_is_asb_desc(desc_a)) then 
     info = 600
-    int_err(1) = dscstate
+    int_err(1) = psb_cd_get_dectype(desc_a)
     call psb_errpush(info,name)
     goto 9999
   endif
@@ -105,123 +104,23 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
     !
     ! First case: we come from a fresh build. 
     ! 
+
     n_row = psb_cd_get_local_rows(desc_a)
     n_col = psb_cd_get_local_cols(desc_a)
-
-
-    !
-    ! Second step: handle the local matrix part. 
-    !
-    if (present(upd)) then 
-      upd_=upd
-    else
-      upd_ = psb_upd_dflt_
-    endif
-
-    if (present(dupl)) then
-      select case(dupl) 
-      case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
-        dupl_ = dupl
-      case default
-        dupl_ =  psb_dupl_def_
-      end select
-    else
-      dupl_ =  psb_dupl_def_
-    endif
-
     a%m = n_row
     a%k = n_col
-
-    call psb_sp_clone(a,atemp,info)
-    if(info /= psb_no_err_) then
-      info=4010
-      ch_err='psb_sp_clone'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-      ! convert to user requested format after the temp copy
-    end if
-
-    if (present(afmt)) then
-      a%fida = afmt
-    else 
-      a%fida = '???'
   end if
 
-    if (debugwrt) then
+  call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl)
-      iout = 30+me
-      open(iout)
-      call psb_csprt(iout,atemp,head='Input mat')
-      close(iout)
-    endif
-
-    ! Do the real conversion into the requested storage format
-    ! result is put in A
-    call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_)
 
   IF (debug) WRITE (*, *) me,'   ASB:  From DCSDP',info,' ',A%FIDA
   if (info /= psb_no_err_) then    
     info=4010
-      ch_err='psb_csdp'
+    ch_err='psb_spcnv'
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
 
-    if (debugwrt) then
-      iout = 60+me
-      open(iout)
-      call psb_csprt(iout,a,head='Output mat')
-      close(iout)
-    endif
-
-    call psb_sp_free(atemp,info)
-
-
-  else if (spstate == psb_spmat_upd_) then
-    !
-    ! Second  case: we come from an update loop.
-    ! 
-
-
-    ! Right now, almost nothing to be done, but this 
-    ! may change in the future
-    ! as we revise the implementation of the update routine. 
-    call psb_sp_all(atemp,1,info)
-    atemp%m=a%m
-    atemp%k=a%k
-    ! check on allocation
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_sp_all'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-
-    call psb_csdp(atemp,a,info,check='R')
-    ! check on error retuned by dcsdp
-    if (info /= psb_no_err_) then
-      info = 4010
-      ch_err='psb_csdp90'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
-
-    call psb_sp_free(atemp,info)
-    if (info /= psb_no_err_) then
-      info = 4010
-      ch_err='sp_free'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
-
-  else
-
-    info = 600
-    call psb_errpush(info,name)
-    goto 9999
-    if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
-
-  endif
-
   call psb_erractionrestore(err_act)
   return
 

base/tools/psb_dspcnv.f90

@@ -1,242 +0,0 @@
-!!$ 
-!!$              Parallel Sparse BLAS  v2.0
-!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
-!!$                       Alfredo Buttari        University of Rome Tor Vergata
-!!$ 
-!!$  Redistribution and use in source and binary forms, with or without
-!!$  modification, are permitted provided that the following conditions
-!!$  are met:
-!!$    1. Redistributions of source code must retain the above copyright
-!!$       notice, this list of conditions and the following disclaimer.
-!!$    2. Redistributions in binary form must reproduce the above copyright
-!!$       notice, this list of conditions, and the following disclaimer in the
-!!$       documentation and/or other materials provided with the distribution.
-!!$    3. The name of the PSBLAS group or the names of its contributors may
-!!$       not be used to endorse or promote products derived from this
-!!$       software without specific written permission.
-!!$ 
-!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
-!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!!$  POSSIBILITY OF SUCH DAMAGE.
-!!$ 
-!!$  
-! File: psb_dspcnv.f90
-!
-! Subroutine: psb_dspcnv
-!    converts sparse matrix a into b
-! 
-! Parameters: 
-!    a        - type(<psb_dspmat_type>).          The sparse input matrix.      
-!    b        - type(<psb_dspmat_type>).          The sparse output matrix.
-!    desc_a   - type(<psb_desc_type>).            The communication descriptor.
-!    info     - integer.                          Eventually returns an error code.
-!
-subroutine psb_dspcnv(a,b,desc_a,info)
-
-  use psb_descriptor_type
-  use psb_spmat_type
-  use psb_realloc_mod
-  use psb_serial_mod
-  use psb_const_mod
-  use psb_error_mod
-  use psb_penv_mod
-  implicit none
-  interface dcsdp
-
-    subroutine dcsdp(check,trans,m,n,unitd,d,&
-         & fida,descra,a,ia1,ia2,infoa,&
-         & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,&
-         & work,lwork,ierror)
-      integer, intent(in)   :: lh, lwork, lh1, lh2, m, n                 
-      integer, intent(out)  :: ierror                 
-      character, intent(in) :: check, trans, unitd                               
-      real(kind(1.d0)), intent(in)  :: d(*), a(*)
-      real(kind(1.d0)), intent(out) :: h(*)
-      real(kind(1.d0)), intent(inout) :: work(*)
-      integer, intent(in)  :: ia1(*), ia2(*), infoa(*)
-      integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) 
-      character, intent(in) ::  fida*5, descra*11
-      character, intent(out) :: fidh*5, descrh*11
-    end subroutine dcsdp
-  end interface
-
-
-  interface dcsrp
-
-    subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,&
-         & infoa,p,work,lwork,ierror)
-      integer, intent(in)  :: m, n, lwork
-      integer, intent(out) :: ierror
-      character, intent(in) ::       trans
-      real(kind(1.d0)), intent(inout) :: work(*)                     
-      integer, intent(in)    :: p(*)
-      integer, intent(inout) :: ia1(*), ia2(*), infoa(*) 
-      character, intent(in)  :: fida*5, descra*11
-    end subroutine dcsrp
-  end interface
-
-  interface dcsprt
-    subroutine dcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror)
-      integer, intent(in)  ::  iout,m, n                 
-      integer, intent(out) ::  ierror                 
-      real(kind(1.d0)), intent(in) :: a(*)
-      integer, intent(in)   :: ia1(*), ia2(*), infoa(*)
-      character, intent(in) :: fida*5, descra*11
-    end subroutine dcsprt
-  end interface
-
-  !...parameters....
-  type(psb_dspmat_type), intent(in)   :: a
-  type(psb_dspmat_type), intent(out)  :: b
-  type(psb_desc_type), intent(in)     :: desc_a
-  integer, intent(out)                :: info
-  !....locals....
-  integer                       ::  int_err(5)
-  real(kind(1.d0))              ::  d(1)
-  integer,allocatable           ::  i_temp(:)
-  real(kind(1.d0)),allocatable  ::  work_dcsdp(:)
-  integer                       ::  ia1_size,ia2_size,aspk_size,&
-       & err_act,i,np,me,n_col,l_dcsdp
-  integer                       ::  lwork_dcsdp,dectype
-  integer                       ::  ictxt,n_row
-  character                     ::  check*1, trans*1, unitd*1
-
-  logical, parameter :: debug=.false.
-  character(len=20)   :: name, ch_err
-
-  if(psb_get_errstatus() /= 0) return 
-  info=0
-  name = 'psb_dspcnv'
-  call psb_erractionsave(err_act)
-
-
-  ictxt   = psb_cd_get_context(desc_a)
-  dectype = psb_cd_get_dectype(desc_a)
-  n_row   = psb_cd_get_local_rows(desc_a)
-  n_col   = psb_cd_get_local_cols(desc_a)
-
-  ! check on blacs grid 
-  call psb_info(ictxt, me, np)
-  if (np == -1) then
-    info = 2010
-    call psb_errpush(info,name)
-    goto 9999
-  endif
-
-  if (.not.psb_is_ok_dec((dectype))) then
-    info = 600
-    int_err(1) = dectype
-    call psb_errpush(info,name,i_err=int_err)
-    goto 9999
-  endif
-
-  if (debug) write (0, *) name,'   begin matrix assembly...'
-
-  ia1_size  = size(a%ia1)
-  ia2_size  = size(a%ia2)
-  aspk_size = size(a%aspk)
-
-  if (debug) write (0, *) name,'  sizes',ia1_size,ia2_size,aspk_size
-
-  ! convert only without check
-  check='N'
-  trans='N'
-  unitd='U'
-
-  ! l_dcsdp is the size requested for dcsdp procedure
-  l_dcsdp=(ia1_size+100)
-
-  b%m=n_row
-  b%k=n_col
-  call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info)
-  allocate(work_dcsdp(l_dcsdp),stat=info)
-  if (info /= 0) then
-    info=4025
-    int_err(1)=l_dcsdp
-    call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))')
-    goto 9999
-  endif
-
-  lwork_dcsdp=size(work_dcsdp)
-  ! set infoa(1) to nnzero
-  b%pl(:)  = 0
-  b%pr(:)  = 0
-
-  if (debug) write (0, *) name,'  calling dcsdp',lwork_dcsdp,&
-       &size(work_dcsdp)
-  ! convert aspk,ia1,ia2 in requested representation mode
-  if (debug) then
-
-  endif
-  ! result is put in b
-  call dcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,&
-       & a%aspk,a%ia1,a%ia2,a%infoa,&
-       & b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,&
-       & size(b%aspk),size(b%ia1),size(b%ia2),&
-       & work_dcsdp,size(work_dcsdp),info)
-
-  if(info /= psb_no_err_) then
-    info=4010
-    ch_err='dcsdp'
-    call psb_errpush(info, name, a_err=ch_err)
-    goto 9999
-  end if
-
-  !
-  !  hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! 
-  !  should work (crossed fingers :-)
-  if (a%pr(1) /= 0) then 
-    if (b%pr(1) /= 0) then 
-      allocate(i_temp(n_col))
-      do i=1,  n_col
-        i_temp(i) = b%pr(a%pr(i))
-      enddo
-      call psb_transfer(i_temp,b%pr,info)
-    else
-      allocate(i_temp(n_col))
-      do i=1,  n_col
-        i_temp(i) = a%pr(i)
-      enddo
-      call psb_transfer(i_temp,b%pr,info)
-    endif
-  endif
-  if (a%pl(1) /= 0) then 
-    if (b%pr(1) /= 0) then 
-      allocate(i_temp(n_row))
-      do i=1,  n_row
-        i_temp(i) = a%pl(b%pl(i))
-      enddo
-      call psb_transfer(i_temp,b%pl,info)
-    else
-      allocate(i_temp(n_row))
-      do i=1,  n_row
-        i_temp(i) = a%pl(i)
-      enddo
-      call psb_transfer(i_temp,b%pl,info)
-    endif
-  endif
-
-
-  if (debug) write (0, *) me,name,'  from dcsdp ',&
-       &b%fida,' pl ', b%pl(:),'pr',b%pr(:)
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_erractionrestore(err_act)
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
-    return
-  end if
-  return
-
-end subroutine psb_dspcnv

base/tools/psb_zspalloc.f90

@@ -115,16 +115,6 @@ subroutine psb_zspalloc(a, desc_a, info, nnz)
     goto 9999
   end if
 
-  ! set permutation matrices
-  a%pl(1)=0
-  a%pr(1)=0
-  ! set infoa fields
-  a%fida   = 'COO'
-  a%descra = 'GUN'
-  a%infoa(psb_nnz_)  = 0
-  a%infoa(psb_srtd_) = 0
-  a%infoa(psb_state_) = psb_spmat_bld_
-
   if (debug) write(0,*) 'spall: ',  &
        & psb_cd_get_dectype(desc_a),psb_desc_bld_
 

base/tools/psb_zspasb.f90

@@ -60,7 +60,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
   type(psb_desc_type), intent(in)         :: desc_a
   integer, intent(out)                    :: info
   integer,optional, intent(in)            :: dupl, upd
-  character, optional, intent(in)         :: afmt*5
+  character(len=*), optional, intent(in)         :: afmt
   !....Locals....
   integer               :: int_err(5)
   type(psb_zspmat_type) :: atemp
@@ -107,120 +107,20 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
 
     n_row = psb_cd_get_local_rows(desc_a)
     n_col = psb_cd_get_local_cols(desc_a)
-
-    !
-    ! Second step: handle the local matrix part. 
-    !
-    if (present(upd)) then 
-      upd_=upd
-    else
-      upd_ = psb_upd_dflt_
-    endif
-
-    if (present(dupl)) then
-      select case(dupl) 
-      case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
-        dupl_ = dupl
-      case default
-        dupl_ =  psb_dupl_def_
-      end select
-    else
-      dupl_ =  psb_dupl_def_
-    endif
-
     a%m = n_row
     a%k = n_col
-
-    call psb_sp_clone(a,atemp,info)
-    if(info /= psb_no_err_) then
-      info=4010
-      ch_err='psb_sp_clone'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-      ! convert to user requested format after the temp copy
   end if
 
-    if (present(afmt)) then
+  call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl)
-      a%fida = afmt
-    else 
-      a%fida = '???'
-    endif
 
-    if (debugwrt) then
+  IF (debug) WRITE (*, *) me,'   ASB:  From DCSDP',info,' ',A%FIDA
-      iout = 30+me
-      open(iout)
-      call psb_csprt(iout,atemp,head='Input mat')
-      close(iout)
-    endif
-
-    ! Do the real conversion into the requested storage format
-    ! result is put in A
-    call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_)
-
-    IF (debug) WRITE (*, *) me,'   ASB:  From ZCSDP',info,' ',A%FIDA
   if (info /= psb_no_err_) then    
     info=4010
-      ch_err='psb_csdp'
+    ch_err='psb_spcnv'
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
 
-    if (debugwrt) then
-      iout = 60+me
-      open(iout)
-      call psb_csprt(iout,a,head='Output mat')
-      close(iout)
-    endif
-
-    call psb_sp_free(atemp,info)
-
-
-  else if (spstate == psb_spmat_upd_) then
-    !
-    ! Second  case: we come from an update loop.
-    ! 
-
-
-    ! Right now, almost nothing to be done, but this 
-    ! may change in the future
-    ! as we revise the implementation of the update routine. 
-    call psb_sp_all(atemp,1,info)
-    atemp%m=a%m
-    atemp%k=a%k
-    ! check on allocation
-    if (info /= psb_no_err_) then    
-      info=4010
-      ch_err='psb_sp_all'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    endif
-
-    call psb_csdp(atemp,a,info,check='R')
-    ! check on error retuned by zcsdp
-    if (info /= psb_no_err_) then
-      info = 4010
-      ch_err='psb_csdp90'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
-
-    call psb_sp_free(atemp,info)
-    if (info /= psb_no_err_) then
-      info = 4010
-      ch_err='sp_free'
-      call psb_errpush(info,name,a_err=ch_err)
-      goto 9999
-    end if
-
-  else
-
-    info = 600
-    call psb_errpush(info,name)
-    goto 9999
-    if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
-
-  endif
-
   call psb_erractionrestore(err_act)
   return
 

base/tools/psb_zspcnv.f90

@@ -1,243 +0,0 @@
-!!$ 
-!!$              Parallel Sparse BLAS  v2.0
-!!$    (C) Copyright 2006 Salvatore Filippone    University of Rome Tor Vergata
-!!$                       Alfredo Buttari        University of Rome Tor Vergata
-!!$ 
-!!$  Redistribution and use in source and binary forms, with or without
-!!$  modification, are permitted provided that the following conditions
-!!$  are met:
-!!$    1. Redistributions of source code must retain the above copyright
-!!$       notice, this list of conditions and the following disclaimer.
-!!$    2. Redistributions in binary form must reproduce the above copyright
-!!$       notice, this list of conditions, and the following disclaimer in the
-!!$       documentation and/or other materials provided with the distribution.
-!!$    3. The name of the PSBLAS group or the names of its contributors may
-!!$       not be used to endorse or promote products derived from this
-!!$       software without specific written permission.
-!!$ 
-!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
-!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!!$  POSSIBILITY OF SUCH DAMAGE.
-!!$ 
-!!$  
-! File: psb_zspcnv.f90
-!
-! Subroutine: psb_zspcnv
-!    converts sparse matrix a into b
-! 
-! Parameters: 
-!    a        - type(<psb_zspmat_type>).          The sparse input matrix.      
-!    b        - type(<psb_zspmat_type>).          The sparse output matrix.
-!    desc_a   - type(<psb_desc_type>).            The communication descriptor.
-!    info     - integer.                          Eventually returns an error code.
-!
-subroutine psb_zspcnv(a,b,desc_a,info)
-
-  use psb_descriptor_type
-  use psb_spmat_type
-  use psb_realloc_mod
-  use psb_serial_mod
-  use psb_const_mod
-  use psb_error_mod
-  use psb_penv_mod
-  implicit none
-
-  interface zcsdp
-
-    subroutine zcsdp(check,trans,m,n,unitd,d,&
-         & fida,descra,a,ia1,ia2,infoa,&
-         & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,&
-         & work,lwork,ierror)
-      integer, intent(in)   :: lh, lwork, lh1, lh2, m, n                 
-      integer, intent(out)  :: ierror                 
-      character, intent(in) :: check, trans, unitd                               
-      complex(kind(1.d0)), intent(in)  :: d(*), a(*)
-      complex(kind(1.d0)), intent(out) :: h(*)
-      complex(kind(1.d0)), intent(inout) :: work(*)
-      integer, intent(in)  :: ia1(*), ia2(*), infoa(*)
-      integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) 
-      character, intent(in) ::  fida*5, descra*11
-      character, intent(out) :: fidh*5, descrh*11
-    end subroutine zcsdp
-  end interface
-
-
-  interface zcsrp
-
-    subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,&
-         & infoa,p,work,lwork,ierror)
-      integer, intent(in)  :: m, n, lwork
-      integer, intent(out) :: ierror
-      character, intent(in) ::       trans
-      complex(kind(1.d0)), intent(inout) :: work(*)                     
-      integer, intent(in)    :: p(*)
-      integer, intent(inout) :: ia1(*), ia2(*), infoa(*) 
-      character, intent(in)  :: fida*5, descra*11
-    end subroutine zcsrp
-  end interface
-
-  interface zcsprt
-    subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror)
-      integer, intent(in)  ::  iout,m, n                 
-      integer, intent(out) ::  ierror                 
-      complex(kind(1.d0)), intent(in) :: a(*)
-      integer, intent(in)   :: ia1(*), ia2(*), infoa(*)
-      character, intent(in) :: fida*5, descra*11
-    end subroutine zcsprt
-  end interface
-
-  !...parameters....
-  type(psb_zspmat_type), intent(in)   :: a
-  type(psb_zspmat_type), intent(out)  :: b
-  type(psb_desc_type), intent(in)     :: desc_a
-  integer, intent(out)                :: info
-  !....locals....
-  integer                       ::  int_err(5)
-  complex(kind(1.d0))           ::  d(1)
-  integer,allocatable           ::  i_temp(:)
-  complex(kind(1.d0)),allocatable ::  work_dcsdp(:)
-  integer                       ::  ia1_size,ia2_size,aspk_size,err_act&
-       & ,i,err,np,me,n_col,l_dcsdp
-  integer                       ::  lwork_dcsdp,dectype
-  integer                       ::  ictxt,n_row
-  character                     ::  check*1, trans*1, unitd*1
-
-  logical, parameter :: debug=.false.
-  character(len=20)   :: name, ch_err
-
-  if(psb_get_errstatus() /= 0) return 
-  info=0
-  name = 'psb_zspcnv'
-  call psb_erractionsave(err_act)
-
-
-  ictxt   = psb_cd_get_context(desc_a)
-  dectype = psb_cd_get_dectype(desc_a)
-  n_row   = psb_cd_get_local_rows(desc_a)
-  n_col   = psb_cd_get_local_cols(desc_a)
-
-  ! check on blacs grid 
-  call psb_info(ictxt, me, np)
-  if (np == -1) then
-    info = 2010
-    call psb_errpush(info,name)
-    goto 9999
-  endif
-
-  if (.not.psb_is_ok_dec((dectype))) then
-    info = 600
-    int_err(1) = dectype
-    call psb_errpush(info,name,i_err=int_err)
-    goto 9999
-  endif
-
-  if (debug) write (0, *) name,'   begin matrix assembly...'
-
-  ia1_size  = size(a%ia1)
-  ia2_size  = size(a%ia2)
-  aspk_size = size(a%aspk)
-
-  if (debug) write (0, *) name,'  sizes',ia1_size,ia2_size,aspk_size
-
-  ! convert only without check
-  check='N'
-  trans='N'
-  unitd='U'
-
-  ! l_dcsdp is the size requested for dcsdp procedure
-  l_dcsdp=(ia1_size+100)
-
-  b%m=n_row
-  b%k=n_col
-  call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info)
-  allocate(work_dcsdp(l_dcsdp),stat=info)
-  if (info /= 0) then
-    info=4025
-    int_err(1)=l_dcsdp
-    call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))')
-    goto 9999
-  endif
-
-  lwork_dcsdp=size(work_dcsdp)
-  ! set infoa(1) to nnzero
-  b%pl(:)  = 0
-  b%pr(:)  = 0
-
-  if (debug) write (0, *) name,'  calling dcsdp',lwork_dcsdp,&
-       &size(work_dcsdp)
-  ! convert aspk,ia1,ia2 in requested representation mode
-  if (debug) then
-
-  endif
-  ! result is put in b
-  call zcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,&
-       & a%aspk,a%ia1,a%ia2,a%infoa,&
-       & b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,&
-       & size(b%aspk),size(b%ia1),size(b%ia2),&
-       & work_dcsdp,size(work_dcsdp),info)
-
-  if(info /= psb_no_err_) then
-    info=4010
-    ch_err='zcsdp'
-    call psb_errpush(info, name, a_err=ch_err)
-    goto 9999
-  end if
-
-  !
-  !  hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! 
-  !  should work (crossed fingers :-)
-  if (a%pr(1) /= 0) then 
-    if (b%pr(1) /= 0) then 
-      allocate(i_temp(n_col))
-      do i=1,  n_col
-        i_temp(i) = b%pr(a%pr(i))
-      enddo
-      call psb_transfer(i_temp,b%pr,info)
-    else
-      allocate(i_temp(n_col))
-      do i=1,  n_col
-        i_temp(i) = a%pr(i)
-      enddo
-      call psb_transfer(i_temp,b%pr,info)
-    endif
-  endif
-  if (a%pl(1) /= 0) then 
-    if (b%pr(1) /= 0) then 
-      allocate(i_temp(n_row))
-      do i=1,  n_row
-        i_temp(i) = a%pl(b%pl(i))
-      enddo
-      call psb_transfer(i_temp,b%pl,info)
-    else
-      allocate(i_temp(n_row))
-      do i=1,  n_row
-        i_temp(i) = a%pl(i)
-      enddo
-      call psb_transfer(i_temp,b%pl,info)
-    endif
-  endif
-
-
-  if (debug) write (0, *) me,name,'  from zcsdp ',&
-       &b%fida,' pl ', b%pl(:),'pr',b%pr(:)
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_erractionrestore(err_act)
-  if (err_act == psb_act_abort_) then
-    call psb_error(ictxt)
-    return
-  end if
-  return
-
-end subroutine psb_zspcnv

krylov/psb_zgmresr.f90

@@ -437,23 +437,6 @@ Subroutine psb_zgmresr(a,prec,b,x,eps,desc_a,info,&
 
 
 contains
-  function safe_dn2(a,b)
-    real(kind(1.d0)), intent(in) :: a, b
-    real(kind(1.d0))  :: safe_dn2
-    real(kind(1.d0))  :: t
-
-    t = max(abs(a),abs(b))
-    if (t==0.d0) then 
-      safe_dn2 = 0.d0
-    else
-      safe_dn2 = t * sqrt(abs(a/t)**2 + abs(b/t)**2)
-    endif
-    return
-  end function safe_dn2
-
-
-End Subroutine psb_zgmresr
-
 
   subroutine zrot( n, cx, incx, cy, incy, c, s )
     !
@@ -572,3 +555,4 @@ subroutine zrotg(ca,cb,c,s)
 
     return
   end subroutine zrotg
+End Subroutine psb_zgmresr