fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
Reworked error constant names and typographical fixes.
This commit is contained in:
Salvatore Filippone
2010-04-22 15:35:14 +00:00
parent 22876a972f
commit 6b278318bd
346 changed files with 9843 additions and 9777 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/comm/psb_cgather.f90
+14 -14
View File
@@ -65,7 +65,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
name='psb_cgatherm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -73,7 +73,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,7 +81,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -117,17 +117,17 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -238,7 +238,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -246,7 +246,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -254,7 +254,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -280,17 +280,17 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/comm/psb_chalo.f90
+24 -24
View File
@@ -77,7 +77,7 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
name='psb_chalom'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -85,7 +85,7 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -132,14 +132,14 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -163,8 +163,8 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -174,8 +174,8 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -191,14 +191,14 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psi_swaptran(imode,k,cone,xp,&
&desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_zswapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@@ -298,7 +298,7 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
name='psb_chalov'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -306,7 +306,7 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -337,14 +337,14 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -366,8 +366,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -376,8 +376,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -392,14 +392,14 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
call psi_swaptran(imode,cone,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_dSwap...'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
base/comm/psb_covrl.f90
+20 -20
View File
@@ -86,7 +86,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
name='psb_covrlm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -94,7 +94,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -138,14 +138,14 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -166,8 +166,8 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -180,9 +180,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
call psi_swapdata(mode_,k,cone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
@@ -285,7 +285,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
name='psb_covrlv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -293,7 +293,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -323,14 +323,14 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -351,8 +351,8 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -365,9 +365,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
call psi_swapdata(mode_,cone,x(:),&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
base/comm/psb_cscatter.F90
+22 -22
View File
@@ -72,7 +72,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
name='psb_scatterm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -80,7 +80,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -88,7 +88,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -129,23 +129,23 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow=psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
@@ -158,8 +158,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -175,8 +175,8 @@ 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 /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -208,7 +208,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
end do
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
@@ -301,7 +301,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
name='psb_scatterv'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
debug_unit = psb_get_debug_unit()
@@ -311,7 +311,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -319,7 +319,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -345,24 +345,24 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
idx=desc_a%idxmap%loc_to_glob(i)
@@ -411,7 +411,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
& mpi_complex,locx,nrow,&
& mpi_complex,rootrank,icomm,info)
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
base/comm/psb_dgather.f90
+13 -13
View File
@@ -65,7 +65,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
name='psb_dgatherm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -73,7 +73,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,7 +81,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -89,7 +89,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
else
root = -1
end if
if (root==-1) then
if (root == -1) then
iiroot = psb_root_
else
iiroot = root
@@ -117,15 +117,15 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -235,7 +235,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
name='psb_dgatherv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -243,7 +243,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -251,7 +251,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -278,15 +278,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/comm/psb_dhalo.f90
+24 -24
View File
@@ -77,7 +77,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
name='psb_dhalom'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -85,7 +85,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -134,14 +134,14 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -165,8 +165,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -176,8 +176,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
aliw=.true.
!!$ write(0,*) 'halom ',liwork
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -193,14 +193,14 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psi_swaptran(imode,k,done,xp,&
&desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_dSwapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@@ -298,7 +298,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
name='psb_dhalov'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -306,7 +306,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -336,14 +336,14 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -365,8 +365,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -375,8 +375,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -391,14 +391,14 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
call psi_swaptran(imode,done,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_swapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
base/comm/psb_dovrl.f90
+20 -20
View File
@@ -85,7 +85,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
name='psb_dovrlm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -93,7 +93,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -137,14 +137,14 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -166,8 +166,8 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -180,9 +180,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
call psi_swapdata(mode_,k,done,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
@@ -287,7 +287,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
name='psb_dovrlv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -295,7 +295,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -325,14 +325,14 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -353,8 +353,8 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -367,9 +367,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
call psi_swapdata(mode_,done,x(:),&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
base/comm/psb_dscatter.F90
+22 -22
View File
@@ -72,7 +72,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
name='psb_scatterm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -80,7 +80,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -88,7 +88,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -129,23 +129,23 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow=psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
@@ -158,8 +158,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -175,8 +175,8 @@ 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 /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -208,7 +208,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
end do
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
@@ -302,7 +302,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
name='psb_scatterv'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
debug_unit = psb_get_debug_unit()
@@ -312,7 +312,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -320,7 +320,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -346,24 +346,24 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
idx=desc_a%idxmap%loc_to_glob(i)
@@ -412,7 +412,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
& mpi_double_precision,locx,nrow,&
& mpi_double_precision,rootrank,icomm,info)
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
base/comm/psb_dspgather.F90
+9 -9
View File
@@ -27,7 +27,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
name='psb_gather'
if (psb_get_errstatus().ne.0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
@@ -50,8 +50,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
ncg = psb_cd_get_global_rows(desc_a)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
info=4025
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
goto 9999
@@ -61,8 +61,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
nzbr(me+1) = loc_coo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr)
if (info == 0) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= 0) goto 9999
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@@ -70,15 +70,15 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call mpi_allgatherv(loc_coo%val,ndx,mpi_double_precision,&
& glob_coo%val,nzbr,idisp,&
& mpi_double_precision,icomm,info)
if (info == 0) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,&
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,&
& glob_coo%ia,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,&
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,&
& glob_coo%ja,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
base/comm/psb_igather.f90
+13 -13
View File
@@ -65,7 +65,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
name='psb_igatherm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -73,7 +73,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,7 +81,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -89,7 +89,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
else
root = -1
end if
if (root==-1) then
if (root == -1) then
iiroot = psb_root_
else
iiroot = root
@@ -117,15 +117,15 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -235,7 +235,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
name='psb_igatherv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -243,7 +243,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -251,7 +251,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -278,15 +278,15 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/comm/psb_ihalo.f90
+24 -24
View File
@@ -78,7 +78,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
name='psb_ihalom'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -86,7 +86,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -135,14 +135,14 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -168,8 +168,8 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -178,8 +178,8 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -195,13 +195,13 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psi_swaptran(imode,k,ione,xp,&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
call psb_errpush(4010,name,a_err='PSI_iSwap...')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iSwap...')
goto 9999
end if
@@ -302,7 +302,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
name='psb_ihalov'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -310,7 +310,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -342,14 +342,14 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -371,8 +371,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -381,8 +381,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -397,13 +397,13 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
call psi_swaptran(imode,ione,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
call psb_errpush(4010,name,a_err='PSI_iswapdata')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iswapdata')
goto 9999
end if
base/comm/psb_iovrl.f90
+20 -20
View File
@@ -85,7 +85,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
name='psb_iovrlm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -93,7 +93,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -137,14 +137,14 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -165,8 +165,8 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -179,9 +179,9 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
call psi_swapdata(mode_,k,ione,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
@@ -286,7 +286,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
name='psb_iovrlv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -294,7 +294,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -324,14 +324,14 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -352,8 +352,8 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -366,9 +366,9 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
call psi_swapdata(mode_,ione,x(:),&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
base/comm/psb_iscatter.F90
+22 -22
View File
@@ -70,7 +70,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
name='psb_scatterm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -78,7 +78,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -86,7 +86,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -127,23 +127,23 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow=psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
@@ -156,8 +156,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -173,8 +173,8 @@ subroutine psb_iscatterm(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 /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -206,7 +206,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
end do
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
@@ -299,7 +299,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
name='psb_scatterv'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
debug_unit = psb_get_debug_unit()
@@ -309,7 +309,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -317,7 +317,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -343,24 +343,24 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
idx=desc_a%idxmap%loc_to_glob(i)
@@ -409,7 +409,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
& mpi_integer,locx,nrow,&
& mpi_integer,rootrank,icomm,info)
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
base/comm/psb_sgather.f90
+13 -13
View File
@@ -65,7 +65,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
name='psb_sgatherm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -73,7 +73,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,7 +81,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -89,7 +89,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
else
root = -1
end if
if (root==-1) then
if (root == -1) then
iiroot = psb_root_
else
iiroot = root
@@ -117,15 +117,15 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -235,7 +235,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
name='psb_sgatherv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -243,7 +243,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -251,7 +251,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -278,15 +278,15 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/comm/psb_shalo.f90
+24 -24
View File
@@ -77,7 +77,7 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
name='psb_shalom'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -85,7 +85,7 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -134,14 +134,14 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -165,8 +165,8 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -176,8 +176,8 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
aliw=.true.
!!$ write(0,*) 'halom ',liwork
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -193,14 +193,14 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psi_swaptran(imode,k,sone,xp,&
&desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_dSwapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@@ -298,7 +298,7 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
name='psb_shalov'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -306,7 +306,7 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -336,14 +336,14 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -365,8 +365,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -375,8 +375,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -391,14 +391,14 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
call psi_swaptran(imode,sone,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_swapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
base/comm/psb_sovrl.f90
+20 -20
View File
@@ -85,7 +85,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
name='psb_sovrlm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -93,7 +93,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -137,14 +137,14 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -166,8 +166,8 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -180,9 +180,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
call psi_swapdata(mode_,k,sone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
@@ -287,7 +287,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
name='psb_sovrlv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -295,7 +295,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -325,14 +325,14 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -353,8 +353,8 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -367,9 +367,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
call psi_swapdata(mode_,sone,x(:),&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
base/comm/psb_sscatter.F90
+22 -22
View File
@@ -72,7 +72,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
name='psb_scatterm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -80,7 +80,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -88,7 +88,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -129,23 +129,23 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow=psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
@@ -158,8 +158,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -175,8 +175,8 @@ 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 /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -208,7 +208,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
end do
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
@@ -301,7 +301,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
name='psb_scatterv'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
debug_unit = psb_get_debug_unit()
@@ -311,7 +311,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -319,7 +319,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -345,24 +345,24 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
idx=desc_a%idxmap%loc_to_glob(i)
@@ -411,7 +411,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
& mpi_real,locx,nrow,&
& mpi_real,rootrank,icomm,info)
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
base/comm/psb_zgather.f90
+14 -14
View File
@@ -65,7 +65,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
name='psb_zgatherm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -73,7 +73,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,7 +81,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -117,17 +117,17 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -238,7 +238,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
name='psb_zgatherv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -246,7 +246,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -254,7 +254,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -280,17 +280,17 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/comm/psb_zhalo.f90
+24 -24
View File
@@ -77,7 +77,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
name='psb_zhalom'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -85,7 +85,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -132,14 +132,14 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -163,8 +163,8 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -174,8 +174,8 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -191,14 +191,14 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psi_swaptran(imode,k,zone,xp,&
&desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_zswapdata'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@@ -298,7 +298,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
name='psb_zhalov'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -306,7 +306,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -337,14 +337,14 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -366,8 +366,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -376,8 +376,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -392,14 +392,14 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
call psi_swaptran(imode,zone,x(iix:size(x)),&
& desc_a,iwork,info)
else
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
goto 9999
end if
if(info /= 0) then
if(info /= psb_success_) then
ch_err='PSI_dSwap...'
call psb_errpush(4010,name,a_err=ch_err)
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
base/comm/psb_zovrl.f90
+20 -20
View File
@@ -86,7 +86,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
name='psb_zovrlm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -94,7 +94,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -138,14 +138,14 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -166,8 +166,8 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -180,9 +180,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
call psi_swapdata(mode_,k,zone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
@@ -285,7 +285,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
name='psb_zovrlv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -293,7 +293,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -323,14 +323,14 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
@@ -351,8 +351,8 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
@@ -365,9 +365,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
call psi_swapdata(mode_,zone,x(:),&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
base/comm/psb_zscatter.F90
+22 -22
View File
@@ -71,7 +71,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
name='psb_scatterm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -79,7 +79,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -87,7 +87,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -128,23 +128,23 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow=psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
@@ -157,8 +157,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! root has to gather size information
allocate(displ(np),all_dim(np),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -174,8 +174,8 @@ 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 /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -207,7 +207,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
end do
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
@@ -300,7 +300,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
name='psb_scatterv'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
debug_unit = psb_get_debug_unit()
@@ -310,7 +310,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -318,7 +318,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=30
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
@@ -344,24 +344,24 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = psb_cd_get_local_rows(desc_a)
if ((root == -1).or.(np==1)) then
if ((root == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
idx=desc_a%idxmap%loc_to_glob(i)
@@ -410,7 +410,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
& mpi_double_complex,locx,nrow,&
& mpi_double_complex,rootrank,icomm,info)
if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
end if
call psb_erractionrestore(err_act)
base/internals/psi_bld_g2lmap.f90
+5 -5
View File
@@ -58,7 +58,7 @@ subroutine psi_bld_g2lmap(desc,info)
integer :: ictxt,n_row
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psi_bld_g2lmap'
call psb_erractionsave(err_act)
@@ -70,14 +70,14 @@ subroutine psi_bld_g2lmap(desc,info)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
@@ -104,8 +104,8 @@ subroutine psi_bld_g2lmap(desc,info)
hmask = hsize - 1
desc%idxmap%hashvsize = hsize
desc%idxmap%hashvmask = hmask
if (info ==0) call psb_realloc(hsize+1,desc%idxmap%hashv,info,lb=0)
if (info /= 0) then
if (info == psb_success_) call psb_realloc(hsize+1,desc%idxmap%hashv,info,lb=0)
if (info /= psb_success_) then
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/internals/psi_bld_tmphalo.f90
+12 -12
View File
@@ -64,7 +64,7 @@ subroutine psi_bld_tmphalo(desc,info)
integer :: ictxt,n_row
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psi_bld_tmphalo'
call psb_erractionsave(err_act)
@@ -76,13 +76,13 @@ subroutine psi_bld_tmphalo(desc,info)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
@@ -91,8 +91,8 @@ subroutine psi_bld_tmphalo(desc,info)
! to call fnd_owner.
nh = (n_col-n_row)
Allocate(helem(max(1,nh)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -101,22 +101,22 @@ subroutine psi_bld_tmphalo(desc,info)
end do
call psb_map_l2g(helem(1:nh),desc%idxmap,info)
if (info == 0) &
if (info == psb_success_) &
& call psi_fnd_owner(nh,helem,hproc,desc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='fnd_owner')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='fnd_owner')
goto 9999
endif
if (nh > size(hproc)) then
info=4010
call psb_errpush(4010,name,a_err='nh > size(hproc)')
info=psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='nh > size(hproc)')
goto 9999
end if
allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
j = 1
base/internals/psi_bld_tmpovrl.f90
+4 -4
View File
@@ -71,7 +71,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info)
integer :: ictxt,n_row, debug_unit, debug_level
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psi_bld_tmpovrl'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
@@ -82,7 +82,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -107,7 +107,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info)
allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info)
if (info /= psb_no_err_) then
info=4010
info=psb_err_from_subroutine_
err=info
call psb_errpush(err,name,a_err='psb_realloc')
goto 9999
@@ -137,7 +137,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info)
l_ov_ix = l_ov_ix + 1
ov_idx(l_ov_ix) = -1
call psb_move_alloc(ov_idx,desc%ovrlap_index,info)
if (info == 0) call psb_move_alloc(ov_el,desc%ovrlap_elem,info)
if (info == psb_success_) call psb_move_alloc(ov_el,desc%ovrlap_elem,info)
call psb_erractionrestore(err_act)
base/internals/psi_compute_size.f90
+5 -5
View File
@@ -61,19 +61,19 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0
info = psb_success_
ictxt = desc_data(psb_ctxt_)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
allocate(counter_dl(0:np-1),counter_recv(0:np-1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -88,7 +88,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
do while (index_in(i) /= -1)
proc=index_in(i)
if ((proc > np-1).or.(proc < 0)) then
info = 115
info = psb_err_invalid_pid_arg_
int_err(1) = 11
int_err(2) = proc
call psb_errpush(info,name,i_err=int_err)
base/internals/psi_crea_bnd_elem.f90
+7 -7
View File
@@ -59,13 +59,13 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info)
integer :: i, j, nr, ns, k, err_act
character(len=20) :: name
info = 0
info = psb_success_
name='psi_crea_bnd_elem'
call psb_erractionsave(err_act)
allocate(work(size(desc_a%halo_index)),stat=info)
if (info /= 0 ) then
info = 4000
if (info /= psb_success_ ) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
@@ -88,8 +88,8 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info)
if (.true.) then
if (j>=0) then
call psb_realloc(j,bndel,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
bndel(1:j) = work(1:j)
@@ -100,8 +100,8 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info)
end if
else
call psb_realloc(j+1,bndel,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
bndel(1:j) = work(1:j)
base/internals/psi_crea_index.f90
+10 -10
View File
@@ -75,7 +75,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
info = psb_success_
name='psi_crea_index'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
@@ -84,7 +84,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -95,8 +95,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
dl_lda=np+1
allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -108,8 +108,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
call psi_extract_dep_list(desc_a%matrix_data,index_in,&
& dep_list,length_dl,np,max(1,dl_lda),mode,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='extrct_dl')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='extrct_dl')
goto 9999
end if
@@ -124,8 +124,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
! ....now i can sort dependency lists.
call psi_sort_dl(dep_list,length_dl,np,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_sort_dl')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_sort_dl')
goto 9999
end if
@@ -139,8 +139,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
& write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',&
& size(index_out)
nxch = length_dl(me)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_desc_index')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_desc_index')
goto 9999
end if
base/internals/psi_crea_ovr_elem.f90
+3 -3
View File
@@ -71,7 +71,7 @@ subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_crea_ovr_elem'
@@ -85,8 +85,8 @@ subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info)
insize = size(desc_overlap)
insize = max(1,(insize+1)/2)
allocate(telem(insize,3),stat=info)
if (info /= 0) then
info = 4000
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
base/internals/psi_cswapdata.F90
+44 -44
View File
@@ -107,7 +107,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
@@ -115,13 +115,13 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -133,14 +133,14 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -192,13 +192,13 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -218,8 +218,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -253,8 +253,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -267,8 +267,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -302,7 +302,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -354,7 +354,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& mpi_complex,prcid(i),&
@@ -379,7 +379,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=ksendid(ictxt,proc_to_comm,me)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& mpi_complex,prcid(i),&
@@ -392,7 +392,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -417,7 +417,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -597,20 +597,20 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -624,13 +624,13 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -711,8 +711,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -794,7 +794,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -881,7 +881,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -904,7 +904,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -977,13 +977,13 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_cswaptran.F90
+46 -46
View File
@@ -112,7 +112,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
@@ -121,13 +121,13 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -139,13 +139,13 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -197,13 +197,13 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -223,8 +223,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -258,8 +258,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -273,8 +273,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -313,7 +313,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -362,7 +362,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& mpi_complex,prcid(i),&
@@ -385,7 +385,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
@@ -399,7 +399,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -423,7 +423,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -601,7 +601,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
@@ -609,13 +609,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -627,13 +627,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -687,13 +687,13 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -713,8 +713,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -748,8 +748,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -763,8 +763,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -802,7 +802,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -851,7 +851,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),nesd,&
& mpi_complex,prcid(i),&
@@ -874,7 +874,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
@@ -888,7 +888,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -911,7 +911,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -988,13 +988,13 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_desc_index.F90
+16 -16
View File
@@ -136,7 +136,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
info = psb_success_
name='psi_desc_index'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
@@ -146,7 +146,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
icomm = psb_cd_get_mpic(desc)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -163,8 +163,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
! be careful of the inversion
!
allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info)
if(info /= 0) then
info=4000
if(info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
@@ -184,8 +184,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
end do
ihinsz=i
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mpi_alltoall')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall')
goto 9999
end if
@@ -220,8 +220,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
endif
!!$ call psb_ensure_size(ntot,desc_index,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_realloc')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
goto 9999
end if
@@ -230,8 +230,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
call psb_barrier(ictxt)
endif
allocate(sndbuf(iszs),rcvbuf(iszr),stat=info)
if(info /= 0) then
info=4000
if(info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
@@ -260,8 +260,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
call psb_map_l2g(index_in(i+1:i+nerv),&
& sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
& desc%idxmap,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_map_l2g')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_map_l2g')
goto 9999
end if
@@ -289,8 +289,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
call mpi_alltoallv(sndbuf,sdsz,bsdindx,mpi_integer,&
& rcvbuf,rvsz,brvindx,mpi_integer,icomm,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mpi_alltoallv')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
goto 9999
end if
@@ -317,8 +317,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
desc_index(i) = - 1
deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info)
if (info /= 0) then
info=4000
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
base/internals/psi_dswapdata.F90
+44 -44
View File
@@ -108,7 +108,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
@@ -116,13 +116,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -134,14 +134,14 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -193,13 +193,13 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -219,8 +219,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -254,8 +254,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -268,8 +268,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -303,7 +303,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -355,7 +355,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& mpi_double_precision,prcid(i),&
@@ -380,7 +380,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=ksendid(ictxt,proc_to_comm,me)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& mpi_double_precision,prcid(i),&
@@ -393,7 +393,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -418,7 +418,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -499,13 +499,13 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -597,20 +597,20 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -624,13 +624,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -711,8 +711,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -794,7 +794,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -881,7 +881,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -904,7 +904,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -977,13 +977,13 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_dswaptran.F90
+46 -46
View File
@@ -112,7 +112,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
@@ -121,13 +121,13 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -139,13 +139,13 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -197,13 +197,13 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -223,8 +223,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -258,8 +258,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -273,8 +273,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -313,7 +313,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -362,7 +362,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& mpi_double_precision,prcid(i),&
@@ -385,7 +385,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
@@ -399,7 +399,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -423,7 +423,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -601,7 +601,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
@@ -609,13 +609,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -627,13 +627,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -710,8 +710,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -799,7 +799,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -848,7 +848,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),nesd,&
& mpi_double_precision,prcid(i),&
@@ -871,7 +871,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
@@ -885,7 +885,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -908,7 +908,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -985,13 +985,13 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_exist_ovr_elem.f
+2 -2
View File
@@ -33,14 +33,14 @@ C
+ DIM_LIST,ELEM_SEARCHED)
C PURPOSE:
C =======
C == = ====
C
C If ELEM_SEARCHED exist in the list OVR_ELEM returns its position in
C the list, else returns -1
C
C
C INPUT
C ======
C == = ===
C OVRLAP_ELEMENT_D.: Contains for all overlap points belonging to
C the current process:
C 1. overlap point index
base/internals/psi_extrct_dl.F90
+12 -12
View File
@@ -33,19 +33,19 @@ subroutine psi_extract_dep_list(desc_data,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
@@ -110,7 +110,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_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
@@ -150,7 +150,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0
info = psb_success_
ictxt = desc_data(psb_ctxt_)
@@ -199,7 +199,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
endif
else if (mode == 0) then
if (pointer_dep_list > dl_lda) then
info = 4000
info = psb_err_alloc_dealloc_
goto 998
endif
dep_list(pointer_dep_list,me)=proc
@@ -230,7 +230,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
if (j == pointer_dep_list) then
! ...if not found.....
if (pointer_dep_list > dl_lda) then
info = 4000
info = psb_err_alloc_dealloc_
goto 998
endif
dep_list(pointer_dep_list,me)=proc
@@ -238,7 +238,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
endif
else if (mode == 0) then
if (pointer_dep_list > dl_lda) then
info = 4000
info = psb_err_alloc_dealloc_
goto 998
endif
dep_list(pointer_dep_list,me)=proc
@@ -265,16 +265,16 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
call psb_sum(ictxt,length_dl(0:np))
call psb_get_mpicomm(ictxt,icomm )
allocate(itmp(dl_lda),stat=info)
if (info /= 0) then
info=4000
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
goto 9999
endif
itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,mpi_integer,&
& dep_list,dl_lda,mpi_integer,icomm,info)
deallocate(itmp,stat=info)
if (info /= 0) then
info=4000
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
goto 9999
endif
base/internals/psi_fnd_owner.F90
+20 -20
View File
@@ -78,7 +78,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name
info = 0
info = psb_success_
name = 'psi_fnd_owner'
call psb_erractionsave(err_act)
@@ -92,19 +92,19 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (nv < 0 ) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_ok_desc(desc))) then
call psb_errpush(4010,name,a_err='invalid desc')
call psb_errpush(psb_err_from_subroutine_,name,a_err='invalid desc')
goto 9999
end if
@@ -118,8 +118,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
& sdsz(0:np-1),sdidx(0:np-1),&
& rvsz(0:np-1),rvidx(0:np-1),&
& stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -132,8 +132,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
end do
hsize = hidx(np+1)
Allocate(helem(hsize),hproc(hsize),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -158,9 +158,9 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
if (gettime) then
tidx = psb_wtime()-t3
end if
if (info == 140) info = 0
if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_idx_cnv')
if (info == psb_err_iarray_outside_bounds_) info = psb_success_
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_idx_cnv')
goto 9999
end if
@@ -190,8 +190,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
isz = sum(rvsz)
allocate(answers(isz,2),idxsrch(nv,2),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
j = 0
@@ -221,8 +221,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
! Now extract the answers for our local query
call psb_realloc(nv,iprc,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_realloc')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
goto 9999
end if
last_ih = -1
@@ -241,8 +241,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
if (j == -1) then
write(0,*) me,'psi_fnd_owner: searching for ',ih, &
& 'not found : ',size(answers,1),':',answers(:,1)
info = 4001
call psb_errpush(4001,name,a_err='out bounds srch ih')
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih')
goto 9999
end if
end if
@@ -253,8 +253,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
if (j == -1) then
write(0,*) me,'psi_fnd_owner: searching for ',ih, &
& 'not found : ',size(answers,1),':',answers(:,1)
info = 4001
call psb_errpush(4001,name,a_err='out bounds srch ih')
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih')
goto 9999
end if
end if
@@ -282,7 +282,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
call psb_amx(ictxt,tamx)
call psb_amx(ictxt,tidx)
call psb_amx(ictxt,t1)
if (me==psb_root_) then
if (me == psb_root_) then
write(*,'(" fnd_owner idx time : ",es10.4)') tidx
write(*,'(" fnd_owner amx time : ",es10.4)') tamx
write(*,'(" fnd_owner remainedr : ",es10.4)') t1
base/internals/psi_idx_cnv.f90
+5 -5
View File
@@ -65,7 +65,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
character(len=20) :: name
logical :: owned_
info = 0
info = psb_success_
name = 'psb_idx_cnv'
call psb_erractionsave(err_act)
@@ -78,7 +78,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc)) then
info = 3110
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
@@ -176,7 +176,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
! hence psi_inner_cnv does the hashing and binary search.
!
if (.not.allocated(desc%idxmap%hashv)) then
info = 4001
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid hashv into inner_cnv')
end if
call psi_inner_cnv(nv,idxin,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc,mask=mask)
@@ -313,7 +313,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
logical, pointer :: mask_(:)
logical :: owned_
info = 0
info = psb_success_
name = 'psb_idx_cnv'
call psb_erractionsave(err_act)
@@ -326,7 +326,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc)) then
info = 3110
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
base/internals/psi_idx_ins_cnv.f90
+24 -24
View File
@@ -69,7 +69,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
integer, parameter :: relocsz=200
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psb_idx_ins_cnv'
call psb_erractionsave(err_act)
@@ -82,7 +82,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
call psb_info(ictxt, me, np)
if (.not.psb_is_bld_desc(desc)) then
info = 3110
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
@@ -132,24 +132,24 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1)
if (info /= 0) then
if (info /= psb_success_) then
info=1
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%idxmap%loc_to_glob(nxt) = ip
endif
info = 0
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
idxin(i) = lip
info = 0
info = psb_success_
else
idxin(i) = -1
end if
@@ -175,24 +175,24 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1)
if (info /= 0) then
if (info /= psb_success_) then
info=1
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
endif
desc%idxmap%loc_to_glob(nxt) = ip
endif
info = 0
info = psb_success_
else
ch_err='SearchInsKeyVal'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
idxin(i) = lip
info = 0
info = psb_success_
enddo
endif
@@ -249,10 +249,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=3
if (info /= psb_success_) then
info=psb_err_invalid_ovr_num_
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
@@ -262,10 +262,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if ((pnt_halo+3) > isize) then
nh = isize + max(nv,relocsz)
call psb_realloc(nh,desc%halo_index,info,pad=-1)
if (info /= 0) then
if (info /= psb_success_) then
info=4
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
@@ -302,10 +302,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if (ncol > isize) then
nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=3
if (info /= psb_success_) then
info=psb_err_invalid_ovr_num_
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
@@ -315,10 +315,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
if ((pnt_halo+3) > isize) then
nh = isize + max(nv,relocsz)
call psb_realloc(nh,desc%halo_index,info,pad=-1)
if (info /= 0) then
if (info /= psb_success_) then
info=4
ch_err='psb_realloc'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
isize = nh
@@ -423,7 +423,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
integer, parameter :: relocsz=200
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psb_idx_ins_cnv'
call psb_erractionsave(err_act)
@@ -436,7 +436,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc)) then
info = 3110
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
endif
base/internals/psi_iswapdata.F90
+44 -44
View File
@@ -107,7 +107,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
@@ -115,13 +115,13 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -133,14 +133,14 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -192,13 +192,13 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -218,8 +218,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -253,8 +253,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -267,8 +267,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -302,7 +302,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& brvidx,mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -354,7 +354,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& mpi_integer,prcid(i),&
@@ -379,7 +379,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=ksendid(ictxt,proc_to_comm,me)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& mpi_integer,prcid(i),&
@@ -392,7 +392,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -417,7 +417,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -597,20 +597,20 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -624,13 +624,13 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -711,8 +711,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -794,7 +794,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& brvidx,mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -881,7 +881,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -904,7 +904,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -977,13 +977,13 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_iswaptran.F90
+46 -46
View File
@@ -112,7 +112,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
@@ -121,13 +121,13 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -139,13 +139,13 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -197,13 +197,13 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -223,8 +223,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -258,8 +258,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -273,8 +273,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -313,7 +313,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -362,7 +362,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& mpi_integer,prcid(i),&
@@ -385,7 +385,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
@@ -399,7 +399,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -423,7 +423,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -601,7 +601,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
@@ -609,13 +609,13 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -627,13 +627,13 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -687,13 +687,13 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -713,8 +713,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -748,8 +748,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -763,8 +763,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -802,7 +802,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -851,7 +851,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),nesd,&
& mpi_integer,prcid(i),&
@@ -874,7 +874,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
@@ -888,7 +888,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -911,7 +911,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -988,13 +988,13 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_ldsc_pre_halo.f90
+7 -7
View File
@@ -63,7 +63,7 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info)
integer :: ictxt,n_row
character(len=20) :: name,ch_err
info = 0
info = psb_success_
name = 'psi_ldsc_pre_halo'
call psb_erractionsave(err_act)
@@ -75,35 +75,35 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
call psi_bld_g2lmap(desc,info)
if (info /= 0) then
if (info /= psb_success_) then
ch_err='psi_bld_hash'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! We no longer need the inner hash structure.
call psb_free(desc%idxmap%hash,info)
if (info /= 0) then
if (info /= psb_success_) then
ch_err='psi_bld_tmphalo'
info = 4010
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (.not.ext_hv) then
call psi_bld_tmphalo(desc,info)
if (info /= 0) then
if (info /= psb_success_) then
ch_err='psi_bld_tmphalo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/internals/psi_sort_dl.f90
+4 -4
View File
@@ -48,12 +48,12 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
name='psi_sort_dl'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0
info = psb_success_
ndgmx = 0
do i=1,np
ndgmx = ndgmx + l_dep_list(i)
@@ -75,8 +75,8 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
call srtlist(dep_list,size(dep_list,1),l_dep_list,np,work(idg),&
& work(idgp),work(iupd),work(iedges),work(iidx),work(iich),info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='srtlist')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='srtlist')
goto 9999
endif
base/internals/psi_sswapdata.F90
+44 -44
View File
@@ -108,7 +108,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
@@ -116,13 +116,13 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -134,14 +134,14 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -193,13 +193,13 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -219,8 +219,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -254,8 +254,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -268,8 +268,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -303,7 +303,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -355,7 +355,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& mpi_real,prcid(i),&
@@ -380,7 +380,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=ksendid(ictxt,proc_to_comm,me)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& mpi_real,prcid(i),&
@@ -393,7 +393,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -418,7 +418,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -499,13 +499,13 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -597,20 +597,20 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -624,13 +624,13 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -711,8 +711,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -794,7 +794,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -881,7 +881,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -904,7 +904,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -977,13 +977,13 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_sswaptran.F90
+46 -46
View File
@@ -112,7 +112,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
@@ -121,13 +121,13 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -139,13 +139,13 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -197,13 +197,13 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -223,8 +223,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -258,8 +258,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -273,8 +273,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -313,7 +313,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -362,7 +362,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& mpi_real,prcid(i),&
@@ -385,7 +385,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
@@ -399,7 +399,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -423,7 +423,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -601,7 +601,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
@@ -609,13 +609,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -627,13 +627,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -710,8 +710,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -799,7 +799,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -848,7 +848,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),nesd,&
& mpi_real,prcid(i),&
@@ -871,7 +871,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
@@ -885,7 +885,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -908,7 +908,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -985,13 +985,13 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_zswapdata.F90
+44 -44
View File
@@ -107,7 +107,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
@@ -115,13 +115,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -133,14 +133,14 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -192,13 +192,13 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -218,8 +218,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -253,8 +253,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -267,8 +267,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -302,7 +302,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -354,7 +354,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& mpi_double_complex,prcid(i),&
@@ -379,7 +379,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=ksendid(ictxt,proc_to_comm,me)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& mpi_double_complex,prcid(i),&
@@ -392,7 +392,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -417,7 +417,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -597,20 +597,20 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
integer, pointer :: d_idx(:)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -624,13 +624,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -684,13 +684,13 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -711,8 +711,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -745,8 +745,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -760,8 +760,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -794,7 +794,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -881,7 +881,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -904,7 +904,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -977,13 +977,13 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/psi_zswaptran.F90
+46 -46
View File
@@ -112,7 +112,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
@@ -121,13 +121,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -139,13 +139,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -197,13 +197,13 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -223,8 +223,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -258,8 +258,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -273,8 +273,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -313,7 +313,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -362,7 +362,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& mpi_double_complex,prcid(i),&
@@ -385,7 +385,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
@@ -399,7 +399,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -423,7 +423,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -498,13 +498,13 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -601,7 +601,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
integer :: int_err(5)
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
@@ -609,13 +609,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
icomm = psb_cd_get_mpic(desc_a)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = 1122
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
@@ -627,13 +627,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='psb_cd_get_list')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= 0) goto 9999
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
@@ -687,13 +687,13 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
#endif
character(len=20) :: name
info = 0
info = psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
call psb_info(ictxt,me,np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -713,8 +713,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
@@ -748,8 +748,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
@@ -763,8 +763,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
@@ -802,7 +802,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -851,7 +851,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm/=me)) then
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = krecvid(ictxt,proc_to_comm,me)
call mpi_irecv(sndbuf(snd_pt),nesd,&
& mpi_double_complex,prcid(i),&
@@ -874,7 +874,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm/=me)) then
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=ksendid(ictxt,proc_to_comm,me)
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
@@ -888,7 +888,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -911,7 +911,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
info=400
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -988,13 +988,13 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= 0) then
call psb_errpush(4000,name)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
base/internals/srtlist.f
+1 -1
View File
@@ -155,7 +155,7 @@ c$$$ write(0,*) 'SRTLIST Input :',i,ip
write(0,*) 'SRTLIST: Edge:',ix,edges(1,ix),
+ edges(2,ix),dgp(ix)
enddo
info = 30
info = psb_err_input_value_invalid_i_
return
ENDIF
call psb_msort(ich(1:nch))
base/modules/psb_base_mat_mod.f03
+6 -6
View File
@@ -14,12 +14,12 @@ module psb_base_mat_mod
integer, allocatable :: aux(:)
contains
! ====================================
! == = =================================
!
! Getters
!
!
! ====================================
! == = =================================
procedure, pass(a) :: get_nrows => psb_base_get_nrows
procedure, pass(a) :: get_ncols => psb_base_get_ncols
procedure, pass(a) :: get_nzeros => psb_base_get_nzeros
@@ -39,11 +39,11 @@ module psb_base_mat_mod
procedure, pass(a) :: is_triangle => psb_base_is_triangle
procedure, pass(a) :: is_unit => psb_base_is_unit
! ====================================
! == = =================================
!
! Setters
!
! ====================================
! == = =================================
procedure, pass(a) :: set_nrows => psb_base_set_nrows
procedure, pass(a) :: set_ncols => psb_base_set_ncols
procedure, pass(a) :: set_dupl => psb_base_set_dupl
@@ -60,11 +60,11 @@ module psb_base_mat_mod
procedure, pass(a) :: set_aux => psb_base_set_aux
! ====================================
! == = =================================
!
! Data management
!
! ====================================
! == = =================================
procedure, pass(a) :: get_neigh => psb_base_get_neigh
procedure, pass(a) :: free => psb_base_free
procedure, pass(a) :: trim => psb_base_trim
base/modules/psb_base_tools_mod.f90
+12 -12
View File
@@ -212,7 +212,7 @@ contains
integer :: info
call psb_owned_index(res,idx,desc,info)
if (info /= 0) res=.false.
if (info /= psb_success_) res=.false.
psb_is_owned = res
end function psb_is_owned
@@ -226,7 +226,7 @@ contains
integer :: info
call psb_local_index(res,idx,desc,info)
if (info /= 0) res=.false.
if (info /= psb_success_) res=.false.
psb_is_local = res
end function psb_is_local
@@ -256,7 +256,7 @@ contains
allocate(lx(size(idx)),stat=info)
res=.false.
if (info /= 0) return
if (info /= psb_success_) return
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.)
res = (lx>0)
@@ -288,7 +288,7 @@ contains
allocate(lx(size(idx)),stat=info)
res=.false.
if (info /= 0) return
if (info /= psb_success_) return
call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.)
res = (lx>0)
@@ -533,7 +533,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
name = 'psb_cdall'
call psb_erractionsave(err_act)
@@ -541,7 +541,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (count((/ present(vg),present(vl),&
& present(parts),present(nl), present(repl) /)) /= 1) then
info=581
info=psb_err_no_optional_arg_
call psb_errpush(info,name,a_err=" vg, vl, parts, nl, repl")
goto 999
endif
@@ -550,7 +550,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
if (present(parts)) then
if (.not.present(mg)) then
info=581
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
end if
@@ -563,12 +563,12 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
else if (present(repl)) then
if (.not.present(mg)) then
info=581
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
end if
if (.not.repl) then
info=581
info=psb_err_no_optional_arg_
call psb_errpush(info,name)
goto 999
end if
@@ -587,8 +587,8 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
else if (present(nl)) then
allocate(itmpsz(0:np-1),stat=info)
if (info /= 0) then
info = 4000
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 999
endif
@@ -604,7 +604,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
endif
if (info /= 0) goto 999
if (info /= psb_success_) goto 999
call psb_erractionrestore(err_act)
return
base/modules/psb_c_base_mat_mod.f03
+12 -12
View File
@@ -102,11 +102,11 @@ module psb_c_base_mat_mod
!===================
! == =================
!
! BASE interfaces
!
!===================
! == =================
interface
@@ -374,11 +374,11 @@ module psb_c_base_mat_mod
!=================
! == ===============
!
! COO interfaces
!
!=================
! == ===============
interface
subroutine psb_c_coo_reallocate_nz(nz,a)
@@ -697,7 +697,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -707,7 +707,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -763,7 +763,7 @@ contains
end function c_coo_get_nzeros
!====================================
! == ==================================
!
!
!
@@ -774,7 +774,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine c_coo_set_nzeros(nz,a)
implicit none
@@ -785,7 +785,7 @@ contains
end subroutine c_coo_set_nzeros
!====================================
! == ==================================
!
!
!
@@ -795,7 +795,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -818,7 +818,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -829,7 +829,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine c_coo_transp_1mat(a)
implicit none
base/modules/psb_c_csc_mat_mod.f03
+4 -4
View File
@@ -318,7 +318,7 @@ module psb_c_csc_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -328,7 +328,7 @@ contains
!
!
!
!=====================================
! == ===================================
function c_csc_sizeof(a) result(res)
@@ -400,7 +400,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -410,7 +410,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine c_csc_free(a)
base/modules/psb_c_csr_mat_mod.f03
+4 -4
View File
@@ -319,7 +319,7 @@ module psb_c_csr_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -329,7 +329,7 @@ contains
!
!
!
!=====================================
! == ===================================
function c_csr_sizeof(a) result(res)
@@ -401,7 +401,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -411,7 +411,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine c_csr_free(a)
implicit none
base/modules/psb_c_mat_mod.f03
+6 -6
View File
@@ -108,7 +108,7 @@ module psb_c_mat_mod
end interface
!=====================================
! == ===================================
!
!
!
@@ -119,7 +119,7 @@ module psb_c_mat_mod
!
!
!
!=====================================
! == ===================================
interface
@@ -506,7 +506,7 @@ module psb_c_mat_mod
!=====================================
! == ===================================
!
!
!
@@ -517,7 +517,7 @@ module psb_c_mat_mod
!
!
!
!=====================================
! == ===================================
interface psb_csmm
subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans)
@@ -597,7 +597,7 @@ module psb_c_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -607,7 +607,7 @@ contains
!
!
!
!=====================================
! == ===================================
function psb_c_sizeof(a) result(res)
base/modules/psb_c_tools_mod.f90
+2 -2
View File
@@ -235,8 +235,8 @@ Module psb_c_tools_mod
!!$ ictxt = psb_cd_get_context(descin)
!!$
!!$ call psb_cdcpy(descin,cd_xt,info)
!!$ if (info ==0) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= 0) then
!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= psb_success_) then
!!$ write(0,*) 'Error on reinitialising the extension map'
!!$ call psb_error(ictxt)
!!$ call psb_abort(ictxt)
base/modules/psb_check_mod.f90
+40 -40
View File
@@ -82,74 +82,74 @@ contains
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
name='psb_chkvect'
call psb_erractionsave(err_act)
if (m < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
else if (n < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 3
int_err(2) = n
else if ((ix < 1) .and. (m /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 4
int_err(2) = ix
else if ((jx < 1) .and. (n /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 5
int_err(2) = jx
else if (psb_cd_get_local_cols(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_col_
int_err(3) = psb_cd_get_local_cols(desc_dec)
else if (psb_cd_get_local_rows(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_row_
int_err(3) = psb_cd_get_local_cols(desc_dec)
else if (lldx < psb_cd_get_local_cols(desc_dec)) then
info=50
info=psb_err_iarg_not_gtia_ii_
int_err(1) = 3
int_err(2) = lldx
int_err(3) = 6
int_err(4) = psb_n_col_
int_err(5) = psb_cd_get_local_cols(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < m) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 1
int_err(2) = m
int_err(3) = 6
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < ix) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 4
int_err(2) = ix
int_err(3) = 6
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < jx) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 5
int_err(2) = jx
int_err(3) = 6
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < (ix+m-1)) then
info=80
info=psb_err_iarg2_neg_
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = ix
end if
if (info /= 0) then
if (info /= psb_success_) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -207,74 +207,74 @@ contains
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
name='psb_chkglobvect'
call psb_erractionsave(err_act)
if (m < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
else if (n < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 3
int_err(2) = n
else if ((ix < 1) .and. (m /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 4
int_err(2) = ix
else if ((jx < 1) .and. (n /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 5
int_err(2) = jx
else if (psb_cd_get_local_cols(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_col_
int_err(3) = psb_cd_get_local_cols(desc_dec)
else if (psb_cd_get_local_rows(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_row_
int_err(3) = psb_cd_get_local_rows(desc_dec)
else if (lldx < psb_cd_get_global_rows(desc_dec)) then
info=50
info=psb_err_iarg_not_gtia_ii_
int_err(1) = 3
int_err(2) = lldx
int_err(3) = 6
int_err(4) = psb_n_col_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < m) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 1
int_err(2) = m
int_err(3) = 6
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < ix) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 4
int_err(2) = ix
int_err(3) = 6
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < jx) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 5
int_err(2) = jx
int_err(3) = 6
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < (ix+m-1)) then
info=80
info=psb_err_iarg2_neg_
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = ix
end if
if (info /= 0) then
if (info /= psb_success_) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
@@ -331,79 +331,79 @@ contains
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
name='psb_chkmat'
call psb_erractionsave(err_act)
if (m < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
else if (n < 0) then
info=10
info=psb_err_iarg_neg_
int_err(1) = 3
int_err(2) = n
else if ((ia < 1) .and. (m /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 4
int_err(2) = ia
else if ((ja < 1) .and. (n /= 0)) then
info=20
info=psb_err_iarg_pos_
int_err(1) = 5
int_err(2) = ja
else if (psb_cd_get_local_cols(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_col_
int_err(3) = psb_cd_get_local_cols(desc_dec)
else if (psb_cd_get_local_rows(desc_dec) < 0) then
info=40
info=psb_err_iarg_invalid_i_
int_err(1) = 6
int_err(2) = psb_n_row_
int_err(3) = psb_cd_get_local_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < m) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 1
int_err(2) = m
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < m) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 2
int_err(2) = n
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < ia) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 3
int_err(2) = ia
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < ja) then
info=60
info=psb_err_iarg_not_gteia_ii_
int_err(1) = 4
int_err(2) = ja
int_err(3) = 5
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < (ia+m-1)) then
info=80
info=psb_err_iarg2_neg_
int_err(1) = 1
int_err(2) = m
int_err(3) = 3
int_err(4) = ia
else if (psb_cd_get_global_cols(desc_dec) < (ja+n-1)) then
info=80
info=psb_err_iarg2_neg_
int_err(1) = 2
int_err(2) = n
int_err(3) = 4
int_err(4) = ja
end if
if (info /= 0) then
if (info /= psb_success_) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
base/modules/psb_const_mod.f90
+66
View File
@@ -105,5 +105,71 @@ module psb_const_mod
integer, parameter :: psb_dbleint_=2
character(len=5) :: psb_fidef_='CSR'
!
!
! Error constants
integer, parameter, public :: psb_success_=0
integer, parameter, public :: psb_err_pivot_too_small_=2
integer, parameter, public :: psb_err_invalid_ovr_num_=3
integer, parameter, public :: psb_err_invalid_input_=5
integer, parameter, public :: psb_err_iarg_neg_=10
integer, parameter, public :: psb_err_iarg_pos_=20
integer, parameter, public :: psb_err_input_value_invalid_i_=30
integer, parameter, public :: psb_err_input_asize_invalid_i_=35
integer, parameter, public :: psb_err_iarg_invalid_i_=40
integer, parameter, public :: psb_err_iarg_not_gtia_ii_=50
integer, parameter, public :: psb_err_iarg_not_gteia_ii_=60
integer, parameter, public :: psb_err_iarg_invalid_value_=70
integer, parameter, public :: psb_err_asb_nrc_error_=71
integer, parameter, public :: psb_err_iarg2_neg_=80
integer, parameter, public :: psb_err_ia2_not_increasing_=90
integer, parameter, public :: psb_err_ia1_not_increasing_=91
integer, parameter, public :: psb_err_ia1_badindices_=100
integer, parameter, public :: psb_err_invalid_args_combination_=110
integer, parameter, public :: psb_err_invalid_pid_arg_=115
integer, parameter, public :: psb_err_iarg_n_mbgtian_=120
integer, parameter, public :: psb_err_duplicate_coo=130
integer, parameter, public :: psb_err_invalid_input_format_=134
integer, parameter, public :: psb_err_unsupported_format_=135
integer, parameter, public :: psb_err_format_unknown_=136
integer, parameter, public :: psb_err_iarray_outside_bounds_=140
integer, parameter, public :: psb_err_iarray_outside_process_=150
integer, parameter, public :: psb_err_forgot_geall_=290
integer, parameter, public :: psb_err_forgot_spall_=295
integer, parameter, public :: psb_err_iarg_mbeeiarra_i_=300
integer, parameter, public :: psb_err_mpi_error_=400
integer, parameter, public :: psb_err_parm_differs_among_procs_=550
integer, parameter, public :: psb_err_entry_out_of_bounds_=551
integer, parameter, public :: psb_err_inconsistent_index_lists_=552
integer, parameter, public :: psb_err_partfunc_toomuchprocs_=570
integer, parameter, public :: psb_err_partfunc_toofewprocs_=575
integer, parameter, public :: psb_err_partfunc_wrong_pid_=580
integer, parameter, public :: psb_err_no_optional_arg_=581
integer, parameter, public :: psb_err_arg_m_required_=582
integer, parameter, public :: psb_err_many_optional_arg_=583
integer, parameter, public :: psb_err_spmat_invalid_state_=600
integer, parameter, public :: psb_err_invalid_cd_state_=1122
integer, parameter, public :: psb_err_invalid_a_and_cd_state_=1123
integer, parameter, public :: psb_err_blacs_error_=2010
integer, parameter, public :: psb_err_initerror_neugh_procs_=2011
integer, parameter, public :: psb_err_blacs_err_gridcols_not_1_=2030
integer, parameter, public :: psb_err_invalid_matrix_input_state_=2231
integer, parameter, public :: psb_err_input_no_regen_=2232
integer, parameter, public :: psb_err_lld_case_not_implemented_=3010
integer, parameter, public :: psb_err_transpose_unsupported_=3015
integer, parameter, public :: psb_err_transpose_c_unsupported_=3020
integer, parameter, public :: psb_err_transpose_not_n_unsupported_=3021
integer, parameter, public :: psb_err_only_unit_diag_=3022
integer, parameter, public :: psb_err_ja_nix_ia_niy_unsupported_=3030
integer, parameter, public :: psb_err_ix_n1_iy_n1_unsupported_=3040
integer, parameter, public :: psb_err_input_matrix_unassembled_=3110
integer, parameter, public :: psb_err_alloc_dealloc_=4000
integer, parameter, public :: psb_err_internal_error_=4001
integer, parameter, public :: psb_err_from_subroutine_=4010
integer, parameter, public :: psb_err_from_subroutine_i_=4012
integer, parameter, public :: psb_err_from_subroutine_ai_=4013
integer, parameter, public :: psb_err_alloc_request_=4025
integer, parameter, public :: psb_err_from_subroutine_non_=4011
integer, parameter, public :: psb_err_invalid_istop_=5001
end module psb_const_mod
base/modules/psb_d_base_mat_mod.f03
+12 -12
View File
@@ -102,11 +102,11 @@ module psb_d_base_mat_mod
!===================
! == =================
!
! BASE interfaces
!
!===================
! == =================
interface
@@ -374,11 +374,11 @@ module psb_d_base_mat_mod
!=================
! == ===============
!
! COO interfaces
!
!=================
! == ===============
interface
subroutine psb_d_coo_reallocate_nz(nz,a)
@@ -697,7 +697,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -707,7 +707,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -763,7 +763,7 @@ contains
end function d_coo_get_nzeros
!====================================
! == ==================================
!
!
!
@@ -774,7 +774,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine d_coo_set_nzeros(nz,a)
implicit none
@@ -785,7 +785,7 @@ contains
end subroutine d_coo_set_nzeros
!====================================
! == ==================================
!
!
!
@@ -795,7 +795,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -818,7 +818,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -829,7 +829,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine d_coo_transp_1mat(a)
implicit none
base/modules/psb_d_csc_mat_mod.f03
+4 -4
View File
@@ -318,7 +318,7 @@ module psb_d_csc_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -328,7 +328,7 @@ contains
!
!
!
!=====================================
! == ===================================
function d_csc_sizeof(a) result(res)
@@ -400,7 +400,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -410,7 +410,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine d_csc_free(a)
base/modules/psb_d_csr_mat_mod.f03
+4 -4
View File
@@ -319,7 +319,7 @@ module psb_d_csr_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -329,7 +329,7 @@ contains
!
!
!
!=====================================
! == ===================================
function d_csr_sizeof(a) result(res)
@@ -401,7 +401,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -411,7 +411,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine d_csr_free(a)
implicit none
base/modules/psb_d_mat_mod.f03
+6 -6
View File
@@ -108,7 +108,7 @@ module psb_d_mat_mod
end interface
!=====================================
! == ===================================
!
!
!
@@ -119,7 +119,7 @@ module psb_d_mat_mod
!
!
!
!=====================================
! == ===================================
interface
@@ -506,7 +506,7 @@ module psb_d_mat_mod
!=====================================
! == ===================================
!
!
!
@@ -517,7 +517,7 @@ module psb_d_mat_mod
!
!
!
!=====================================
! == ===================================
interface psb_csmm
subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans)
@@ -597,7 +597,7 @@ module psb_d_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -607,7 +607,7 @@ contains
!
!
!
!=====================================
! == ===================================
function psb_d_sizeof(a) result(res)
base/modules/psb_d_tools_mod.f90
+2 -2
View File
@@ -234,8 +234,8 @@ Module psb_d_tools_mod
!!$
!!$ ictxt = psb_cd_get_context(descin)
!!$ call psb_cdcpy(descin,cd_xt,info)
!!$ if (info ==0) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= 0) then
!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= psb_success_) then
!!$ write(0,*) 'Error on reinitialising the extension map'
!!$ call psb_error(ictxt)
!!$ call psb_abort(ictxt)
base/modules/psb_desc_type.f90
+75 -75
View File
@@ -474,7 +474,7 @@ contains
logical function psb_is_large_desc(desc)
type(psb_desc_type), intent(in) :: desc
psb_is_large_desc =(psb_desc_large_==psb_cd_get_size(desc))
psb_is_large_desc =(psb_desc_large_ == psb_cd_get_size(desc))
end function psb_is_large_desc
@@ -542,7 +542,7 @@ contains
integer :: dectype
psb_is_asb_dec = (dectype == psb_desc_asb_).or.&
& (dectype== psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_)
& (dectype == psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_)
end function psb_is_asb_dec
@@ -604,7 +604,7 @@ contains
psb_cd_get_context = desc%matrix_data(psb_ctxt_)
else
psb_cd_get_context = -1
call psb_errpush(1122,'psb_cd_get_context')
call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_context')
call psb_error()
end if
end function psb_cd_get_context
@@ -617,7 +617,7 @@ contains
psb_cd_get_dectype = desc%matrix_data(psb_dec_type_)
else
psb_cd_get_dectype = -1
call psb_errpush(1122,'psb_cd_get_dectype')
call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_dectype')
call psb_error()
end if
@@ -631,7 +631,7 @@ contains
psb_cd_get_size = desc%idxmap%state
else
psb_cd_get_size = -1
call psb_errpush(1122,'psb_cd_get_size')
call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_size')
call psb_error()
end if
@@ -645,7 +645,7 @@ contains
psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_)
else
psb_cd_get_mpic = -1
call psb_errpush(1122,'psb_cd_get_mpic')
call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_mpic')
call psb_error()
end if
@@ -712,7 +712,7 @@ contains
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20), parameter :: name='psb_cd_get_list'
info = 0
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -743,7 +743,7 @@ contains
case(psb_comm_mov_)
ipnt => desc%ovr_mst_idx
case default
info=4010
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='wrong Data selector')
goto 9999
end select
@@ -778,23 +778,23 @@ contains
character(len=*), parameter :: name = 'psb_idxmap_free'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
if (allocated(map%loc_to_glob)) then
deallocate(map%loc_to_glob,stat=info)
end if
if ((info == 0).and.allocated(map%glob_to_loc)) then
if ((info == psb_success_).and.allocated(map%glob_to_loc)) then
deallocate(map%glob_to_loc,stat=info)
end if
if ((info == 0).and.allocated(map%hashv)) then
if ((info == psb_success_).and.allocated(map%hashv)) then
deallocate(map%hashv,stat=info)
end if
if ((info == 0).and.allocated(map%glb_lc)) then
if ((info == psb_success_).and.allocated(map%glb_lc)) then
deallocate(map%glb_lc,stat=info)
end if
if (info /= 0) call psb_free(map%hash, info)
if (info /= 0) then
if (info /= psb_success_) call psb_free(map%hash, info)
if (info /= psb_success_) then
info=2052
call psb_errpush(info,name)
goto 9999
@@ -838,13 +838,13 @@ contains
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_cdfree'
if (.not.allocated(desc_a%matrix_data)) then
info=295
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
end if
@@ -854,7 +854,7 @@ contains
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -869,7 +869,7 @@ contains
!deallocate halo_index field
deallocate(desc_a%halo_index,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2053
call psb_errpush(info,name)
goto 9999
@@ -883,7 +883,7 @@ contains
else
!deallocate halo_index field
deallocate(desc_a%bnd_elem,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2054
call psb_errpush(info,name)
goto 9999
@@ -898,7 +898,7 @@ contains
!deallocate ovrlap_index field
deallocate(desc_a%ovrlap_index,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2055
call psb_errpush(info,name)
goto 9999
@@ -906,7 +906,7 @@ contains
!deallocate ovrlap_elem field
deallocate(desc_a%ovrlap_elem,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2056
call psb_errpush(info,name)
goto 9999
@@ -914,7 +914,7 @@ contains
!deallocate ovrlap_index field
deallocate(desc_a%ovr_mst_idx,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2055
call psb_errpush(info,name)
goto 9999
@@ -922,7 +922,7 @@ contains
deallocate(desc_a%lprm,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2057
call psb_errpush(info,name)
goto 9999
@@ -930,7 +930,7 @@ contains
if (allocated(desc_a%idx_space)) then
deallocate(desc_a%idx_space,stat=info)
if (info /= 0) then
if (info /= psb_success_) then
info=2056
call psb_errpush(info,name)
goto 9999
@@ -985,8 +985,8 @@ contains
integer :: debug_level, debug_unit
character(len=20) :: name
if (psb_get_errstatus()/=0) return
info = 0
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
name = 'psb_cdtransfer'
debug_unit = psb_get_debug_unit()
@@ -997,26 +997,26 @@ contains
! empty.
call psb_move_alloc( desc_in%matrix_data , desc_out%matrix_data , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%halo_index , desc_out%halo_index , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%bnd_elem , desc_out%bnd_elem , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%ovrlap_elem , desc_out%ovrlap_elem , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%ovrlap_index, desc_out%ovrlap_index , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%ovr_mst_idx , desc_out%ovr_mst_idx , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%ext_index , desc_out%ext_index , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%lprm , desc_out%lprm , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( desc_in%idx_space , desc_out%idx_space , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc(desc_in%idxmap, desc_out%idxmap,info)
if (info /= 0) then
info = 4010
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name)
goto 9999
endif
@@ -1057,8 +1057,8 @@ contains
integer :: debug_level, debug_unit
character(len=*), parameter :: name = 'psb_idxmap_transfer'
if (psb_get_errstatus()/=0) return
info = 0
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
@@ -1068,19 +1068,19 @@ contains
map_out%hashvsize = map_in%hashvsize
map_out%hashvmask = map_in%hashvmask
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( map_in%loc_to_glob , map_out%loc_to_glob , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( map_in%glob_to_loc , map_out%glob_to_loc , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( map_in%hashv , map_out%hashv , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( map_in%glb_lc , map_out%glb_lc , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_move_alloc( map_in%hash , map_out%hash , info)
if (info /= 0) then
info = 4010
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name)
goto 9999
endif
@@ -1121,8 +1121,8 @@ contains
integer :: debug_level, debug_unit
character(len=*), parameter :: name = 'psb_idxmap_transfer'
if (psb_get_errstatus()/=0) return
info = 0
if (psb_get_errstatus() /= 0) return
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
@@ -1133,17 +1133,17 @@ contains
map_out%hashvmask = map_in%hashvmask
call psb_safe_ab_cpy( map_in%loc_to_glob , map_out%loc_to_glob , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_safe_ab_cpy( map_in%glob_to_loc , map_out%glob_to_loc , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_safe_ab_cpy( map_in%hashv , map_out%hashv , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_safe_ab_cpy( map_in%glb_lc , map_out%glb_lc , info)
if (info == 0) &
if (info == psb_success_) &
& call psb_hash_copy( map_in%hash , map_out%hash , info)
if (info /= 0) then
info = 4010
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name)
goto 9999
endif
@@ -1172,15 +1172,15 @@ contains
type(psb_idxmap_type) :: map
integer :: nc
info = 0
info = psb_success_
if (.not.allocated(map%loc_to_glob)) then
info = 140
info = psb_err_iarray_outside_bounds_
idx = -1
return
end if
nc = size(map%loc_to_glob)
if ((idx < 1).or.(idx>nc)) then
info = 140
info = psb_err_iarray_outside_bounds_
idx = -1
return
end if
@@ -1195,15 +1195,15 @@ contains
type(psb_idxmap_type) :: map
integer :: nc
info = 0
info = psb_success_
if (.not.allocated(map%loc_to_glob)) then
info = 140
info = psb_err_iarray_outside_bounds_
gidx = -1
return
end if
nc = size(map%loc_to_glob)
if ((idx < 1).or.(idx>nc)) then
info = 140
info = psb_err_iarray_outside_bounds_
gidx = -1
return
end if
@@ -1218,10 +1218,10 @@ contains
type(psb_idxmap_type) :: map
integer :: nc, i, ix
info = 0
if (size(idx)==0) return
info = psb_success_
if (size(idx) == 0) return
if (.not.allocated(map%loc_to_glob)) then
info = 140
info = psb_err_iarray_outside_bounds_
idx = -1
return
end if
@@ -1229,7 +1229,7 @@ contains
do i=1, size(idx)
ix = idx(i)
if ((ix < 1).or.(ix>nc)) then
info = 140
info = psb_err_iarray_outside_bounds_
idx(i) = -1
else
idx(i) = map%loc_to_glob(ix)
@@ -1245,11 +1245,11 @@ contains
type(psb_idxmap_type) :: map
integer :: nc, i, ix
info = 0
if (size(idx)==0) return
info = psb_success_
if (size(idx) == 0) return
if ((.not.allocated(map%loc_to_glob)).or.&
& (size(gidx)<size(idx))) then
info = 140
info = psb_err_iarray_outside_bounds_
gidx = -1
return
end if
@@ -1258,7 +1258,7 @@ contains
do i=1, size(idx)
ix = idx(i)
if ((ix < 1).or.(ix>nc)) then
info = 140
info = psb_err_iarray_outside_bounds_
gidx(i) = -1
else
gidx(i) = map%loc_to_glob(ix)
@@ -1288,7 +1288,7 @@ contains
character(len=20) :: name
name = 'psb_cd_get_recv_idx'
info = 0
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -1307,7 +1307,7 @@ contains
idxlist => desc%ovr_mst_idx
write(0,*) 'Warning: unusual request getidx on ovr_mst_idx'
case default
info=4010
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='wrong Data selector')
goto 9999
end select
@@ -1315,9 +1315,9 @@ contains
l_tmp = 3*size(idxlist)
allocate(tmp(l_tmp),stat=info)
if (info /= 0) then
info = 4010
call psb_errpush(4010,name,a_err='Allocate')
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
@@ -1332,8 +1332,8 @@ contains
Do j=0,n_elem_recv-1
idx = idxlist(incnt+psb_elem_recv_+j)
call psb_ensure_size((outcnt+3),tmp,info,pad=-1)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
base/modules/psb_error_mod.F90
+1 -1
View File
@@ -523,7 +523,7 @@ contains
case(3024)
write (0,'("Cases DESCRA(1:1)=G not yet implemented. ")')
case(3030)
write (0,'("Case ja/=ix or ia/=iy is not yet implemented.")')
write (0,'("Case ja /= ix or ia/=iy is not yet implemented.")')
case(3040)
write (0,'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
case(3050)
base/modules/psb_gps_mod.f90
+3 -3
View File
@@ -122,13 +122,13 @@ CONTAINS
idpth = 0
ALLOCATE(SIZEG(NR),STPT(NR), STAT=INFO)
IF(INFO /= 0) THEN
IF(INFO /= psb_success_) THEN
WRITE(*,*) 'ERROR! MEMORY ALLOCATION # 1 FAILED IN GPS'
STOP
END IF
!
ALLOCATE(NHIGH(INIT), NLOW(INIT), NACUM(INIT), AUX(INIT), STAT=INFO)
IF(INFO /= 0) THEN
IF(INFO /= psb_success_) THEN
WRITE(*,*) 'ERROR! MEMORY ALLOCATION # 2 FAILED IN GPS'
STOP
END IF
@@ -747,7 +747,7 @@ CONTAINS
INTEGER :: SZ1,SZ2,INFO
call psb_realloc(sz2,vet,info)
IF(INFO /= 0) THEN
IF(INFO /= psb_success_) THEN
WRITE(*,*) 'Error! Memory allocation failure in REALLOC'
STOP
END IF
base/modules/psb_hash_mod.f90
+8 -8
View File
@@ -126,7 +126,7 @@ contains
use psb_realloc_mod
type(psb_hash_type) :: hashin
info = 0
info = psb_success_
if (allocated(hashin%table)) then
deallocate(hashin%table,stat=info)
end if
@@ -177,11 +177,11 @@ contains
if (associated(hashout)) then
deallocate(hashout,stat=info)
!if (info /= 0) return
!if (info /= psb_success_) return
end if
if (associated(hashin)) then
allocate(hashout,stat=info)
if (info /= 0) return
if (info /= psb_success_) return
call HashCopy(hashin,hashout,info)
end if
@@ -194,10 +194,10 @@ contains
integer :: i,j,k,hsize,nbits, nv
info = 0
info = psb_success_
nv = size(v)
call psb_hash_init(nv,hash,info)
if (info /= 0) return
if (info /= psb_success_) return
do i=1,nv
call psb_hash_searchinskey(v(i),j,i,hash,info)
if ((j /= i).or.(info /= HashOK)) then
@@ -215,7 +215,7 @@ contains
integer :: i,j,k,hsize,nbits
info = 0
info = psb_success_
nbits = 12
hsize = 2**nbits
!
@@ -238,7 +238,7 @@ contains
hash%nsrch = 0
hash%nacc = 0
allocate(hash%table(0:hsize-1,2),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
write(0,*) 'Error: memory allocation failure ',hsize
info = HashOutOfMemory
return
@@ -267,7 +267,7 @@ contains
nextval = hash%table(i,2)
if (key /= HashFreeEntry) then
call psb_hash_searchinskey(key,val,nextval,nhash,info)
if (info /= 0) then
if (info /= psb_success_) then
info = HashOutOfMemory
return
end if
base/modules/psb_ip_reord_mod.f90
+18 -18
View File
@@ -67,7 +67,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -96,7 +96,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -124,7 +124,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -154,7 +154,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -182,7 +182,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -212,7 +212,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -246,7 +246,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -278,7 +278,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -312,7 +312,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -344,7 +344,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -378,7 +378,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -414,7 +414,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -450,7 +450,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -486,7 +486,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -523,7 +523,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -562,7 +562,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -601,7 +601,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
@@ -640,7 +640,7 @@ contains
lp = iaux(0)
k = 1
do
if ((lp==0).or.(k>n)) exit
if ((lp == 0).or.(k>n)) exit
do
if (lp >= k) exit
lp = iaux(lp)
base/modules/psb_penv_mod.F90
+42 -42
View File
@@ -207,7 +207,7 @@ contains
#endif
if (present(np)) then
if (np_ < np) then
info = 2011
info = psb_err_initerror_neugh_procs_
call psb_errpush(info,name)
call psb_error(ictxt)
endif
@@ -305,7 +305,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -329,7 +329,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -353,7 +353,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -378,7 +378,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -403,7 +403,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -427,7 +427,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -453,7 +453,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -478,7 +478,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -502,7 +502,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -527,7 +527,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -551,7 +551,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -575,7 +575,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -599,7 +599,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -623,7 +623,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -647,7 +647,7 @@ contains
call psb_info(ictxt,iam,np)
if (iam==root_) then
if (iam == root_) then
call gebs2d(ictxt,'A',dat)
else
call gebr2d(ictxt,'A',dat,rrt=root_)
@@ -837,9 +837,9 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_=dat
if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info)
if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_=dat
call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info)
@@ -878,9 +878,9 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_=dat
if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info)
if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_=dat
call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info)
@@ -953,10 +953,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info)
@@ -995,10 +995,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
if (info ==0)&
if (info == psb_success_)&
& call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info)
@@ -1070,10 +1070,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info)
@@ -1112,10 +1112,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
if (info ==0)&
if (info == psb_success_)&
& call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info)
@@ -1188,9 +1188,9 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_=dat
if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info)
if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_=dat
call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info)
@@ -1229,9 +1229,9 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_=dat
if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info)
if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_=dat
call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info)
@@ -1304,10 +1304,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info)
@@ -1346,10 +1346,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info)
@@ -1423,10 +1423,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info)
@@ -1465,10 +1465,10 @@ contains
if (root_ == -1) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
if (info ==0) &
if (info == psb_success_) &
& call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
call psb_realloc(size(dat,1),size(dat,2),dat_,info)
dat_ = dat
call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info)
@@ -2366,7 +2366,7 @@ contains
dat_=dat
call mpi_allreduce(dat_,dat,isz,mpi_int8_type,mpi_sum,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
dat_=dat
call mpi_reduce(dat_,dat,isz,mpi_int8_type,mpi_sum,root_,icomm,info)
else
@@ -2406,7 +2406,7 @@ contains
dat_=dat
call mpi_allreduce(dat_,dat,1,mpi_int8_type,mpi_sum,icomm,info)
else
if (iam==root_) then
if (iam == root_) then
dat_=dat
call mpi_reduce(dat_,dat,1,mpi_int8_type,mpi_sum,root_,icomm,info)
else
base/modules/psb_realloc_mod.F90
+161 -161
View File
@@ -121,10 +121,10 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -132,8 +132,8 @@ Contains
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -172,10 +172,10 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
if (allocated(vin)) then
@@ -184,8 +184,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -224,9 +224,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -234,8 +234,8 @@ Contains
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -274,9 +274,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -286,8 +286,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -326,9 +326,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -336,8 +336,8 @@ Contains
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -376,9 +376,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -388,8 +388,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -428,9 +428,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -438,8 +438,8 @@ Contains
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -478,9 +478,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -490,8 +490,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -530,17 +530,17 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
if (allocated(vin)) then
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -579,9 +579,9 @@ Contains
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
if (allocated(vin)) then
@@ -590,8 +590,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -631,16 +631,16 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -678,9 +678,9 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -689,8 +689,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -728,17 +728,17 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -776,9 +776,9 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -787,8 +787,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -826,16 +826,16 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -873,9 +873,9 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -884,8 +884,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -923,17 +923,17 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -971,9 +971,9 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -982,8 +982,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -1021,16 +1021,16 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -1069,9 +1069,9 @@ Contains
name='psb_safe_cpy'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
isz1 = size(vin,1)
@@ -1079,8 +1079,8 @@ Contains
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
@@ -1268,10 +1268,10 @@ Contains
name='psb_ensure_size'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1287,8 +1287,8 @@ Contains
endif
call psb_realloc(isz,v,info,pad=pad)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
@@ -1327,10 +1327,10 @@ Contains
name='psb_ensure_size'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1346,8 +1346,8 @@ Contains
endif
call psb_realloc(isz,v,info,pad=pad)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
End If
@@ -1385,10 +1385,10 @@ Contains
name='psb_ensure_size'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1404,8 +1404,8 @@ Contains
endif
call psb_realloc(isz,v,info,pad=pad)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
End If
@@ -1444,10 +1444,10 @@ Contains
name='psb_ensure_size'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1462,8 +1462,8 @@ Contains
endif
endif
call psb_realloc(isz,v,info,pad=pad)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
@@ -1502,10 +1502,10 @@ Contains
name='psb_ensure_size'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1520,8 +1520,8 @@ Contains
endif
endif
call psb_realloc(isz,v,info,pad=pad)
if (info /= 0) then
info=4010
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
@@ -1561,12 +1561,12 @@ Contains
name='psb_dreallocate1i'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if (debug) write(0,*) 'reallocate I',len
if (psb_get_errstatus() /= 0) then
if (debug) write(0,*) 'reallocate errstatus /= 0'
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
@@ -1587,7 +1587,7 @@ Contains
lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer')
goto 9999
@@ -1600,7 +1600,7 @@ Contains
else
dim = 0
allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer')
goto 9999
@@ -1646,7 +1646,7 @@ Contains
name='psb_dreallocate1s'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (debug) write(0,*) 'reallocate S',len
if (present(lb)) then
@@ -1666,7 +1666,7 @@ Contains
lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)')
goto 9999
@@ -1677,7 +1677,7 @@ Contains
else
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)')
goto 9999
@@ -1720,7 +1720,7 @@ Contains
name='psb_dreallocate1d'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (debug) write(0,*) 'reallocate D',len
if (present(lb)) then
@@ -1740,7 +1740,7 @@ Contains
lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_dpk_)')
goto 9999
@@ -1751,7 +1751,7 @@ Contains
else
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_dpk_)')
goto 9999
@@ -1795,7 +1795,7 @@ Contains
name='psb_dreallocate1c'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (debug) write(0,*) 'reallocate C',len
if (present(lb)) then
lb_ = lb
@@ -1814,7 +1814,7 @@ Contains
lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)')
goto 9999
@@ -1825,7 +1825,7 @@ Contains
else
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)')
goto 9999
@@ -1868,7 +1868,7 @@ Contains
name='psb_dreallocate1z'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (debug) write(0,*) 'reallocate Z',len
if (present(lb)) then
lb_ = lb
@@ -1887,7 +1887,7 @@ Contains
lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_dpk_)')
goto 9999
@@ -1898,7 +1898,7 @@ Contains
else
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_dpk_)')
goto 9999
@@ -1943,7 +1943,7 @@ Contains
name='psb_dreallocates2'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (present(lb1)) then
lb1_ = lb1
else
@@ -1977,7 +1977,7 @@ Contains
If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)&
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)')
goto 9999
@@ -1990,7 +1990,7 @@ Contains
dim = 0
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)')
goto 9999
@@ -2035,7 +2035,7 @@ Contains
name='psb_dreallocated2'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (present(lb1)) then
lb1_ = lb1
else
@@ -2069,7 +2069,7 @@ Contains
If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)&
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_dpk_)')
goto 9999
@@ -2082,7 +2082,7 @@ Contains
dim = 0
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_dpk_)')
goto 9999
@@ -2127,7 +2127,7 @@ Contains
name='psb_dreallocatec2'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (present(lb1)) then
lb1_ = lb1
else
@@ -2161,7 +2161,7 @@ Contains
If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)&
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)')
goto 9999
@@ -2174,7 +2174,7 @@ Contains
dim = 0
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)')
goto 9999
@@ -2219,7 +2219,7 @@ Contains
name='psb_dreallocatez2'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (present(lb1)) then
lb1_ = lb1
else
@@ -2253,7 +2253,7 @@ Contains
If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)&
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_dpk_)')
goto 9999
@@ -2266,7 +2266,7 @@ Contains
dim = 0
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_dpk_)')
goto 9999
@@ -2311,7 +2311,7 @@ Contains
name='psb_dreallocatei2'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
if (present(lb1)) then
lb1_ = lb1
else
@@ -2344,7 +2344,7 @@ Contains
If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)&
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer')
goto 9999
@@ -2357,7 +2357,7 @@ Contains
dim = 0
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer')
goto 9999
@@ -2397,21 +2397,21 @@ Contains
name='psb_dreallocate2i'
call psb_erractionsave(err_act)
info=0
info=psb_success_
if(psb_get_errstatus() /= 0) then
info = 4010
info = psb_err_from_subroutine_
goto 9999
end if
call psb_dreallocate1i(len,rrax,info,pad=pad)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_dreallocate1i(len,y,info,pad=pad)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
@@ -2449,21 +2449,21 @@ Contains
call psb_erractionsave(err_act)
info = 0
info = psb_success_
call psb_realloc(len,rrax,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,y,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,z,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
@@ -2496,22 +2496,22 @@ Contains
name='psb_dreallocate2i1d'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
call psb_realloc(len,rrax,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,y,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,z,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
@@ -2546,21 +2546,21 @@ Contains
call psb_erractionsave(err_act)
info = 0
info = psb_success_
call psb_realloc(len,rrax,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,y,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,z,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
@@ -2592,21 +2592,21 @@ Contains
name='psb_dreallocate2i1z'
call psb_erractionsave(err_act)
info = 0
info = psb_success_
call psb_realloc(len,rrax,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,y,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_realloc(len,z,info)
if (info /= 0) then
if (info /= psb_success_) then
err=4000
call psb_errpush(err,name)
goto 9999
@@ -2631,7 +2631,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_smove_alloc1d
@@ -2642,7 +2642,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_smove_alloc2d
@@ -2653,7 +2653,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_dmove_alloc1d
@@ -2664,7 +2664,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_dmove_alloc2d
@@ -2675,7 +2675,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_cmove_alloc1d
@@ -2686,7 +2686,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_cmove_alloc2d
@@ -2697,7 +2697,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_zmove_alloc1d
@@ -2708,7 +2708,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_zmove_alloc2d
@@ -2719,7 +2719,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_imove_alloc1d
@@ -2729,7 +2729,7 @@ Contains
integer, intent(out) :: info
!
!
info = 0
info = psb_success_
call move_alloc(vin,vout)
end Subroutine psb_imove_alloc2d
base/modules/psb_s_base_mat_mod.f03
+12 -12
View File
@@ -102,11 +102,11 @@ module psb_s_base_mat_mod
!===================
! == =================
!
! BASE interfaces
!
!===================
! == =================
interface
@@ -374,11 +374,11 @@ module psb_s_base_mat_mod
!=================
! == ===============
!
! COO interfaces
!
!=================
! == ===============
interface
subroutine psb_s_coo_reallocate_nz(nz,a)
@@ -697,7 +697,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -707,7 +707,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -763,7 +763,7 @@ contains
end function s_coo_get_nzeros
!====================================
! == ==================================
!
!
!
@@ -774,7 +774,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine s_coo_set_nzeros(nz,a)
implicit none
@@ -785,7 +785,7 @@ contains
end subroutine s_coo_set_nzeros
!====================================
! == ==================================
!
!
!
@@ -795,7 +795,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -818,7 +818,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -829,7 +829,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine s_coo_transp_1mat(a)
implicit none
base/modules/psb_s_csc_mat_mod.f03
+4 -4
View File
@@ -318,7 +318,7 @@ module psb_s_csc_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -328,7 +328,7 @@ contains
!
!
!
!=====================================
! == ===================================
function s_csc_sizeof(a) result(res)
@@ -400,7 +400,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -410,7 +410,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine s_csc_free(a)
base/modules/psb_s_csr_mat_mod.f03
+4 -4
View File
@@ -319,7 +319,7 @@ module psb_s_csr_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -329,7 +329,7 @@ contains
!
!
!
!=====================================
! == ===================================
function s_csr_sizeof(a) result(res)
@@ -401,7 +401,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -411,7 +411,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine s_csr_free(a)
implicit none
base/modules/psb_s_mat_mod.f03
+6 -6
View File
@@ -108,7 +108,7 @@ module psb_s_mat_mod
end interface
!=====================================
! == ===================================
!
!
!
@@ -119,7 +119,7 @@ module psb_s_mat_mod
!
!
!
!=====================================
! == ===================================
interface
@@ -506,7 +506,7 @@ module psb_s_mat_mod
!=====================================
! == ===================================
!
!
!
@@ -517,7 +517,7 @@ module psb_s_mat_mod
!
!
!
!=====================================
! == ===================================
interface psb_csmm
subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans)
@@ -597,7 +597,7 @@ module psb_s_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -607,7 +607,7 @@ contains
!
!
!
!=====================================
! == ===================================
function psb_s_sizeof(a) result(res)
base/modules/psb_s_tools_mod.f90
+2 -2
View File
@@ -236,8 +236,8 @@ Module psb_s_tools_mod
!!$
!!$ ictxt = psb_cd_get_context(descin)
!!$ call psb_cdcpy(descin,cd_xt,info)
!!$ if (info ==0) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= 0) then
!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= psb_success_) then
!!$ write(0,*) 'Error on reinitialising the extension map'
!!$ call psb_error(ictxt)
!!$ call psb_abort(ictxt)
base/modules/psb_z_base_mat_mod.f03
+12 -12
View File
@@ -102,11 +102,11 @@ module psb_z_base_mat_mod
!===================
! == =================
!
! BASE interfaces
!
!===================
! == =================
interface
@@ -374,11 +374,11 @@ module psb_z_base_mat_mod
!=================
! == ===============
!
! COO interfaces
!
!=================
! == ===============
interface
subroutine psb_z_coo_reallocate_nz(nz,a)
@@ -697,7 +697,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -707,7 +707,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -763,7 +763,7 @@ contains
end function z_coo_get_nzeros
!====================================
! == ==================================
!
!
!
@@ -774,7 +774,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine z_coo_set_nzeros(nz,a)
implicit none
@@ -785,7 +785,7 @@ contains
end subroutine z_coo_set_nzeros
!====================================
! == ==================================
!
!
!
@@ -795,7 +795,7 @@ contains
!
!
!
!====================================
! == ==================================
@@ -818,7 +818,7 @@ contains
!====================================
! == ==================================
!
!
!
@@ -829,7 +829,7 @@ contains
!
!
!
!====================================
! == ==================================
subroutine z_coo_transp_1mat(a)
implicit none
base/modules/psb_z_csc_mat_mod.f03
+4 -4
View File
@@ -318,7 +318,7 @@ module psb_z_csc_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -328,7 +328,7 @@ contains
!
!
!
!=====================================
! == ===================================
function z_csc_sizeof(a) result(res)
@@ -400,7 +400,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -410,7 +410,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine z_csc_free(a)
base/modules/psb_z_csr_mat_mod.f03
+4 -4
View File
@@ -319,7 +319,7 @@ module psb_z_csr_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -329,7 +329,7 @@ contains
!
!
!
!=====================================
! == ===================================
function z_csr_sizeof(a) result(res)
@@ -401,7 +401,7 @@ contains
!=====================================
! == ===================================
!
!
!
@@ -411,7 +411,7 @@ contains
!
!
!
!=====================================
! == ===================================
subroutine z_csr_free(a)
implicit none
base/modules/psb_z_mat_mod.f03
+6 -6
View File
@@ -108,7 +108,7 @@ module psb_z_mat_mod
end interface
!=====================================
! == ===================================
!
!
!
@@ -119,7 +119,7 @@ module psb_z_mat_mod
!
!
!
!=====================================
! == ===================================
interface
@@ -506,7 +506,7 @@ module psb_z_mat_mod
!=====================================
! == ===================================
!
!
!
@@ -517,7 +517,7 @@ module psb_z_mat_mod
!
!
!
!=====================================
! == ===================================
interface psb_csmm
subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans)
@@ -597,7 +597,7 @@ module psb_z_mat_mod
contains
!=====================================
! == ===================================
!
!
!
@@ -607,7 +607,7 @@ contains
!
!
!
!=====================================
! == ===================================
function psb_z_sizeof(a) result(res)
base/modules/psb_z_tools_mod.f90
+2 -2
View File
@@ -237,8 +237,8 @@ Module psb_z_tools_mod
!!$ ictxt = psb_cd_get_context(descin)
!!$
!!$ call psb_cdcpy(descin,cd_xt,info)
!!$ if (info ==0) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= 0) then
!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info)
!!$ if (info /= psb_success_) then
!!$ write(0,*) 'Error on reinitialising the extension map'
!!$ call psb_error(ictxt)
!!$ call psb_abort(ictxt)
base/psblas/pdtreecomb.F
+12 -12
View File
@@ -53,14 +53,14 @@ C
* ..
*
* Purpose
* =======
* == = ====
*
* PDTREECOMB does a 1-tree parallel combine operation on scalars,
* using the subroutine indicated by SUBPTR to perform the required
* computation.
*
* Arguments
* =========
* == = ======
*
* ICTXT (global input) INTEGER
* The BLACS context handle, indicating the global context of
@@ -89,7 +89,7 @@ C
* SUBPTR (local input) Pointer to the subroutine to call to perform
* the required combine.
*
* =====================================================================
* == = ==================================================================
*
* .. Local Scalars ..
LOGICAL BCAST, RSCOPE, CSCOPE
@@ -259,13 +259,13 @@ C
* ..
*
* Purpose
* =======
* == = ====
*
* DCOMBAMAX finds the element having max. absolute value as well
* as its corresponding globl index.
*
* Arguments
* =========
* == = ======
*
* V1 (local input/local output) DOUBLE PRECISION array of
* dimension 2. The first maximum absolute value element and
@@ -275,7 +275,7 @@ C
* The second maximum absolute value element and its global
* index. V2(1) = AMAX, V2(2) = INDX.
*
* =====================================================================
* == = ==================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ABS
@@ -305,12 +305,12 @@ C
* ..
*
* Purpose
* =======
* == = ====
*
* DCOMBSSQ does a scaled sum of squares on two scalars.
*
* Arguments
* =========
* == = ======
*
* V1 (local input/local output) DOUBLE PRECISION array of
* dimension 2. The first scaled sum. V1(1) = SCALE,
@@ -319,7 +319,7 @@ C
* V2 (local input) DOUBLE PRECISION array of dimension 2.
* The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ.
*
* =====================================================================
* == = ==================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
@@ -353,20 +353,20 @@ C
* ..
*
* Purpose
* =======
* == = ====
*
* DCOMBNRM2 combines local norm 2 results, taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
* == = ======
*
* X (local input) DOUBLE PRECISION
* Y (local input) DOUBLE PRECISION
* X and Y specify the values x and y. X and Y are supposed to
* be >= 0.
*
* =====================================================================
* == = ==================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
base/psblas/psb_camax.f90
+20 -20
View File
@@ -66,7 +66,7 @@ function psb_camax(x,desc_a, info, jx)
name='psb_camax'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -75,7 +75,7 @@ function psb_camax(x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -90,15 +90,15 @@ function psb_camax(x,desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -196,7 +196,7 @@ function psb_camaxv (x,desc_a, info)
name='psb_camaxv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -205,7 +205,7 @@ function psb_camaxv (x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -216,15 +216,15 @@ function psb_camaxv (x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -324,7 +324,7 @@ subroutine psb_camaxvs(res,x,desc_a, info)
name='psb_camaxvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -333,7 +333,7 @@ subroutine psb_camaxvs(res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -343,15 +343,15 @@ subroutine psb_camaxvs(res,x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -450,7 +450,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx)
name='psb_cmamaxs'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -459,7 +459,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -475,15 +475,15 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx)
k = min(size(x,2),size(res,1))
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_casum.f90
+15 -15
View File
@@ -67,7 +67,7 @@ function psb_casum (x,desc_a, info, jx)
name='psb_casum'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -76,7 +76,7 @@ function psb_casum (x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -92,15 +92,15 @@ function psb_casum (x,desc_a, info, jx)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -208,7 +208,7 @@ function psb_casumv(x,desc_a, info)
name='psb_casumv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -217,7 +217,7 @@ function psb_casumv(x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -229,15 +229,15 @@ function psb_casumv(x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -346,7 +346,7 @@ subroutine psb_casumvs(res,x,desc_a, info)
name='psb_casumvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -355,7 +355,7 @@ subroutine psb_casumvs(res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -367,15 +367,15 @@ subroutine psb_casumvs(res,x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_caxpby.f90
+13 -13
View File
@@ -69,13 +69,13 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -115,17 +115,17 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -219,14 +219,14 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info)
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -238,22 +238,22 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info)
! check vector correctness
call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
base/psblas/psb_cdot.f90
+25 -25
View File
@@ -67,13 +67,13 @@ function psb_cdot(x, y,desc_a, info, jx, jy)
name='psb_cdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -102,17 +102,17 @@ function psb_cdot(x, y,desc_a, info, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -216,14 +216,14 @@ function psb_cdotv(x, y,desc_a, info)
name='psb_cdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -236,17 +236,17 @@ function psb_cdotv(x, y,desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx)
if (info == 0)&
if (info == psb_success_)&
& call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -350,14 +350,14 @@ subroutine psb_cdotvs(res, x, y,desc_a, info)
name='psb_cdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -367,17 +367,17 @@ subroutine psb_cdotvs(res, x, y,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -482,14 +482,14 @@ subroutine psb_cmdots(res, x, y, desc_a, info)
name='psb_cmdots'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -501,22 +501,22 @@ subroutine psb_cmdots(res, x, y, desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ix /= ione).or.(iy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_cnrm2.f90
+15 -15
View File
@@ -64,14 +64,14 @@ function psb_cnrm2(x, desc_a, info, jx)
name='psb_cnrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -85,14 +85,14 @@ function psb_cnrm2(x, desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -196,14 +196,14 @@ function psb_cnrm2v(x, desc_a, info)
name='psb_cnrm2v'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -213,14 +213,14 @@ function psb_cnrm2v(x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -325,14 +325,14 @@ subroutine psb_cnrm2vs(res, x, desc_a, info)
name='psb_cnrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -342,14 +342,14 @@ subroutine psb_cnrm2vs(res, x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_cnrmi.f90
+7 -7
View File
@@ -58,14 +58,14 @@ function psb_cnrmi(a,desc_a,info)
name='psb_cnrmi'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -76,23 +76,23 @@ function psb_cnrmi(a,desc_a,info)
n = psb_cd_get_global_cols(desc_a)
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iia /= 1).or.(jja /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
if ((m /= 0).and.(n /= 0)) then
nrmi = a%csnmi()
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_csnmi'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/psblas/psb_cspmm.f90
+62 -62
View File
@@ -94,7 +94,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
name='psb_cspmm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -103,7 +103,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -146,7 +146,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
if ( (trans_ == 'N').or.(trans_ == 'T')&
& .or.(trans_ == 'C')) then
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -173,8 +173,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -187,8 +187,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -199,17 +199,17 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -217,7 +217,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -239,28 +239,28 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
& call psi_swapdata(psb_swap_send_,ib1,&
& czero,xp,desc_a,iwork,info)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
! local Matrix-vector product
call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),&
& beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
if((ib1 > 0).and.(doswap_))&
& call psi_swapdata(psb_swap_recv_,ib1,&
& czero,xp,desc_a,iwork,info)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
end do blk
else
if (doswap_)&
& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ib1,czero,x(:,1:ik),desc_a,iwork,info)
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info)
if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info)
end if
if(info /= 0) then
info = 4011
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -270,7 +270,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
! Matrix is transposed
if((ja /= iy).or.(ia /= ix)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -278,10 +278,10 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
! checking for vectors correctness
call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -289,7 +289,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -301,30 +301,30 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
! with a proper scale factor (1/np) to the overall product.
!
call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info)
if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
y(nrow+1:ncol,1:ik) = czero
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if (info /= 0) then
info = 4010
if (info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='psb_csmm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (doswap_)then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& ik,cone,y(:,1:ik),desc_a,iwork,info)
if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ik,cone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -336,8 +336,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -445,7 +445,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
name='psb_cspmv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -453,7 +453,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -481,7 +481,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if ( (trans_ == 'N').or.(trans_ == 'T')&
& .or.(trans_ == 'C')) then
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -509,8 +509,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -523,8 +523,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -536,17 +536,17 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -554,7 +554,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -566,8 +566,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
call psb_csmm(alpha,a,x,beta,y,info)
if(info /= 0) then
info = 4011
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -576,17 +576,17 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
! Matrix is transposed
if((ja /= iy).or.(ia /= ix)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0)&
if (info == psb_success_)&
& call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -594,7 +594,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -609,18 +609,18 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
! with a proper scale factor (1/np) to the overall product.
!
call psi_ovrl_save(x,xvsave,desc_a,info)
if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
yp(nrow+1:ncol) = czero
! local Matrix-vector product
if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_)
if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info /= 0) then
info = 4010
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='psb_csmm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -629,13 +629,13 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& cone,yp,desc_a,iwork,info)
if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& cone,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -647,8 +647,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/psblas/psb_cspsm.f90
+36 -36
View File
@@ -106,14 +106,14 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
name='psb_cspsm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -160,7 +160,7 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then
! OK
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -175,7 +175,7 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
lldy = size(y,1)
if((lldx < ncol).or.(lldy < ncol)) then
info=3010
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
goto 9999
end if
@@ -195,8 +195,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -219,12 +219,12 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -232,15 +232,15 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
if(ja /= ix) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= 0) then
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
@@ -250,8 +250,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
yp => y(iiy:lldy,jjy:jjy+ik-1)
call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='cssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -263,9 +263,9 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,&
& cone,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
end if
@@ -384,14 +384,14 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
name='psb_cspsv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -422,7 +422,7 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then
! Ok
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -437,7 +437,7 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
lldy = size(y)
if((lldx < ncol).or.(lldy < ncol)) then
info=3010
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
goto 9999
end if
@@ -458,8 +458,8 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -482,12 +482,12 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -495,15 +495,15 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
if(ja /= ix) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= 0) then
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
@@ -513,8 +513,8 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
yp => y(iiy:lldy)
call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='dcssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -526,9 +526,9 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
& cone,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
end if
base/psblas/psb_damax.f90
+20 -20
View File
@@ -66,7 +66,7 @@ function psb_damax (x,desc_a, info, jx)
name='psb_damax'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -75,7 +75,7 @@ function psb_damax (x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -90,15 +90,15 @@ function psb_damax (x,desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -195,7 +195,7 @@ function psb_damaxv (x,desc_a, info)
name='psb_damaxv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -204,7 +204,7 @@ function psb_damaxv (x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -215,15 +215,15 @@ function psb_damaxv (x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -317,7 +317,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
name='psb_damaxvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -326,7 +326,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -337,15 +337,15 @@ subroutine psb_damaxvs (res,x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -438,7 +438,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
name='psb_dmamaxs'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -447,7 +447,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -463,15 +463,15 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
k = min(size(x,2),size(res,1))
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_dasum.f90
+15 -15
View File
@@ -67,7 +67,7 @@ function psb_dasum (x,desc_a, info, jx)
name='psb_dasum'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -76,7 +76,7 @@ function psb_dasum (x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -92,15 +92,15 @@ function psb_dasum (x,desc_a, info, jx)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -209,7 +209,7 @@ function psb_dasumv (x,desc_a, info)
name='psb_dasumv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -218,7 +218,7 @@ function psb_dasumv (x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -230,15 +230,15 @@ function psb_dasumv (x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -342,7 +342,7 @@ subroutine psb_dasumvs(res,x,desc_a, info)
name='psb_dasumvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.d0
@@ -351,7 +351,7 @@ subroutine psb_dasumvs(res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -363,15 +363,15 @@ subroutine psb_dasumvs(res,x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_daxpby.f90
+13 -13
View File
@@ -68,14 +68,14 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
name='psb_dgeaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -115,17 +115,17 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -218,14 +218,14 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
name='psb_dgeaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -237,22 +237,22 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
! check vector correctness
call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
base/psblas/psb_ddot.f90
+25 -25
View File
@@ -70,13 +70,13 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
name='psb_ddot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -105,17 +105,17 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -222,14 +222,14 @@ function psb_ddotv(x, y,desc_a, info)
name='psb_ddot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -242,17 +242,17 @@ function psb_ddotv(x, y,desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -357,14 +357,14 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
name='psb_ddot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -374,17 +374,17 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -489,14 +489,14 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
name='psb_dmdots'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -508,22 +508,22 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ix /= ione).or.(iy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_dnrm2.f90
+15 -15
View File
@@ -66,14 +66,14 @@ function psb_dnrm2(x, desc_a, info, jx)
name='psb_dnrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -87,14 +87,14 @@ function psb_dnrm2(x, desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -200,14 +200,14 @@ function psb_dnrm2v(x, desc_a, info)
name='psb_dnrm2v'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -217,14 +217,14 @@ function psb_dnrm2v(x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -328,14 +328,14 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
name='psb_dnrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -345,14 +345,14 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_dnrmi.f90
+7 -7
View File
@@ -63,14 +63,14 @@ function psb_dnrmi(a,desc_a,info)
name='psb_dnrmi'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -81,23 +81,23 @@ function psb_dnrmi(a,desc_a,info)
n = psb_cd_get_global_cols(desc_a)
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iia /= 1).or.(jja /= 1)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
if ((m /= 0).and.(n /= 0)) then
nrmi = a%csnmi()
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_csnmi'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/psblas/psb_dspmm.f90
+62 -62
View File
@@ -94,7 +94,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
name='psb_dspmm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -103,7 +103,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -146,7 +146,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if ( (trans_ == 'N').or.(trans_ == 'T')&
& .or.(trans_ == 'C')) then
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -173,8 +173,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -187,8 +187,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -199,17 +199,17 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -217,7 +217,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -239,28 +239,28 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
& call psi_swapdata(psb_swap_send_,ib1,&
& dzero,xp,desc_a,iwork,info)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
! local Matrix-vector product
call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),&
& beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
if((ib1 > 0).and.(doswap_))&
& call psi_swapdata(psb_swap_recv_,ib1,&
& dzero,xp,desc_a,iwork,info)
if(info /= 0) exit blk
if(info /= psb_success_) exit blk
end do blk
else
if (doswap_)&
& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ib1,dzero,x(:,1:ik),desc_a,iwork,info)
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info)
if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info)
end if
if(info /= 0) then
info = 4011
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -270,7 +270,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! Matrix is transposed
if((ja /= iy).or.(ia /= ix)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -278,10 +278,10 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! checking for vectors correctness
call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -289,7 +289,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -301,30 +301,30 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! with a proper scale factor (1/np) to the overall product.
!
call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info)
if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
y(nrow+1:ncol,1:ik) = dzero
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if (info /= 0) then
info = 4010
if (info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='psb_csmm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (doswap_)then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info)
if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -336,8 +336,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -445,7 +445,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
name='psb_dspmv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
@@ -453,7 +453,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -481,7 +481,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if ( (trans_ == 'N').or.(trans_ == 'T')&
& .or.(trans_ == 'C')) then
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -509,8 +509,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -523,8 +523,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -536,17 +536,17 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -554,7 +554,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -566,8 +566,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
call psb_csmm(alpha,a,x,beta,y,info)
if(info /= 0) then
info = 4011
if(info /= psb_success_) then
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@@ -576,17 +576,17 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
! Matrix is transposed
if((ja /= iy).or.(ia /= ix)) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
call psb_errpush(info,name)
goto 9999
end if
! checking for vectors correctness
call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0)&
if (info == psb_success_)&
& call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -594,7 +594,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -609,18 +609,18 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
! with a proper scale factor (1/np) to the overall product.
!
call psi_ovrl_save(x,xvsave,desc_a,info)
if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
yp(nrow+1:ncol) = dzero
! local Matrix-vector product
if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_)
if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info /= 0) then
info = 4010
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='psb_csmm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -629,13 +629,13 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& done,yp,desc_a,iwork,info)
if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& done,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -647,8 +647,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
base/psblas/psb_dspsm.f90
+36 -36
View File
@@ -107,14 +107,14 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
name='psb_dspsm'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -161,7 +161,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then
! OK
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -176,7 +176,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
lldy = size(y,1)
if((lldx < ncol).or.(lldy < ncol)) then
info=3010
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
goto 9999
end if
@@ -196,8 +196,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -220,12 +220,12 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -233,15 +233,15 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
if(ja /= ix) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= 0) then
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
@@ -251,8 +251,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
yp => y(iiy:lldy,jjy:jjy+ik-1)
call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='cssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -264,9 +264,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,&
& done,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
end if
@@ -385,14 +385,14 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
name='psb_dspsv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -423,7 +423,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then
! Ok
else
info = 70
info = psb_err_iarg_invalid_value_
call psb_errpush(info,name)
goto 9999
end if
@@ -438,7 +438,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
lldy = size(y)
if((lldx < ncol).or.(lldy < ncol)) then
info=3010
info=psb_err_lld_case_not_implemented_
call psb_errpush(info,name)
goto 9999
end if
@@ -459,8 +459,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -483,12 +483,12 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
! checking for vectors correctness
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0)&
if (info == psb_success_)&
& call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect/mat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -496,15 +496,15 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
if(ja /= ix) then
! this case is not yet implemented
info = 3030
info = psb_err_ja_nix_ia_niy_unsupported_
end if
if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented
info = 3040
info = psb_err_ix_n1_iy_n1_unsupported_
end if
if(info /= 0) then
if(info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
@@ -514,8 +514,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
yp => y(iiy:lldy)
call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)
if(info /= 0) then
info = 4010
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='dcssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@@ -527,9 +527,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
& done,yp,desc_a,iwork,info,data=psb_comm_ovr_)
if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Inner updates')
if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
end if
base/psblas/psb_samax.f90
+20 -20
View File
@@ -66,7 +66,7 @@ function psb_samax (x,desc_a, info, jx)
name='psb_samax'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -75,7 +75,7 @@ function psb_samax (x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -90,15 +90,15 @@ function psb_samax (x,desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -195,7 +195,7 @@ function psb_samaxv (x,desc_a, info)
name='psb_samaxv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -204,7 +204,7 @@ function psb_samaxv (x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -215,15 +215,15 @@ function psb_samaxv (x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -317,7 +317,7 @@ subroutine psb_samaxvs (res,x,desc_a, info)
name='psb_samaxvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -326,7 +326,7 @@ subroutine psb_samaxvs (res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -337,15 +337,15 @@ subroutine psb_samaxvs (res,x,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -438,7 +438,7 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx)
name='psb_smamaxs'
if (psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
amax=0.d0
@@ -447,7 +447,7 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -463,15 +463,15 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx)
k = min(size(x,2),size(res,1))
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_sasum.f90
+15 -15
View File
@@ -67,7 +67,7 @@ function psb_sasum (x,desc_a, info, jx)
name='psb_sasum'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.0
@@ -76,7 +76,7 @@ function psb_sasum (x,desc_a, info, jx)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -92,15 +92,15 @@ function psb_sasum (x,desc_a, info, jx)
! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -209,7 +209,7 @@ function psb_sasumv (x,desc_a, info)
name='psb_sasumv'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.0
@@ -218,7 +218,7 @@ function psb_sasumv (x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -230,15 +230,15 @@ function psb_sasumv (x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -342,7 +342,7 @@ subroutine psb_sasumvs(res,x,desc_a, info)
name='psb_sasumvs'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
asum=0.0
@@ -351,7 +351,7 @@ subroutine psb_sasumvs(res,x,desc_a, info)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -363,15 +363,15 @@ subroutine psb_sasumvs(res,x,desc_a, info)
! check vector correctness
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_saxpby.f90
+13 -13
View File
@@ -68,14 +68,14 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
name='psb_sgeaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -115,17 +115,17 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -218,14 +218,14 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info)
name='psb_sgeaxpby'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -237,22 +237,22 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info)
! check vector correctness
call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 1'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect 2'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
end if
base/psblas/psb_sdot.f90
+25 -25
View File
@@ -70,13 +70,13 @@ function psb_sdot(x, y,desc_a, info, jx, jy)
name='psb_sdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -105,17 +105,17 @@ function psb_sdot(x, y,desc_a, info, jx, jy)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -222,14 +222,14 @@ function psb_sdotv(x, y,desc_a, info)
name='psb_sdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -242,17 +242,17 @@ function psb_sdotv(x, y,desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -356,14 +356,14 @@ subroutine psb_sdotvs(res, x, y,desc_a, info)
name='psb_sdot'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -373,17 +373,17 @@ subroutine psb_sdotvs(res, x, y,desc_a, info)
m = psb_cd_get_global_rows(desc_a)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if (info == 0) &
if (info == psb_success_) &
& call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iix /= ione).or.(iiy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -488,14 +488,14 @@ subroutine psb_smdots(res, x, y, desc_a, info)
name='psb_smdots'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -ione) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -507,22 +507,22 @@ subroutine psb_smdots(res, x, y, desc_a, info)
! check vector correctness
call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ix /= ione).or.(iy /= ione)) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
base/psblas/psb_snrm2.f90
+15 -15
View File
@@ -66,14 +66,14 @@ function psb_snrm2(x, desc_a, info, jx)
name='psb_snrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -87,14 +87,14 @@ function psb_snrm2(x, desc_a, info, jx)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -200,14 +200,14 @@ function psb_snrm2v(x, desc_a, info)
name='psb_snrm2v'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -217,14 +217,14 @@ function psb_snrm2v(x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
@@ -328,14 +328,14 @@ subroutine psb_snrm2vs(res, x, desc_a, info)
name='psb_snrm2'
if(psb_get_errstatus() /= 0) return
info=0
info=psb_success_
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
info = psb_err_blacs_error_
call psb_errpush(info,name)
goto 9999
endif
@@ -345,14 +345,14 @@ subroutine psb_snrm2vs(res, x, desc_a, info)
m = psb_cd_get_global_rows(desc_a)
call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx)
if(info /= 0) then
info=4010
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
call psb_errpush(info,name,a_err=ch_err)
end if
if (iix /= 1) then
info=3040
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if

Some files were not shown because too many files have changed in this diff Show More