Changed extra environment file by adding preprocessing directives to

Fortran compilation in a single environment-dependent file.

src/internals/Makefile

@@ -3,7 +3,7 @@ include ../../Make.inc
 FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \
 	psi_crea_ovr_elem.o psi_dl_check.o \
 	psi_gthsct.o \
-	psi_sort_dl.o $(EXTRA_BLACS_P2P_OBJS)
+	psi_sort_dl.o 
 FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o 
 COBJS = avltree.o srcht.o
 

src/internals/krecvid.f90

@@ -1,7 +0,0 @@
-	integer function krecvid(contxt,proc_to_comm,myrow)
-	integer contxt,proc_to_comm,myrow
-
-	krecvid=32766
-
-	return
-	end

src/internals/ksendid.f90

@@ -1,7 +0,0 @@
-	integer function ksendid(contxt,proc_to_comm,myrow)
-	integer contxt,proc_to_comm,myrow
-
-	ksendid=32766
-
-	return
-	end

src/internals/psi_crea_bnd_elem.f90

@@ -28,12 +28,13 @@
 !!$  POSSIBILITY OF SUCH DAMAGE.
 !!$ 
 !!$  
-subroutine psi_crea_bnd_elem(desc_a,info)
-
+subroutine psi_crea_bnd_elem(bndel,desc_a,info)
+  use psb_realloc_mod
   use psb_descriptor_type
   use psb_error_mod
   implicit none
-
+  
+  integer, pointer     :: bndel(:)
   type(psb_desc_type)  :: desc_a
   integer, intent(out) :: info
 
@@ -82,20 +83,26 @@ subroutine psi_crea_bnd_elem(desc_a,info)
 
 
   if (.true.) then 
-    allocate(desc_a%bnd_elem(j),stat=info)
-    if (info /= 0) then 
-      call psb_errpush(4010,name,a_err='Allocate')
-      goto 9999      
+    if (j>0) then 
+      allocate(bndel(j),stat=info)
+      if (info /= 0) then 
+        call psb_errpush(4010,name,a_err='Allocate')
+        goto 9999      
+      end if
+      bndel(1:j) = work(1:j)
+    else
+      if (associated(bndel)) then 
+        deallocate(bndel)
+      end if
     end if
-    desc_a%bnd_elem(1:j) = work(1:j)
   else
-    allocate(desc_a%bnd_elem(j+1),stat=info)
+    allocate(bndel(j+1),stat=info)
     if (info /= 0) then 
       call psb_errpush(4010,name,a_err='Allocate')
       goto 9999      
     end if
-    desc_a%bnd_elem(1:j) = work(1:j)
-    desc_a%bnd_elem(j+1) = -1
+    bndel(1:j) = work(1:j)
+    bndel(j+1) = -1
   endif
 
   deallocate(work)

src/modules/Makefile

@@ -6,7 +6,7 @@ MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
 	psb_prec_type.o psb_error_mod.o psb_prec_mod.o \
 	psb_methd_mod.o psb_const_mod.o \
 	psb_comm_mod.o psb_psblas_mod.o psi_mod.o \
-	psb_check_mod.o  $(EXTRA_BLACS_ENV_OBJS)
+	psb_check_mod.o blacs_env.o
 
 
 MPFOBJS = psb_penv_mod.o 
@@ -21,10 +21,13 @@ psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o
 psb_error_mod.o: psb_const_mod.o
 psb_penv_mod.o: psb_const_mod.o psb_error_mod.o
 psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o
+psb_desc_type.o: psb_const_mod.o
 psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
+psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o 
 psb_sparse_mod.o: $(MODULES) $(MPFOBJS)
 
-lib:  mpfobjs $(MODULES) $(OBJS)
+
+lib:  mpfobjs $(MODULES)  $(OBJS)
 	$(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS)
 	$(RANLIB) $(LIBDIR)/$(LIBNAME)
 	/bin/cp *$(.mod) ./parts.fh ../../lib

src/modules/extra_env.f90

@@ -1,20 +0,0 @@
-subroutine psb_set_coher(ictxt,isvch)
-  integer :: ictxt, isvch
-  ! Ensure global coherence for convergence checks.
-  Call blacs_get(ictxt,16,isvch)
-  Call blacs_set(ictxt,16,1)
-end subroutine psb_set_coher
-subroutine psb_restore_coher(ictxt,isvch)
-  integer :: ictxt, isvch
-  ! Ensure global coherence for convergence checks.
-  Call blacs_set(ictxt,16,isvch)
-end subroutine psb_restore_coher
-subroutine psb_get_mpicomm(ictxt,comm)
-  integer :: ictxt, comm
-  call blacs_get(ictxt,10,comm)
-end subroutine psb_get_mpicomm
-subroutine psb_get_rank(rank,ictxt,id)
-  integer :: rank,ictxt, id
-  integer :: blacs_pnum
-  rank =  blacs_pnum(ictxt,id,0)
-end subroutine psb_get_rank

