fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/comm/psb_cscatter.F90
 base/comm/psb_dscatter.F90
 base/comm/psb_sscatter.F90
 base/comm/psb_zscatter.F90

Fix calling of MPI routines with unallocated arrays: under debug
conditions it can generate false errors.
psblas-3.3.1-1
Salvatore Filippone 12 years ago
parent 107fe97402
commit ccc7b59c80
4 changed files with 202 additions and 55 deletions
Show Stats Download Patch File Download Diff File

64
base/comm/psb_cscatter.F90
Unescape Escape View File

@ -180,13 +180,20 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -213,7 +220,14 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
end do
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
@ -376,7 +390,14 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow))
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
@ -397,7 +418,22 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
endif
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)))
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -420,7 +456,13 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_c_spk_,locx,nrow,&
& psb_mpi_c_spk_,rootrank,icomm,info)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)

65
base/comm/psb_dscatter.F90
Unescape Escape View File

@ -180,13 +180,20 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -213,7 +220,14 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
end do
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
@ -377,9 +391,10 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -404,16 +419,23 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
@ -433,15 +455,14 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_r_dpk_,locx,nrow,&
& psb_mpi_r_dpk_,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, scatterv,stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)

64
base/comm/psb_sscatter.F90
Unescape Escape View File

@ -180,13 +180,20 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -213,7 +220,14 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
end do
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
@ -376,7 +390,14 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow))
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
@ -397,7 +418,22 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
endif
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)))
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -420,7 +456,13 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_r_spk_,locx,nrow,&
& psb_mpi_r_spk_,rootrank,icomm,info)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)

64
base/comm/psb_zscatter.F90
Unescape Escape View File

@ -180,13 +180,20 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -213,7 +220,14 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
end do
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
@ -376,7 +390,14 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow))
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
@ -397,7 +418,22 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
endif
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)))
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gatherv(ltg,nrow,&
@ -420,7 +456,13 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_c_dpk_,locx,nrow,&
& psb_mpi_c_dpk_,rootrank,icomm,info)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call psb_erractionrestore(err_act)

Write Preview
Loading…
Cancel
Save