diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index 88b588fb..47f57a95 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -98,247 +98,249 @@ ! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine). ! ! -subroutine psi_desc_index(desc,index_in,dep_list,& - & length_dl,nsnd,nrcv,desc_index,isglob_in,info) - use psb_desc_mod - use psb_realloc_mod - use psb_error_mod - use psb_const_mod +submodule (psi_i_mod) psi_desc_index_impl_mod +contains + subroutine psi_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,isglob_in,info) + use psb_desc_mod + use psb_realloc_mod + use psb_error_mod + use psb_const_mod #ifdef MPI_MOD - use mpi + use mpi #endif - use psb_penv_mod - use psi_mod, psb_protect_name => psi_desc_index - implicit none + use psb_penv_mod + implicit none #ifdef MPI_H - include 'mpif.h' + include 'mpif.h' #endif - ! ...array parameters..... - type(psb_desc_type) :: desc - integer(psb_ipk_) :: index_in(:),dep_list(:) - integer(psb_ipk_),allocatable :: desc_index(:) - integer(psb_ipk_) :: length_dl,nsnd,nrcv,info - logical :: isglob_in - ! ....local scalars... - integer(psb_ipk_) :: j,me,np,i,proc - ! ...parameters... - integer(psb_ipk_) :: ictxt - integer(psb_ipk_), parameter :: no_comm=-1 - ! ...local arrays.. - integer(psb_ipk_),allocatable :: sndbuf(:), rcvbuf(:) + ! ...array parameters..... + type(psb_desc_type) :: desc + integer(psb_ipk_) :: index_in(:),dep_list(:) + integer(psb_ipk_),allocatable :: desc_index(:) + integer(psb_ipk_) :: length_dl,nsnd,nrcv,info + logical :: isglob_in + ! ....local scalars... + integer(psb_ipk_) :: j,me,np,i,proc + ! ...parameters... + integer(psb_ipk_) :: ictxt + integer(psb_ipk_), parameter :: no_comm=-1 + ! ...local arrays.. + integer(psb_ipk_),allocatable :: sndbuf(:), rcvbuf(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:),& - & bsdindx(:),sdsz(:) + integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:),& + & bsdindx(:),sdsz(:) - integer(psb_ipk_) :: ihinsz,ntot,k,err_act,nidx,& - & idxr, idxs, iszs, iszr, nesd, nerv - integer(psb_mpik_) :: icomm, minfo + integer(psb_ipk_) :: ihinsz,ntot,k,err_act,nidx,& + & idxr, idxs, iszs, iszr, nesd, nerv + integer(psb_mpik_) :: icomm, minfo - logical,parameter :: usempi=.true. - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + logical,parameter :: usempi=.true. + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name - info = psb_success_ - name='psi_desc_index' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() + info = psb_success_ + name='psi_desc_index' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() - ictxt = desc%get_context() - icomm = desc%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + ictxt = desc%get_context() + icomm = desc%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) me,' ',trim(name),': start' - call psb_barrier(ictxt) - endif + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': start' + call psb_barrier(ictxt) + endif - ! - ! first, find out the sizes to be exchanged. - ! note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things - ! to be received/sent (in the final psblas descriptor). - ! be careful of the inversion - ! - allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + ! + ! first, find out the sizes to be exchanged. + ! note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things + ! to be received/sent (in the final psblas descriptor). + ! be careful of the inversion + ! + allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) + if(info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if - sdsz(:) = 0 - rvsz(:) = 0 - bsdindx(:) = 0 - brvindx(:) = 0 - i = 1 - do - if (index_in(i) == -1) exit - proc = index_in(i) - i = i + 1 - nerv = index_in(i) - sdsz(proc+1) = sdsz(proc+1) + nerv - i = i + nerv + 1 - end do - ihinsz=i - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo) - if (minfo /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall') - goto 9999 - end if + sdsz(:) = 0 + rvsz(:) = 0 + bsdindx(:) = 0 + brvindx(:) = 0 + i = 1 + do + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + sdsz(proc+1) = sdsz(proc+1) + nerv + i = i + nerv + 1 + end do + ihinsz=i + call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo) + if (minfo /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall') + goto 9999 + end if - i = 1 - idxs = 0 - idxr = 0 - do i=1, length_dl - proc = dep_list(i) - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) - end do - iszs = sum(sdsz) - iszr = sum(rvsz) - nsnd = iszr - nrcv = iszs + i = 1 + idxs = 0 + idxr = 0 + do i=1, length_dl + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + end do + iszs = sum(sdsz) + iszr = sum(rvsz) + nsnd = iszr + nrcv = iszs - if ((iszs /= idxs).or.(iszr /= idxr)) then - write(psb_err_unit,*) me, trim(name),': Warning: strange results?', & - & iszs,idxs,iszr,idxr - end if - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs - call psb_barrier(ictxt) - endif + if ((iszs /= idxs).or.(iszr /= idxr)) then + write(psb_err_unit,*) me, trim(name),': Warning: strange results?', & + & iszs,idxs,iszr,idxr + end if + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs + call psb_barrier(ictxt) + endif - ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 + ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 - if (ntot > psb_size(desc_index)) then - call psb_realloc(ntot,desc_index,info) - endif + if (ntot > psb_size(desc_index)) then + call psb_realloc(ntot,desc_index,info) + endif !!$ call psb_ensure_size(ntot,desc_index,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') - goto 9999 - end if - - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs - call psb_barrier(ictxt) - endif - allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') + goto 9999 + end if - ! - ! Second build the lists of requests - ! - i = 1 - do - if (i > ihinsz) then -!!$ write(psb_err_unit,*) me,' did not find index_in end??? ',i,ihinsz - exit + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs + call psb_barrier(ictxt) + endif + allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) + if(info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 end if - if (index_in(i) == -1) exit - proc = index_in(i) - i = i + 1 - nerv = index_in(i) - ! - ! note that here bsdinx is zero-based, hence the following loop - ! - if (isglob_in) then - do j=1, nerv - sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) - end do - else - - call desc%indxmap%l2g(index_in(i+1:i+nerv),& - & sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& - & info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g') - goto 9999 + ! + ! Second build the lists of requests + ! + i = 1 + do + if (i > ihinsz) then +!!$ write(psb_err_unit,*) me,' did not find index_in end??? ',i,ihinsz + exit end if + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + ! + ! note that here bsdinx is zero-based, hence the following loop + ! + if (isglob_in) then + do j=1, nerv + sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) + end do + else + + call desc%indxmap%l2g(index_in(i+1:i+nerv),& + & sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& + & info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g') + goto 9999 + end if + + endif + bsdindx(proc+1) = bsdindx(proc+1) + nerv + i = i + nerv + 1 + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': prepared send buffer ' + call psb_barrier(ictxt) endif - bsdindx(proc+1) = bsdindx(proc+1) + nerv - i = i + nerv + 1 - end do + ! + ! now have to regenerate bsdindx + ! + idxs = 0 + idxr = 0 + do i=1, length_dl + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) me,' ',trim(name),': prepared send buffer ' - call psb_barrier(ictxt) - endif - ! - ! now have to regenerate bsdindx - ! - idxs = 0 - idxr = 0 - do i=1, length_dl - proc = dep_list(i) - bsdindx(proc+1) = idxs - idxs = idxs + sdsz(proc+1) - brvindx(proc+1) = idxr - idxr = idxr + rvsz(proc+1) - end do + call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_integer,& + & rcvbuf,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + if (minfo /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') + goto 9999 + end if - call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_integer,& - & rcvbuf,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) - if (minfo /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') - goto 9999 - end if + ! + ! at this point we can finally build the output desc_index. beware + ! of snd/rcv inversion. + ! + i = 1 + do k = 1, length_dl + proc = dep_list(k) + desc_index(i) = proc + i = i + 1 + nerv = sdsz(proc+1) + desc_index(i) = nerv + call desc%indxmap%g2l(sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& + & desc_index(i+1:i+nerv),info) - ! - ! at this point we can finally build the output desc_index. beware - ! of snd/rcv inversion. - ! - i = 1 - do k = 1, length_dl - proc = dep_list(k) - desc_index(i) = proc - i = i + 1 - nerv = sdsz(proc+1) - desc_index(i) = nerv - call desc%indxmap%g2l(sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& - & desc_index(i+1:i+nerv),info) - - i = i + nerv + 1 - nesd = rvsz(proc+1) - desc_index(i) = nesd - call desc%indxmap%g2l(rcvbuf(brvindx(proc+1)+1:brvindx(proc+1)+nesd),& - & desc_index(i+1:i+nesd),info) - i = i + nesd + 1 - end do - desc_index(i) = - 1 + i = i + nerv + 1 + nesd = rvsz(proc+1) + desc_index(i) = nesd + call desc%indxmap%g2l(rcvbuf(brvindx(proc+1)+1:brvindx(proc+1)+nesd),& + & desc_index(i+1:i+nesd),info) + i = i + nesd + 1 + end do + desc_index(i) = - 1 - deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) me,' ',trim(name),': done' - call psb_barrier(ictxt) - endif + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': done' + call psb_barrier(ictxt) + endif - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_desc_index + return + + end subroutine psi_desc_index +end submodule psi_desc_index_impl_mod diff --git a/base/internals/psi_dl_check.f90 b/base/internals/psi_dl_check.f90 index 0667524c..6ebb287d 100644 --- a/base/internals/psi_dl_check.f90 +++ b/base/internals/psi_dl_check.f90 @@ -44,52 +44,54 @@ ! length_dl(:) - integer Items in dependency lists; updated on ! exit ! -subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) +submodule (psi_i_mod) psi_dl_check_impl_mod +contains + subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) - use psi_mod, psb_protect_name => psi_dl_check - use psb_const_mod - use psb_desc_mod - implicit none + use psb_const_mod + use psb_desc_mod + implicit none - integer(psb_ipk_) :: np,dl_lda,length_dl(0:np) - integer(psb_ipk_) :: dep_list(dl_lda,0:np) - ! locals - integer(psb_ipk_) :: proc, proc2, i, j + integer(psb_ipk_) :: np,dl_lda,length_dl(0:np) + integer(psb_ipk_) :: dep_list(dl_lda,0:np) + ! locals + integer(psb_ipk_) :: proc, proc2, i, j - ! ...if j is in dep_list of process i - ! and i is not in dep_list of process j - ! fix it. + ! ...if j is in dep_list of process i + ! and i is not in dep_list of process j + ! fix it. - do proc=0,np-1 - i=1 - outer: do - if (i >length_dl(proc)) exit outer - proc2=dep_list(i,proc) - if ((proc2 /= -1).and.(proc2 /= proc)) then - ! ...search proc in proc2's dep_list.... - j=1 - p2loop:do - if (j > length_dl(proc2)) exit p2loop - if (dep_list(j,proc2) == proc) exit p2loop - j=j+1 - enddo p2loop + do proc=0,np-1 + i=1 + outer: do + if (i >length_dl(proc)) exit outer + proc2=dep_list(i,proc) + if ((proc2 /= -1).and.(proc2 /= proc)) then + ! ...search proc in proc2's dep_list.... + j=1 + p2loop:do + if (j > length_dl(proc2)) exit p2loop + if (dep_list(j,proc2) == proc) exit p2loop + j=j+1 + enddo p2loop - if (j > length_dl(proc2)) then - ! ...add proc to proc2 s dep_list.....',proc,proc2 - length_dl(proc2) = length_dl(proc2)+1 - if (length_dl(proc2) > size(dep_list,1)) then - write(psb_err_unit,*)'error in crea_halo', proc2,proc,& - & length_dl(proc2),'>',size(dep_list,1) + if (j > length_dl(proc2)) then + ! ...add proc to proc2 s dep_list.....',proc,proc2 + length_dl(proc2) = length_dl(proc2)+1 + if (length_dl(proc2) > size(dep_list,1)) then + write(psb_err_unit,*)'error in crea_halo', proc2,proc,& + & length_dl(proc2),'>',size(dep_list,1) + endif + dep_list(length_dl(proc2),proc2) = proc + else if (dep_list(j,proc2) /= proc) then + write(psb_err_unit,*) 'PSI_DL_CHECK This should not happen!!! ',& + & j,proc2,dep_list(j,proc2),proc endif - dep_list(length_dl(proc2),proc2) = proc - else if (dep_list(j,proc2) /= proc) then - write(psb_err_unit,*) 'PSI_DL_CHECK This should not happen!!! ',& - & j,proc2,dep_list(j,proc2),proc endif - endif - i=i+1 - enddo outer - enddo + i=i+1 + enddo outer + enddo -end subroutine psi_dl_check + end subroutine psi_dl_check +end submodule psi_dl_check_impl_mod diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index c189d01b..a52b0d38 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -29,207 +29,216 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& - & length_dl,np,dl_lda,mode,info) +submodule (psi_i_mod) psi_extract_dep_list_impl_mod +contains + subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& + & length_dl,np,dl_lda,mode,info) - ! internal routine - ! == = ============= - ! - ! _____called by psi_crea_halo and psi_crea_ovrlap ______ - ! - ! purpose - ! == = ==== - ! process root (pid=0) extracts for each process "k" the ordered list of process - ! to which "k" must communicate. this list with its order is extracted from - ! desc_str list - ! - ! - ! input - ! == = ==== - ! desc_data :integer array - ! explanation: - ! name explanation - ! ------------------ ------------------------------------------------------- - ! desc_data array of integer that contains some local and global - ! information of matrix. - ! - ! - ! now we explain each of the above vectors. - ! - ! let a be a generic sparse matrix. we denote with matdata_a the matrix_data - ! array for matrix a. - ! data stored in matrix_data array are: - ! - ! notation stored in explanation - ! --------------- ---------------------- ------------------------------------- - ! dec_type matdata_a[psb_dec_type_] decomposition type - ! m matdata_a[m_] total number of equations - ! n matdata_a[n_] total number of variables - ! n_row matdata_a[psb_n_row_] number of local equations - ! n_col matdata_a[psb_n_col_] number of local variables - ! psb_ctxt_a matdata_a[ctxt_] the blacs context handle, indicating - ! the global context of the operation - ! on the matrix. - ! the context itself is global. - ! desc_str integer array - ! explanation: - ! let desc_str_p be the array desc_str for local process. - !! this is composed of variable dimension blocks for each process to - ! communicate to. - ! each block contain indexes of local halo elements to exchange with other - ! process. - ! let p be the pointer to the first element of a block in desc_str_p. - ! this block is stored in desc_str_p as : - ! - ! notation stored in explanation - ! --------------- --------------------------- ----------------------------------- - ! process_id desc_str_p[p+psb_proc_id_] identifier of process which exchange - ! data with. - ! n_elements_recv desc_str_p[p+n_elem_recv_] number of elements to receive. - ! elements_recv desc_str_p[p+elem_recv_+i] indexes of local elements to - ! receive. these are stored in the - ! array from location p+elem_recv_ to - ! location p+elem_recv_+ - ! desc_str_p[p+n_elem_recv_]-1. - ! if desc_data(psb_dec_type_) == 0 - ! then also will be: - ! n_elements_send desc_str_p[p+n_elem_send_] number of elements to send. - ! elements_send desc_str_p[p+elem_send_+i] indexes of local elements to - ! send. these are stored in the - ! array from location p+elem_send_ to - ! location p+elem_send_+ - ! desc_str_p[p+n_elem_send_]-1. - ! list is ended by -1 value - ! - ! np integer (global input) - ! number of grid process. - ! - ! mode integer (global input) - ! if mode =0 then will be inserted also duplicate element in - ! a same dependence list - ! if mode =1 then not will be inserted duplicate element in - ! a same dependence list - ! output - ! == = == - ! only for root (pid=0) process: - ! dep_list integer array(dl_lda,0:np) - ! dependence list dep_list(*,i) is the list of process identifiers to which process i - ! must communicate with. this list with its order is extracted from - ! desc_str list. - ! length_dl integer array(0:np) - ! length_dl(i) is the length of dep_list(*,i) list - use psi_mod, psb_protect_name => psi_extract_dep_list + ! internal routine + ! == = ============= + ! + ! _____called by psi_crea_halo and psi_crea_ovrlap ______ + ! + ! purpose + ! == = ==== + ! process root (pid=0) extracts for each process "k" the ordered list of process + ! to which "k" must communicate. this list with its order is extracted from + ! desc_str list + ! + ! + ! input + ! == = ==== + ! desc_data :integer array + ! explanation: + ! name explanation + ! ------------------ ------------------------------------------------------- + ! desc_data array of integer that contains some local and global + ! information of matrix. + ! + ! + ! now we explain each of the above vectors. + ! + ! let a be a generic sparse matrix. we denote with matdata_a the matrix_data + ! array for matrix a. + ! data stored in matrix_data array are: + ! + ! notation stored in explanation + ! --------------- ---------------------- ------------------------------------- + ! dec_type matdata_a[psb_dec_type_] decomposition type + ! m matdata_a[m_] total number of equations + ! n matdata_a[n_] total number of variables + ! n_row matdata_a[psb_n_row_] number of local equations + ! n_col matdata_a[psb_n_col_] number of local variables + ! psb_ctxt_a matdata_a[ctxt_] the blacs context handle, indicating + ! the global context of the operation + ! on the matrix. + ! the context itself is global. + ! desc_str integer array + ! explanation: + ! let desc_str_p be the array desc_str for local process. + !! this is composed of variable dimension blocks for each process to + ! communicate to. + ! each block contain indexes of local halo elements to exchange with other + ! process. + ! let p be the pointer to the first element of a block in desc_str_p. + ! this block is stored in desc_str_p as : + ! + ! notation stored in explanation + ! --------------- --------------------------- ----------------------------------- + ! process_id desc_str_p[p+psb_proc_id_] identifier of process which exchange + ! data with. + ! n_elements_recv desc_str_p[p+n_elem_recv_] number of elements to receive. + ! elements_recv desc_str_p[p+elem_recv_+i] indexes of local elements to + ! receive. these are stored in the + ! array from location p+elem_recv_ to + ! location p+elem_recv_+ + ! desc_str_p[p+n_elem_recv_]-1. + ! if desc_data(psb_dec_type_) == 0 + ! then also will be: + ! n_elements_send desc_str_p[p+n_elem_send_] number of elements to send. + ! elements_send desc_str_p[p+elem_send_+i] indexes of local elements to + ! send. these are stored in the + ! array from location p+elem_send_ to + ! location p+elem_send_+ + ! desc_str_p[p+n_elem_send_]-1. + ! list is ended by -1 value + ! + ! np integer (global input) + ! number of grid process. + ! + ! mode integer (global input) + ! if mode =0 then will be inserted also duplicate element in + ! a same dependence list + ! if mode =1 then not will be inserted duplicate element in + ! a same dependence list + ! output + ! == = == + ! only for root (pid=0) process: + ! dep_list integer array(dl_lda,0:np) + ! dependence list dep_list(*,i) is the list of process identifiers to which process i + ! must communicate with. this list with its order is extracted from + ! desc_str list. + ! length_dl integer array(0:np) + ! length_dl(i) is the length of dep_list(*,i) list #ifdef MPI_MOD - use mpi + use mpi #endif - use psb_penv_mod - use psb_const_mod - use psb_error_mod - use psb_desc_mod - implicit none + use psb_penv_mod + use psb_const_mod + use psb_error_mod + use psb_desc_mod + implicit none #ifdef MPI_H - include 'mpif.h' + include 'mpif.h' #endif - ! ....scalar parameters... - logical :: is_bld, is_upd - integer(psb_ipk_) :: ictxt - integer(psb_ipk_) :: np,dl_lda,mode, info + ! ....scalar parameters... + logical :: is_bld, is_upd + integer(psb_ipk_) :: ictxt + integer(psb_ipk_) :: np,dl_lda,mode, info - ! ....array parameters.... - integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) - integer(psb_ipk_), allocatable :: itmp(:) - ! .....local arrays.... - integer(psb_ipk_) :: int_err(5) + ! ....array parameters.... + integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) + integer(psb_ipk_), allocatable :: itmp(:) + ! .....local arrays.... + integer(psb_ipk_) :: int_err(5) - ! .....local scalars... - integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act - integer(psb_ipk_) :: err - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: iictxt, icomm, me, npr, dl_mpi, minfo - character name*20 - name='psi_extrct_dl' + ! .....local scalars... + integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act + integer(psb_ipk_) :: err + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_mpik_) :: iictxt, icomm, me, npr, dl_mpi, minfo + character name*20 + name='psi_extrct_dl' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - iictxt = ictxt - info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + iictxt = ictxt + info = psb_success_ - call psb_info(iictxt,me,npr) - do i=0,np - length_dl(i) = 0 - enddo - i=1 - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),': start ',info + call psb_info(iictxt,me,npr) + do i=0,np + length_dl(i) = 0 + enddo + i=1 + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) me,' ',trim(name),': start ',info - pointer_dep_list=1 - if (is_bld) then - do while (desc_str(i) /= -1) - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),' : looping ',i,& - & desc_str(i),desc_str(i+1),desc_str(i+2) + pointer_dep_list=1 + if (is_bld) then + do while (desc_str(i) /= -1) + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) me,' ',trim(name),' : looping ',i,& + & desc_str(i),desc_str(i+1),desc_str(i+2) - ! ...with different decomposition type we have different - ! structure of indices lists............................ - if ((desc_str(i+1) /= 0).or.(desc_str(i+2) /= 0)) then - ! ..if number of element to be exchanged !=0 - proc=desc_str(i) - if ((proc < 0).or.(proc >= npr)) then - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),': error ',i,desc_str(i) - info = 9999 - int_err(1) = i - int_err(2) = desc_str(i) - goto 998 - endif - ! if((me == 1).and.(proc == 3))write(psb_err_unit,*)'found 3' - if (mode == 1) then - ! ...search if already exist proc - ! in dep_list(*,me)... - j=1 - do while ((j < pointer_dep_list).and.& - & (dep_list(j,me) /= proc)) - j=j+1 - enddo + ! ...with different decomposition type we have different + ! structure of indices lists............................ + if ((desc_str(i+1) /= 0).or.(desc_str(i+2) /= 0)) then + ! ..if number of element to be exchanged !=0 + proc=desc_str(i) + if ((proc < 0).or.(proc >= npr)) then + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) me,' ',trim(name),': error ',i,desc_str(i) + info = 9999 + int_err(1) = i + int_err(2) = desc_str(i) + goto 998 + endif + ! if((me == 1).and.(proc == 3))write(psb_err_unit,*)'found 3' + if (mode == 1) then + ! ...search if already exist proc + ! in dep_list(*,me)... + j=1 + do while ((j < pointer_dep_list).and.& + & (dep_list(j,me) /= proc)) + j=j+1 + enddo - if (j == pointer_dep_list) then - ! ...if not found..... + if (j == pointer_dep_list) then + ! ...if not found..... + dep_list(pointer_dep_list,me)=proc + pointer_dep_list=pointer_dep_list+1 + endif + else if (mode == 0) then + if (pointer_dep_list > dl_lda) then + info = psb_err_alloc_dealloc_ + goto 998 + endif dep_list(pointer_dep_list,me)=proc pointer_dep_list=pointer_dep_list+1 endif - else if (mode == 0) then - if (pointer_dep_list > dl_lda) then - info = psb_err_alloc_dealloc_ - goto 998 - endif - dep_list(pointer_dep_list,me)=proc - pointer_dep_list=pointer_dep_list+1 endif - endif - i=i+desc_str(i+1)+2 - enddo - else if (is_upd) then - do while (desc_str(i) /= -1) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': looping ',i,desc_str(i) + i=i+desc_str(i+1)+2 + enddo + else if (is_upd) then + do while (desc_str(i) /= -1) + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),': looping ',i,desc_str(i) - ! ...with different decomposition type we have different - ! structure of indices lists............................ - if (desc_str(i+1) /= 0) then + ! ...with different decomposition type we have different + ! structure of indices lists............................ + if (desc_str(i+1) /= 0) then - proc=desc_str(i) - ! ..if number of element to be exchanged !=0 + proc=desc_str(i) + ! ..if number of element to be exchanged !=0 - if (mode == 1) then - ! ...search if already exist proc.... - j=1 - do while ((j < pointer_dep_list).and.& - & (dep_list(j,me) /= proc)) - j=j+1 - enddo - if (j == pointer_dep_list) then - ! ...if not found..... + if (mode == 1) then + ! ...search if already exist proc.... + j=1 + do while ((j < pointer_dep_list).and.& + & (dep_list(j,me) /= proc)) + j=j+1 + enddo + if (j == pointer_dep_list) then + ! ...if not found..... + if (pointer_dep_list > dl_lda) then + info = psb_err_alloc_dealloc_ + goto 998 + endif + dep_list(pointer_dep_list,me)=proc + pointer_dep_list=pointer_dep_list+1 + endif + else if (mode == 0) then if (pointer_dep_list > dl_lda) then info = psb_err_alloc_dealloc_ goto 998 @@ -237,59 +246,52 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& dep_list(pointer_dep_list,me)=proc pointer_dep_list=pointer_dep_list+1 endif - else if (mode == 0) then - if (pointer_dep_list > dl_lda) then - info = psb_err_alloc_dealloc_ - goto 998 - endif - dep_list(pointer_dep_list,me)=proc - pointer_dep_list=pointer_dep_list+1 endif - endif - i=i+desc_str(i+1)+2 - enddo - else - info = 2020 - goto 9999 - endif + i=i+desc_str(i+1)+2 + enddo + else + info = 2020 + goto 9999 + endif - length_dl(me)=pointer_dep_list-1 + length_dl(me)=pointer_dep_list-1 - ! ... check for errors... + ! ... check for errors... 998 continue - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) me,' ',trim(name),': info ',info - err = info + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) me,' ',trim(name),': info ',info + err = info - if (err /= 0) goto 9999 + if (err /= 0) goto 9999 - call psb_sum(iictxt,length_dl(0:np)) - call psb_get_mpicomm(iictxt,icomm ) - allocate(itmp(dl_lda),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - goto 9999 - endif - itmp(1:dl_lda) = dep_list(1:dl_lda,me) - dl_mpi = dl_lda - call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,& - & dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo) - info = minfo - if (info == 0) deallocate(itmp,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - goto 9999 - endif + call psb_sum(iictxt,length_dl(0:np)) + call psb_get_mpicomm(iictxt,icomm ) + allocate(itmp(dl_lda),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + goto 9999 + endif + itmp(1:dl_lda) = dep_list(1:dl_lda,me) + dl_mpi = dl_lda + call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,& + & dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo) + info = minfo + if (info == 0) deallocate(itmp,stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + goto 9999 + endif - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 continue - call psb_errpush(info,name,i_err=int_err) - call psb_error_handler(err_act) + call psb_errpush(info,name,i_err=int_err) + call psb_error_handler(err_act) - return + return -end subroutine psi_extract_dep_list + end subroutine psi_extract_dep_list +end submodule psi_extract_dep_list_impl_mod diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index 4f071b19..9fd47dec 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -29,65 +29,65 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_sort_dl(dep_list,l_dep_list,np,info) - ! - ! interface between former sort_dep_list subroutine - ! and new srtlist - ! - use psi_mod, psb_protect_name => psi_sort_dl - use psb_const_mod - use psb_error_mod - implicit none +submodule (psi_i_mod) psi_sort_dlimpl_mod +contains + subroutine psi_sort_dl(dep_list,l_dep_list,np,info) + ! + ! interface between former sort_dep_list subroutine + ! and new srtlist + ! + use psb_const_mod + use psb_error_mod + implicit none - integer(psb_ipk_) :: np,dep_list(:,:), l_dep_list(:) - integer(psb_ipk_) :: idg, iupd, idgp, iedges, iidx, iich,ndgmx, isz, err_act - integer(psb_ipk_) :: i, info - integer(psb_ipk_), allocatable :: work(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - name='psi_sort_dl' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - info = psb_success_ - ndgmx = 0 - do i=1,np - ndgmx = ndgmx + l_dep_list(i) - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) name,': ',i,l_dep_list(i) - enddo - idg = 1 - iupd = idg+np - idgp = iupd+np - iedges = idgp + ndgmx - iidx = iedges + 2*ndgmx - iich = iidx + ndgmx - isz = iich + ndgmx - if (debug_level >= psb_debug_inner_)& - & write(debug_unit,*) name,': ndgmx ',ndgmx,isz + integer(psb_ipk_) :: np,dep_list(:,:), l_dep_list(:) + integer(psb_ipk_) :: idg, iupd, idgp, iedges, iidx, iich,ndgmx, isz, err_act + integer(psb_ipk_) :: i, info + integer(psb_ipk_), allocatable :: work(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name - allocate(work(isz)) - ! call srtlist(dep_list, dl_lda, l_dep_list, np, info) - call srtlist(dep_list,size(dep_list,1,kind=psb_ipk_),l_dep_list,np,work(idg),& - & work(idgp),work(iupd),work(iedges),work(iidx),work(iich),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='srtlist') - goto 9999 - endif - - deallocate(work) - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) + name='psi_sort_dl' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + info = psb_success_ + ndgmx = 0 + do i=1,np + ndgmx = ndgmx + l_dep_list(i) + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) name,': ',i,l_dep_list(i) + enddo + idg = 1 + iupd = idg+np + idgp = iupd+np + iedges = idgp + ndgmx + iidx = iedges + 2*ndgmx + iich = iidx + ndgmx + isz = iich + ndgmx + if (debug_level >= psb_debug_inner_)& + & write(debug_unit,*) name,': ndgmx ',ndgmx,isz - return + allocate(work(isz)) + ! call srtlist(dep_list, dl_lda, l_dep_list, np, info) + call srtlist(dep_list,size(dep_list,1,kind=psb_ipk_),l_dep_list,np,work(idg),& + & work(idgp),work(iupd),work(iedges),work(iidx),work(iich),info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='srtlist') + goto 9999 + endif -end subroutine psi_sort_dl + deallocate(work) + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine psi_sort_dl +end submodule psi_sort_dlimpl_mod