src/modules/extra_env_essl.f90

@@ -1,17 +0,0 @@
-subroutine psb_set_coher(ictxt,isvch)
-  integer :: ictxt, isvch
-  ! Ensure global coherence for convergence checks.
-  ! Do nothing: ESSL does coherence by default,
-  ! and does not handle req=16 
-!!$  Call blacs_get(ictxt,16,isvch)
-!!$  Call blacs_set(ictxt,16,1)
-end subroutine psb_set_coher
-subroutine psb_restore_coher(ictxt,isvch)
-  integer :: ictxt, isvch
-  ! Ensure global coherence for convergence checks.
-!!$  Call blacs_set(ictxt,16,isvch)
-end subroutine psb_restore_coher
-subroutine psb_get_mpicomm(ictxt,comm)
-  integer :: ictxt, comm
-  call blacs_get(ictxt,10,comm)
-end subroutine psb_get_mpicomm

src/modules/psb_desc_type.f90

@@ -49,10 +49,10 @@ module psb_descriptor_type
     ! contain indices of boundary  elements 
     integer, pointer :: bnd_elem(:)=>null()
     ! contain index of overlap elements to send/receive
-    integer, pointer :: ovrlap_elem(:)=>null()
+    integer, pointer :: ovrlap_index(:)=>null()
     ! contain for each local overlap element, the number of times
     ! that is duplicated
-    integer, pointer :: ovrlap_index(:)=>null()
+    integer, pointer :: ovrlap_elem(:)=>null()
     ! contain for each local element the corresponding global index
     integer, pointer :: loc_to_glob(:)=>null()
     ! contain for each global element the corresponding local index,

src/modules/psb_realloc_mod.f90

@@ -49,9 +49,94 @@ module psb_realloc_mod
          & psb_dcpy1d, psb_dcpy2d, psb_zcpy1d, psb_zcpy2d
   end Interface
 
-
+  interface psb_size
+    module procedure psb_isize1d, psb_isize2d,&
+         & psb_dsize1d, psb_dsize2d,&
+         & psb_zsize1d, psb_zsize2d
+  end interface
+    
 contains
   
+  function psb_isize1d(vin)
+    integer :: psb_isize1d
+    integer, pointer :: vin(:)
+    
+    if (.not.associated(vin)) then 
+      psb_isize1d = 0
+    else
+      psb_isize1d = size(vin)
+    end if
+  end function psb_isize1d
+  function psb_isize2d(vin,dim)
+    integer :: psb_isize2d
+    integer, pointer :: vin(:,:)
+    integer, optional :: dim
+
+    if (.not.associated(vin)) then 
+      psb_isize2d = 0
+    else
+      if (present(dim)) then 
+        psb_isize2d = size(vin,dim=dim)
+      else
+        psb_isize2d = size(vin)
+      end if
+    end if
+  end function psb_isize2d
+  
+  function psb_dsize1d(vin)
+    integer :: psb_dsize1d
+    real(kind(1.d0)), pointer :: vin(:)
+    
+    if (.not.associated(vin)) then 
+      psb_dsize1d = 0
+    else
+      psb_dsize1d = size(vin)
+    end if
+  end function psb_dsize1d
+  function psb_dsize2d(vin,dim)
+    integer :: psb_dsize2d
+    real(kind(1.d0)), pointer :: vin(:,:)
+    integer, optional :: dim
+
+    if (.not.associated(vin)) then 
+      psb_dsize2d = 0
+    else
+      if (present(dim)) then 
+        psb_dsize2d = size(vin,dim=dim)
+      else
+        psb_dsize2d = size(vin)
+      end if
+    end if
+  end function psb_dsize2d
+
+  
+  function psb_zsize1d(vin)
+    integer :: psb_zsize1d
+    complex(kind(1.d0)), pointer :: vin(:)
+    
+    if (.not.associated(vin)) then 
+      psb_zsize1d = 0
+    else
+      psb_zsize1d = size(vin)
+    end if
+  end function psb_zsize1d
+  function psb_zsize2d(vin,dim)
+    integer :: psb_zsize2d
+    complex(kind(1.d0)), pointer :: vin(:,:)
+    integer, optional :: dim
+
+    if (.not.associated(vin)) then 
+      psb_zsize2d = 0
+    else
+      if (present(dim)) then 
+        psb_zsize2d = size(vin,dim=dim)
+      else
+        psb_zsize2d = size(vin)
+      end if
+    end if
+  end function psb_zsize2d
+
+
   subroutine psb_icpy1d(vin,vout,info) 
     use psb_error_mod
 

src/modules/psb_tools_mod.f90

@@ -632,4 +632,34 @@ Module psb_tools_mod
      end subroutine psb_cddec
   end interface
 
+  interface psb_get_boundary
+    module procedure psb_get_boundary
+  end interface
+  
+  interface psb_get_overlap
+    subroutine psb_get_ovrlap(ovrel,desc,info)
+      use psb_descriptor_type
+      implicit none 
+      integer, pointer                :: ovrel(:)
+      type(psb_desc_type), intent(in) :: desc
+      integer, intent(out)            :: info
+    end subroutine psb_get_ovrlap
+  end interface
+  
+
+
+contains
+
+  subroutine psb_get_boundary(bndel,desc,info)
+    use psb_descriptor_type
+    use psi_mod
+    implicit none 
+    integer, pointer                :: bndel(:)
+    type(psb_desc_type), intent(in) :: desc
+    integer, intent(out)            :: info
+    
+    call psb_crea_bnd_elem(bndel,desc,info)
+
+  end subroutine psb_get_boundary
+
 end module psb_tools_mod

src/modules/psi_mod.f90

@@ -43,10 +43,11 @@ module psi_mod
   end interface
 
   interface
-     subroutine psi_crea_bnd_elem(desc_a,info)
+     subroutine psi_crea_bnd_elem(bndel,desc_a,info)
        use psb_descriptor_type
-       type(psb_desc_type)  :: desc_a
-       integer, intent(out) :: info
+       integer, pointer                :: bndel(:)
+       type(psb_desc_type), intent(in) :: desc_a
+       integer, intent(out)            :: info
      end subroutine psi_crea_bnd_elem
   end interface
 
@@ -317,7 +318,13 @@ contains
     if (debug) write(0,*) me,'Done crea_ovr_elem'
 
     ! finally bnd_elem
-    call psi_crea_bnd_elem(cdesc,info)
+    idx_out => null()
+    call psi_crea_bnd_elem(idx_out,cdesc,info)
+    if (associated(idx_out)) then 
+      cdesc%bnd_elem => idx_out
+    else
+      cdesc%bnd_elem => null()
+    endif
     if(info /= 0) then
       call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
       goto 9999

src/tools/Makefile

@@ -4,7 +4,7 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \
 	psb_dfree.o psb_dgelp.o psb_dins.o \
 	psb_cdall.o psb_cdalv.o psb_cdasb.o psb_cdcpy.o \
 	psb_cddec.o psb_cdfree.o psb_cdins.o psb_dcdovr.o \
-	psb_cdren.o psb_cdrep.o psb_cdtransfer.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_glob_to_loc.o psb_ialloc.o psb_iasb.o \

src/tools/psb_cdfree.f90

@@ -115,20 +115,21 @@ subroutine psb_cdfree(desc_a,info)
     goto 9999
   end if
 
-  if (.not.associated(desc_a%bnd_elem)) then
-    info=296
-    call psb_errpush(info,name)
-    goto 9999
-  end if
+!!$  if (.not.associated(desc_a%bnd_elem)) then
+!!$    info=296
+!!$    call psb_errpush(info,name)
+!!$    goto 9999
+!!$  end if
 
   !deallocate halo_index field
-  deallocate(desc_a%bnd_elem,stat=info)
-  if (info /= 0) then
-    info=2054
-    call psb_errpush(info,name)
-    goto 9999
+  if (associated(desc_a%bnd_elem)) then 
+    deallocate(desc_a%bnd_elem,stat=info)
+    if (info /= 0) then
+      info=2054
+      call psb_errpush(info,name)
+      goto 9999
+    end if
   end if
-
   if (.not.associated(desc_a%ovrlap_index)) then
     info=295
     call psb_errpush(info,name)

src/tools/psb_get_overlap.f90

@@ -0,0 +1,64 @@
+subroutine psb_get_ovrlap(ovrel,desc,info)
+  use psb_descriptor_type
+  use psb_realloc_mod
+  use psb_error_mod
+  implicit none 
+  integer, pointer                :: ovrel(:)
+  type(psb_desc_type), intent(in) :: desc
+  integer, intent(out)            :: info
+
+  integer  :: i,j, err_act
+  character(len=20)    :: name
+
+  info = 0
+  name='psi_get_overlap'
+  call psb_erractionsave(err_act)
+
+  i=0
+  j=1
+  do while(desc%ovrlap_elem(j) /= -1) 
+    i  = i +1 
+    j  = j + 2
+  enddo
+
+  if (i > 0) then 
+
+    allocate(ovrel(i),stat=info)
+    if (info /= 0 ) then 
+      info = 4000
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+    
+    i=0
+    j=1
+    do while(desc%ovrlap_elem(j) /= -1) 
+      i  = i +1 
+      ovrel(i) = desc%ovrlap_elem(j) 
+      j  = j + 2
+    enddo
+
+  else
+
+    if (associated(ovrel)) then 
+      deallocate(ovrel,stat=info)
+      if (info /= 0) then 
+        call psb_errpush(4010,name,a_err='Deallocate')
+        goto 9999      
+      end if
+    end if
+
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act.eq.act_abort) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine psb_get_ovrlap