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

New error handling interface for i_err and friends.

Browse Source
ILmat
Salvatore Filippone 8 years ago
parent c272444e32
commit aaf5383aa4
18 changed files with 822 additions and 1277 deletions
Show Stats Download Patch File Download Diff File

88
base/modules/auxil/psb_c_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_spk_)')
goto 9999
end if
endif

88
base/modules/auxil/psb_d_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_dpk_)')
goto 9999
end if
endif

88
base/modules/auxil/psb_e_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='integer(psb_epk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_epk_)')
goto 9999
end if
endif

88
base/modules/auxil/psb_m_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='integer(psb_mpk_)')
goto 9999
end if
endif

88
base/modules/auxil/psb_s_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_spk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_spk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='real(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='real(psb_spk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='real(psb_spk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='real(psb_spk_)')
goto 9999
end if
endif

88
base/modules/auxil/psb_z_realloc_mod.F90
Unescape Escape View File

@ -111,8 +111,8 @@ Contains
endif
if ((len<0)) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -124,8 +124,8 @@ Contains
Allocate(tmp(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -136,8 +136,8 @@ Contains
Allocate(rrax(lb_:ub_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
@ -188,14 +188,14 @@ Contains
if (len1 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
@ -210,8 +210,8 @@ Contains
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -224,8 +224,8 @@ Contains
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= psb_success_) then
err=4025
call psb_errpush(err,name, &
& i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
@ -275,8 +275,8 @@ Contains
if ((len<0)) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
ub_ = lb_ + len-1
@ -289,8 +289,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@ -302,8 +302,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
@ -355,15 +355,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
@ -379,8 +379,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -394,8 +394,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
@ -450,15 +450,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
@ -474,8 +474,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -489,8 +489,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name,i_err=(/iplen/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif
@ -545,15 +545,15 @@ Contains
if (len1 < 0) then
err=4025
iplen = len1
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
if (len2 < 0) then
err=4025
iplen = len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
@ -569,8 +569,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@ -584,8 +584,8 @@ Contains
if (info /= psb_success_) then
err=4025
iplen = len1*len2
call psb_errpush(err,name, &
& i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)')
call psb_errpush(err,name, i_err=(/iplen/), &
& a_err='complex(psb_dpk_)')
goto 9999
end if
endif

2
base/modules/error.f90
Unescape Escape View File

@ -52,7 +52,7 @@ subroutine FCpsb_errpush(err_c, r_name, i_err)
character(len=20), intent(in) :: r_name
integer(psb_ipk_) :: i_err(5)
call psb_errpush(err_c, r_name, i_err)
call psb_errpush(err_c, r_name, i_err=i_err)
end subroutine FCpsb_errpush

30
base/modules/psb_error_impl.F90
Unescape Escape View File

@ -2,7 +2,7 @@
subroutine psb_errcomm(ictxt, err)
use psb_error_mod, psb_protect_name => psb_errcomm
use psb_penv_mod
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(inout):: err
if (psb_get_global_checks()) call psb_amx(ictxt, err)
@ -45,7 +45,7 @@ end subroutine psb_par_error_handler
subroutine psb_par_error_print_stack(ictxt)
use psb_error_mod, psb_protect_name => psb_par_error_print_stack
use psb_penv_mod
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
call psb_error(ictxt, abrt=.false.)
@ -68,24 +68,24 @@ subroutine psb_serror()
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_epk_) :: e_e_d(5)
if (psb_errstatus_fatal()) then
if(psb_get_errverbosity() > 1) then
do while (psb_get_numerr() > izero)
write(psb_err_unit,'(50("="))')
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d)
! write(psb_err_unit,'(50("="))')
end do
else
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
end do
end if
end if
@ -103,13 +103,13 @@ subroutine psb_perror(ictxt,abrt)
use psb_error_mod
use psb_penv_mod
implicit none
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_epk_) :: e_e_d(5)
integer(psb_mpk_) :: iam, np
logical :: abrt_
@ -122,8 +122,8 @@ subroutine psb_perror(ictxt,abrt)
do while (psb_get_numerr() > izero)
write(psb_err_unit,'(50("="))')
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam)
! write(psb_err_unit,'(50("="))')
end do
#if defined(HAVE_FLUSH_STMT)
@ -134,10 +134,10 @@ subroutine psb_perror(ictxt,abrt)
else
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
end do
#if defined(HAVE_FLUSH_STMT)
flush(psb_err_unit)

192
base/modules/psb_error_mod.F90
Unescape Escape View File

@ -82,8 +82,8 @@ module psb_error_mod
subroutine psb_serror()
end subroutine psb_serror
subroutine psb_perror(ictxt,abrt)
import :: psb_mpk_
integer(psb_mpk_), intent(in) :: ictxt
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
end subroutine psb_perror
end interface
@ -91,8 +91,8 @@ module psb_error_mod
interface psb_error_print_stack
subroutine psb_par_error_print_stack(ictxt)
import :: psb_ipk_,psb_mpk_
integer(psb_mpk_), intent(in) :: ictxt
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: ictxt
end subroutine psb_par_error_print_stack
subroutine psb_ser_error_print_stack()
end subroutine psb_ser_error_print_stack
@ -100,8 +100,8 @@ module psb_error_mod
interface psb_errcomm
subroutine psb_errcomm(ictxt, err)
import :: psb_mpk_, psb_ipk_
integer(psb_mpk_), intent(in) :: ictxt
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_ipk_), intent(inout):: err
end subroutine psb_errcomm
end interface psb_errcomm
@ -114,15 +114,6 @@ module psb_error_mod
module procedure psb_errmsg, psb_ach_errmsg
end interface
#if defined(LONG_INTEGERS)
interface psb_error
module procedure psb_perror_ipk
end interface psb_error
interface psb_errcomm
module procedure psb_errcomm_ipk
end interface psb_errcomm
#endif
private
@ -133,7 +124,7 @@ module psb_error_mod
! the name of the routine generating the error
character(len=20) :: routine=''
! array of integer data to complete the error msg
integer(psb_ipk_),dimension(5) :: i_err_data=0
integer(psb_epk_),dimension(5) :: e_err_data=0
! real(psb_dpk_)(dim=10) :: r_err_data=0.d0
! array of real data to complete the error msg
! complex(dim=10) :: c_err_data=0.c0
@ -352,22 +343,37 @@ contains
end function psb_errstatus_ok
! pushes an error on the error stack
subroutine psb_stackpush(err_c, r_name, i_err, a_err)
subroutine psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err)
integer(psb_ipk_), intent(in) :: err_c
character(len=*), intent(in) :: r_name
character(len=*), optional :: a_err
integer(psb_ipk_), optional :: i_err(5)
integer(psb_ipk_), optional :: i_err(:)
integer(psb_lpk_), optional :: l_err(:)
integer(psb_mpk_), optional :: m_err(:)
integer(psb_epk_), optional :: e_err(:)
type(psb_errstack_node), pointer :: new_node
integer :: isz
allocate(new_node)
new_node%err_code = err_c
new_node%routine = r_name
if (present(m_err)) then
isz = min(size(new_node%e_err_data),size(m_err))
new_node%e_err_data(1:isz) = m_err(1:isz)
end if
if (present(e_err)) then
isz = min(size(new_node%e_err_data),size(e_err))
new_node%e_err_data(1:isz) = e_err(1:isz)
end if
if (present(i_err)) then
new_node%i_err_data = i_err
isz = min(size(new_node%e_err_data),size(i_err))
new_node%e_err_data(1:isz) = i_err(1:isz)
end if
if (present(l_err)) then
isz = min(size(new_node%e_err_data),size(l_err))
new_node%e_err_data(1:isz) = l_err(1:isz)
end if
if(present(a_err)) then
new_node%a_err_data = a_err
@ -380,34 +386,40 @@ contains
end subroutine psb_stackpush
! pushes an error on the error stack
subroutine psb_errpush(err_c, r_name, i_err, a_err)
subroutine psb_errpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err)
integer(psb_ipk_), intent(in) :: err_c
character(len=*), intent(in) :: r_name
character(len=*), optional :: a_err
integer(psb_ipk_), optional :: i_err(5)
integer(psb_ipk_), optional :: i_err(:)
integer(psb_lpk_), optional :: l_err(:)
integer(psb_mpk_), optional :: m_err(:)
integer(psb_epk_), optional :: e_err(:)
type(psb_errstack_node), pointer :: new_node
call psb_set_errstatus(psb_err_fatal_)
call psb_stackpush(err_c, r_name, i_err, a_err)
call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err)
end subroutine psb_errpush
! pushes a warning on the error stack
subroutine psb_warning_push(err_c, r_name, i_err, a_err)
subroutine psb_warning_push(err_c, r_name, a_err, i_err, l_err, m_err, e_err)
integer(psb_ipk_), intent(in) :: err_c
character(len=*), intent(in) :: r_name
character(len=*), optional :: a_err
integer(psb_ipk_), optional :: i_err(5)
integer(psb_ipk_), optional :: i_err(:)
integer(psb_lpk_), optional :: l_err(:)
integer(psb_mpk_), optional :: m_err(:)
integer(psb_epk_), optional :: e_err(:)
type(psb_errstack_node), pointer :: new_node
if (.not.psb_errstatus_fatal())&
& call psb_set_errstatus( psb_err_warning_)
call psb_stackpush(err_c, r_name, i_err, a_err)
call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err)
end subroutine psb_warning_push
@ -417,16 +429,16 @@ contains
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_epk_) :: e_e_d(5)
type(psb_errstack_node), pointer :: old_node
if (error_stack%n_elems > 0) then
err_c = error_stack%top%err_code
r_name = error_stack%top%routine
i_e_d = error_stack%top%i_err_data
e_e_d = error_stack%top%e_err_data
a_e_d = error_stack%top%a_err_data
call psb_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d)
old_node => error_stack%top
error_stack%top => old_node%next
error_stack%n_elems = error_stack%n_elems - 1
@ -438,19 +450,19 @@ contains
end subroutine psb_ach_errpop
! pops an error from the error stack
subroutine psb_errpop(err_c, r_name, i_e_d, a_e_d)
subroutine psb_errpop(err_c, r_name, e_e_d, a_e_d)
integer(psb_ipk_), intent(out) :: err_c
character(len=20), intent(out) :: r_name
character(len=40), intent(out) :: a_e_d
integer(psb_ipk_), intent(out) :: i_e_d(5)
integer(psb_epk_), intent(out) :: e_e_d(5)
type(psb_errstack_node), pointer :: old_node
if (error_stack%n_elems > 0) then
err_c = error_stack%top%err_code
r_name = error_stack%top%routine
i_e_d = error_stack%top%i_err_data
e_e_d = error_stack%top%e_err_data
a_e_d = error_stack%top%a_err_data
old_node => error_stack%top
@ -469,23 +481,23 @@ contains
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_epk_) :: e_e_d(5)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
end do
end subroutine psb_clean_errstack
! prints the error msg associated to a specific error code
subroutine psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me)
subroutine psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me)
character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:)
integer(psb_ipk_), intent(in) :: err_c
character(len=20), intent(in) :: r_name
character(len=40), intent(in) :: a_e_d
integer(psb_ipk_), intent(in) :: i_e_d(5)
integer(psb_epk_), intent(in) :: e_e_d(5)
integer(psb_mpk_), optional :: me
character(len=psb_max_errmsg_len_) :: tmpmsg
@ -511,12 +523,12 @@ contains
case(psb_err_pivot_too_small_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d)
write(achmsg(2),'("pivot too small: ",i0,1x,a)')e_e_d(1),trim(a_e_d)
case(psb_err_invalid_ovr_num_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid number of ovr:",i0)')i_e_d(1)
write(achmsg(2),'("Invalid number of ovr:",i0)')e_e_d(1)
case(psb_err_invalid_input_)
allocate(achmsg(2))
@ -526,37 +538,37 @@ contains
case(psb_err_iarg_neg_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')e_e_d(1)
write(achmsg(3),'("current value is ",i0)')e_e_d(2)
case(psb_err_iarg_pos_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')e_e_d(1)
write(achmsg(3),'("current value is ",i0)')e_e_d(2)
case(psb_err_input_value_invalid_i_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1)
write(achmsg(3),'("current value is ",i0)')e_e_d(2)
case(psb_err_input_asize_invalid_i_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')e_e_d(1)
write(achmsg(3),'("Current value is ",i0)')e_e_d(2)
case(psb_err_input_asize_small_i_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')i_e_d(1)
write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3)
write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')e_e_d(1)
write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') e_e_d(2),e_e_d(3)
case(psb_err_iarg_invalid_i_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1)
write(achmsg(3),'("current value is ",a)')a_e_d(2:2)
case(psb_err_iarg_not_gtia_ii_)
@ -564,37 +576,37 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') &
& i_e_d(1), i_e_d(3)
& e_e_d(1), e_e_d(3)
write(achmsg(3),'("current values are ",i0," < ",i0)')&
& i_e_d(2),i_e_d(5)
& e_e_d(2),e_e_d(5)
case(psb_err_iarg_not_gteia_ii_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," must be greater than or equal to ",i0)')&
& i_e_d(1),i_e_d(2)
& e_e_d(1),e_e_d(2)
write(achmsg(3),'("current value is ",i0," < ",i0)')&
& i_e_d(3), i_e_d(2)
& e_e_d(3), e_e_d(2)
case(psb_err_iarg_invalid_value_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," in entry # ",i0," has an invalid value")')&
& i_e_d(1:2)
& e_e_d(1:2)
write(achmsg(3),'("current value is ",a)')trim(a_e_d)
case(psb_err_asb_nrc_error_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Impossible error in ASB: nrow>ncol,")')
write(achmsg(3),'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
write(achmsg(3),'("Actual values are ",i0," > ",i0)')e_e_d(1:2)
! ... csr format error ...
case(psb_err_iarg2_neg_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument ia2(1) is less than 0")')
write(achmsg(3),'("current value is ",i0)')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')e_e_d(1)
! ... csr format error ...
case(psb_err_ia2_not_increasing_)
@ -612,7 +624,7 @@ contains
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("indices in ia1 array are not within problem dimension")')
write(achmsg(3),'("problem dimension is ",i0)')i_e_d(1)
write(achmsg(3),'("problem dimension is ",i0)')e_e_d(1)
case(psb_err_invalid_args_combination_)
allocate(achmsg(2))
@ -623,15 +635,15 @@ contains
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')&
& i_e_d(1)
write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
& e_e_d(1)
write(achmsg(3),'("Current value is ",i0)')e_e_d(2)
case(psb_err_iarg_n_mbgtian_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," must be greater than input argument n. ",i0)')&
& i_e_d(1:2)
write(achmsg(3),'("current values are ",i0," < ",i0)') i_e_d(3:4)
& e_e_d(1:2)
write(achmsg(3),'("current values are ",i0," < ",i0)') e_e_d(3:4)
case(psb_err_dupl_cd_vl)
allocate(achmsg(2))
@ -669,14 +681,14 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("indices in input array are not within problem dimension ",2(i0,2x))')&
&i_e_d(1:2)
&e_e_d(1:2)
case(psb_err_iarray_outside_process_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("indices in input array are not belonging to the calling process ",i0)')&
& i_e_d(1)
& e_e_d(1)
case(psb_err_forgot_geall_)
allocate(achmsg(2))
@ -702,26 +714,26 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') &
& i_e_d(1),i_e_d(4),i_e_d(3)
write(achmsg(3),'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
& e_e_d(1),e_e_d(4),e_e_d(3)
write(achmsg(3),'("Current values are ",i0," != ",i0)')e_e_d(2), e_e_d(5)
case(psb_err_mpi_error_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("MPI error:",i0)')i_e_d(1)
write(achmsg(2),'("MPI error:",i0)')e_e_d(1)
case(psb_err_parm_differs_among_procs_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1)
&'("Parameter n. ",i0," must be equal on all processes. ",i0)')e_e_d(1)
case(psb_err_entry_out_of_bounds_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')&
& i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2)
& e_e_d(1),e_e_d(3),e_e_d(4),e_e_d(2)
case(psb_err_inconsistent_index_lists_)
allocate(achmsg(2))
@ -733,31 +745,31 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns number of processes")')&
&i_e_d(1)
&e_e_d(1)
write(achmsg(3),&
& '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')&
&i_e_d(4)
write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
&e_e_d(4)
write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')e_e_d(2),e_e_d(3)
case(psb_err_partfunc_toofewprocs_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns number of processes")')&
&i_e_d(1)
&e_e_d(1)
write(achmsg(3),&
&'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')&
&i_e_d(3),i_e_d(2)
&e_e_d(3),e_e_d(2)
case(psb_err_partfunc_wrong_pid_)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')&
& i_e_d(1)
& e_e_d(1)
write(achmsg(3),&
& '("on global point ",i0,". Current value returned is : ",i0)')&
& i_e_d(3),i_e_d(2)
& e_e_d(3),e_e_d(2)
case(psb_err_no_optional_arg_)
allocate(achmsg(2))
@ -789,11 +801,11 @@ contains
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')&
& i_e_d(1)
& e_e_d(1)
case(psb_err_rectangular_mat_unsupported_)
write(achmsg(2),&
&'("This routine does not support rectangular matrices: ",i0, " /= ",i0)') &
& i_e_d(1), i_e_d(2)
& e_e_d(1), e_e_d(2)
case(psb_err_invalid_mat_state_)
allocate(achmsg(2))
@ -927,7 +939,7 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Decompostion type ",i0," not yet supported.")')&
& i_e_d(1)
& e_e_d(1)
case(3090)
allocate(achmsg(2))
@ -941,7 +953,7 @@ contains
& '("Error on index. Element has not been inserted")')
write(achmsg(3),&
& '("local index is: ",i0," and global index is:",i0)')&
& i_e_d(1:2)
& e_e_d(1:2)
case(psb_err_input_matrix_unassembled_)
allocate(achmsg(2))
@ -1000,37 +1012,37 @@ contains
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Error ",i0," from call to a subroutine ")')&
& i_e_d(1)
& e_e_d(1)
case(psb_err_from_subroutine_ai_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Error from call to subroutine ",a," ",i0)')&
& trim(a_e_d),i_e_d(1)
& trim(a_e_d),e_e_d(1)
case(psb_err_alloc_request_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Error on allocation request for ",i0," items of type ",a)')&
& i_e_d(1),trim(a_e_d)
& e_e_d(1),trim(a_e_d)
case(4110)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Error ",i0," from call to an external package in subroutine ",a)')&
&i_e_d(1),trim(a_e_d)
&e_e_d(1),trim(a_e_d)
case(psb_err_invalid_istop_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid ISTOP: ",i0)')i_e_d(1)
write(achmsg(2),'("Invalid ISTOP: ",i0)')e_e_d(1)
case(5002)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid PREC: ",i0)')i_e_d(1)
write(achmsg(2),'("Invalid PREC: ",i0)')e_e_d(1)
case(5003)
allocate(achmsg(2))
@ -1042,7 +1054,7 @@ contains
achmsg(1) = tmpmsg
write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')&
& err_c,trim(r_name)
write(achmsg(3),'(5(i0,2x))') i_e_d
write(achmsg(3),'(5(i0,2x))') e_e_d
write(achmsg(4),'(a)') trim(a_e_d)
end select
@ -1051,18 +1063,18 @@ contains
! prints the error msg associated to a specific error code
subroutine psb_errmsg(iunit, err_c, r_name, i_e_d, a_e_d,me)
subroutine psb_errmsg(iunit, err_c, r_name, e_e_d, a_e_d,me)
integer(psb_ipk_), intent(in) :: iunit
integer(psb_ipk_), intent(in) :: err_c
character(len=20), intent(in) :: r_name
character(len=40), intent(in) :: a_e_d
integer(psb_ipk_), intent(in) :: i_e_d(5)
integer(psb_epk_), intent(in) :: e_e_d(5)
integer(psb_mpk_), optional :: me
integer(psb_ipk_) :: i
character(len=psb_max_errmsg_len_), allocatable :: achmsg(:)
call psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me)
call psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me)
do i=1,size(achmsg)
write(iunit,'(a)') trim(achmsg(i))

92
base/serial/impl/psb_c_base_mat_impl.F90
Unescape Escape View File

@ -51,7 +51,6 @@ subroutine psb_c_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -76,7 +75,6 @@ subroutine psb_c_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -102,7 +100,6 @@ subroutine psb_c_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -145,7 +142,6 @@ subroutine psb_c_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -191,7 +187,6 @@ subroutine psb_c_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -229,7 +224,6 @@ subroutine psb_c_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -267,7 +261,6 @@ subroutine psb_c_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -298,7 +291,6 @@ subroutine psb_c_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_c_coo_sparse_mat) :: tmp
@ -345,7 +337,6 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -373,7 +364,6 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -424,7 +414,6 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -463,7 +452,6 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
integer(psb_ipk_) :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -555,7 +543,6 @@ subroutine psb_c_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -649,7 +636,6 @@ subroutine psb_c_base_tril(a,l,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
complex(psb_spk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='tril'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -800,7 +786,6 @@ subroutine psb_c_base_triu(a,u,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
complex(psb_spk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='triu'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -999,7 +984,6 @@ subroutine psb_c_base_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='base_mold'
logical, parameter :: debug=.false.
@ -1024,7 +1008,6 @@ subroutine psb_c_base_transp_2mat(a,b)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transp'
call psb_erractionsave(err_act)
@ -1039,8 +1022,7 @@ subroutine psb_c_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1062,7 +1044,6 @@ subroutine psb_c_base_transc_2mat(a,b)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transc'
call psb_erractionsave(err_act)
@ -1077,8 +1058,7 @@ subroutine psb_c_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1099,7 +1079,6 @@ subroutine psb_c_base_transp_1mat(a)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transp'
call psb_erractionsave(err_act)
@ -1131,7 +1110,6 @@ subroutine psb_c_base_transc_1mat(a)
type(psb_c_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='c_base_transc'
call psb_erractionsave(err_act)
@ -1181,7 +1159,6 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@ -1208,7 +1185,6 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmv'
logical, parameter :: debug=.false.
@ -1236,7 +1212,6 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_cssm'
logical, parameter :: debug=.false.
@ -1263,7 +1238,6 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_cssv'
logical, parameter :: debug=.false.
@ -1294,7 +1268,6 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_spk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -1311,14 +1284,12 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1338,8 +1309,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1362,8 +1332,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1387,8 +1356,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1402,16 +1370,13 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_base_cssm
@ -1430,7 +1395,6 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_spk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -1447,14 +1411,12 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1474,8 +1436,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1493,8 +1454,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1518,8 +1478,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1579,7 +1538,6 @@ subroutine psb_c_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_scals'
logical, parameter :: debug=.false.
@ -1606,7 +1564,6 @@ subroutine psb_c_base_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_scal'
logical, parameter :: debug=.false.
@ -1633,7 +1590,6 @@ function psb_c_base_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1661,7 +1617,6 @@ function psb_c_base_csnmi(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
real(psb_spk_), allocatable :: vt(:)
@ -1700,7 +1655,6 @@ function psb_c_base_csnm1(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
real(psb_spk_), allocatable :: vt(:)
@ -1736,7 +1690,6 @@ subroutine psb_c_base_rowsum(d,a)
complex(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1759,7 +1712,6 @@ subroutine psb_c_base_arwsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1782,7 +1734,6 @@ subroutine psb_c_base_colsum(d,a)
complex(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1805,7 +1756,6 @@ subroutine psb_c_base_aclsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1832,7 +1782,6 @@ subroutine psb_c_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1900,7 +1849,6 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_c_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
@ -1917,14 +1865,12 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (x%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (y%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1947,8 +1893,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
allocate(tmpv, mold=y,stat=info)
@ -1966,8 +1911,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1993,8 +1937,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -2033,7 +1976,6 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_inner_vect_sv'
logical, parameter :: debug=.false.

104
base/serial/impl/psb_c_coo_impl.f90
Unescape Escape View File

@ -40,7 +40,6 @@ subroutine psb_c_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -51,8 +50,7 @@ subroutine psb_c_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -89,7 +87,6 @@ subroutine psb_c_coo_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
character :: side_
logical :: left
@ -114,8 +111,7 @@ subroutine psb_c_coo_scal(d,a,info,side)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -127,8 +123,7 @@ subroutine psb_c_coo_scal(d,a,info,side)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -159,7 +154,6 @@ subroutine psb_c_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -194,7 +188,6 @@ subroutine psb_c_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -227,7 +220,6 @@ subroutine psb_c_coo_mold(a,b,info)
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false.
@ -262,7 +254,6 @@ subroutine psb_c_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -309,7 +300,6 @@ subroutine psb_c_coo_trim(a)
implicit none
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -366,7 +356,6 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
class(psb_c_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -374,14 +363,12 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/ione,izero/))
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/))
goto 9999
endif
if (present(nz)) then
@ -391,8 +378,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/))
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -434,7 +420,6 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_print'
logical, parameter :: debug=.false.
@ -563,7 +548,6 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@ -593,14 +577,12 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -919,7 +901,6 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -943,14 +924,12 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1263,7 +1242,6 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1297,16 +1275,15 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
nnz = a%get_nzeros()
if (alpha == czero) then
@ -1458,7 +1435,6 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1494,14 +1470,12 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -1655,7 +1629,6 @@ function psb_c_coo_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_maxval'
logical, parameter :: debug=.false.
@ -1686,7 +1659,6 @@ function psb_c_coo_csnmi(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra, is_unit
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csnmi'
logical, parameter :: debug=.false.
@ -1748,7 +1720,6 @@ function psb_c_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csnm1'
logical, parameter :: debug=.false.
@ -1787,7 +1758,6 @@ subroutine psb_c_coo_rowsum(d,a)
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1795,10 +1765,10 @@ subroutine psb_c_coo_rowsum(d,a)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1836,7 +1806,6 @@ subroutine psb_c_coo_arwsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1846,8 +1815,7 @@ subroutine psb_c_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1884,7 +1852,6 @@ subroutine psb_c_coo_colsum(d,a)
complex(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1894,8 +1861,7 @@ subroutine psb_c_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
@ -1933,7 +1899,6 @@ subroutine psb_c_coo_aclsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1943,11 +1908,11 @@ subroutine psb_c_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
if (a%is_unit()) then
d = sone
else
@ -2007,7 +1972,6 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2282,7 +2246,6 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2557,7 +2520,6 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@ -2570,27 +2532,23 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz < 0) then
info = psb_err_iarg_neg_
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_/))
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_/))
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/4_psb_ipk_/))
goto 9999
end if
@ -2932,7 +2890,6 @@ subroutine psb_c_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2975,7 +2932,6 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3022,7 +2978,6 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3055,7 +3010,6 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3090,7 +3044,6 @@ subroutine psb_c_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3133,7 +3086,6 @@ subroutine psb_c_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3178,7 +3130,6 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3211,7 +3162,6 @@ subroutine psb_c_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3246,7 +3196,6 @@ subroutine psb_c_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3277,7 +3226,6 @@ subroutine psb_c_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3314,7 +3262,6 @@ subroutine psb_c_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3379,7 +3326,6 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
logical :: srt_inp, use_buffers

92
base/serial/impl/psb_d_base_mat_impl.F90
Unescape Escape View File

@ -51,7 +51,6 @@ subroutine psb_d_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -76,7 +75,6 @@ subroutine psb_d_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -102,7 +100,6 @@ subroutine psb_d_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -145,7 +142,6 @@ subroutine psb_d_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -191,7 +187,6 @@ subroutine psb_d_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -229,7 +224,6 @@ subroutine psb_d_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -267,7 +261,6 @@ subroutine psb_d_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -298,7 +291,6 @@ subroutine psb_d_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_d_coo_sparse_mat) :: tmp
@ -345,7 +337,6 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -373,7 +364,6 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -424,7 +414,6 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -463,7 +452,6 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
integer(psb_ipk_) :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -555,7 +543,6 @@ subroutine psb_d_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -649,7 +636,6 @@ subroutine psb_d_base_tril(a,l,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
real(psb_dpk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='tril'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -800,7 +786,6 @@ subroutine psb_d_base_triu(a,u,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
real(psb_dpk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='triu'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -999,7 +984,6 @@ subroutine psb_d_base_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='base_mold'
logical, parameter :: debug=.false.
@ -1024,7 +1008,6 @@ subroutine psb_d_base_transp_2mat(a,b)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transp'
call psb_erractionsave(err_act)
@ -1039,8 +1022,7 @@ subroutine psb_d_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1062,7 +1044,6 @@ subroutine psb_d_base_transc_2mat(a,b)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transc'
call psb_erractionsave(err_act)
@ -1077,8 +1058,7 @@ subroutine psb_d_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1099,7 +1079,6 @@ subroutine psb_d_base_transp_1mat(a)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transp'
call psb_erractionsave(err_act)
@ -1131,7 +1110,6 @@ subroutine psb_d_base_transc_1mat(a)
type(psb_d_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='d_base_transc'
call psb_erractionsave(err_act)
@ -1181,7 +1159,6 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@ -1208,7 +1185,6 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmv'
logical, parameter :: debug=.false.
@ -1236,7 +1212,6 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_cssm'
logical, parameter :: debug=.false.
@ -1263,7 +1238,6 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_cssv'
logical, parameter :: debug=.false.
@ -1294,7 +1268,6 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_dpk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -1311,14 +1284,12 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1338,8 +1309,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1362,8 +1332,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1387,8 +1356,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1402,16 +1370,13 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_base_cssm
@ -1430,7 +1395,6 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_dpk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -1447,14 +1411,12 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1474,8 +1436,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1493,8 +1454,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1518,8 +1478,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1579,7 +1538,6 @@ subroutine psb_d_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_scals'
logical, parameter :: debug=.false.
@ -1606,7 +1564,6 @@ subroutine psb_d_base_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_scal'
logical, parameter :: debug=.false.
@ -1633,7 +1590,6 @@ function psb_d_base_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1661,7 +1617,6 @@ function psb_d_base_csnmi(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
real(psb_dpk_), allocatable :: vt(:)
@ -1700,7 +1655,6 @@ function psb_d_base_csnm1(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
real(psb_dpk_), allocatable :: vt(:)
@ -1736,7 +1690,6 @@ subroutine psb_d_base_rowsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1759,7 +1712,6 @@ subroutine psb_d_base_arwsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1782,7 +1734,6 @@ subroutine psb_d_base_colsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1805,7 +1756,6 @@ subroutine psb_d_base_aclsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1832,7 +1782,6 @@ subroutine psb_d_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1900,7 +1849,6 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_d_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_cssm'
logical, parameter :: debug=.false.
@ -1917,14 +1865,12 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (x%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (y%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1947,8 +1893,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
allocate(tmpv, mold=y,stat=info)
@ -1966,8 +1911,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1993,8 +1937,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -2033,7 +1976,6 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_inner_vect_sv'
logical, parameter :: debug=.false.

104
base/serial/impl/psb_d_coo_impl.f90
Unescape Escape View File

@ -40,7 +40,6 @@ subroutine psb_d_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -51,8 +50,7 @@ subroutine psb_d_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -89,7 +87,6 @@ subroutine psb_d_coo_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
character :: side_
logical :: left
@ -114,8 +111,7 @@ subroutine psb_d_coo_scal(d,a,info,side)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -127,8 +123,7 @@ subroutine psb_d_coo_scal(d,a,info,side)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -159,7 +154,6 @@ subroutine psb_d_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -194,7 +188,6 @@ subroutine psb_d_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -227,7 +220,6 @@ subroutine psb_d_coo_mold(a,b,info)
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false.
@ -262,7 +254,6 @@ subroutine psb_d_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -309,7 +300,6 @@ subroutine psb_d_coo_trim(a)
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -366,7 +356,6 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
class(psb_d_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -374,14 +363,12 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/ione,izero/))
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/))
goto 9999
endif
if (present(nz)) then
@ -391,8 +378,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/))
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -434,7 +420,6 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_print'
logical, parameter :: debug=.false.
@ -563,7 +548,6 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@ -593,14 +577,12 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -919,7 +901,6 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -943,14 +924,12 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1263,7 +1242,6 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
real(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1297,16 +1275,15 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
nnz = a%get_nzeros()
if (alpha == dzero) then
@ -1458,7 +1435,6 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1494,14 +1470,12 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -1655,7 +1629,6 @@ function psb_d_coo_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_maxval'
logical, parameter :: debug=.false.
@ -1686,7 +1659,6 @@ function psb_d_coo_csnmi(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra, is_unit
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csnmi'
logical, parameter :: debug=.false.
@ -1748,7 +1720,6 @@ function psb_d_coo_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csnm1'
logical, parameter :: debug=.false.
@ -1787,7 +1758,6 @@ subroutine psb_d_coo_rowsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1795,10 +1765,10 @@ subroutine psb_d_coo_rowsum(d,a)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1836,7 +1806,6 @@ subroutine psb_d_coo_arwsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1846,8 +1815,7 @@ subroutine psb_d_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1884,7 +1852,6 @@ subroutine psb_d_coo_colsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1894,8 +1861,7 @@ subroutine psb_d_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
@ -1933,7 +1899,6 @@ subroutine psb_d_coo_aclsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1943,11 +1908,11 @@ subroutine psb_d_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
if (a%is_unit()) then
d = done
else
@ -2007,7 +1972,6 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2282,7 +2246,6 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2557,7 +2520,6 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@ -2570,27 +2532,23 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz < 0) then
info = psb_err_iarg_neg_
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_/))
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_/))
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/4_psb_ipk_/))
goto 9999
end if
@ -2932,7 +2890,6 @@ subroutine psb_d_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2975,7 +2932,6 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3022,7 +2978,6 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3055,7 +3010,6 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3090,7 +3044,6 @@ subroutine psb_d_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3133,7 +3086,6 @@ subroutine psb_d_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3178,7 +3130,6 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3211,7 +3162,6 @@ subroutine psb_d_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3246,7 +3196,6 @@ subroutine psb_d_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3277,7 +3226,6 @@ subroutine psb_d_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3314,7 +3262,6 @@ subroutine psb_d_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3379,7 +3326,6 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
logical :: srt_inp, use_buffers

92
base/serial/impl/psb_s_base_mat_impl.F90
Unescape Escape View File

@ -51,7 +51,6 @@ subroutine psb_s_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -76,7 +75,6 @@ subroutine psb_s_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -102,7 +100,6 @@ subroutine psb_s_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -145,7 +142,6 @@ subroutine psb_s_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -191,7 +187,6 @@ subroutine psb_s_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -229,7 +224,6 @@ subroutine psb_s_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -267,7 +261,6 @@ subroutine psb_s_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -298,7 +291,6 @@ subroutine psb_s_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_s_coo_sparse_mat) :: tmp
@ -345,7 +337,6 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -373,7 +364,6 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -424,7 +414,6 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -463,7 +452,6 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
integer(psb_ipk_) :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -555,7 +543,6 @@ subroutine psb_s_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -649,7 +636,6 @@ subroutine psb_s_base_tril(a,l,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
real(psb_spk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='tril'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -800,7 +786,6 @@ subroutine psb_s_base_triu(a,u,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
real(psb_spk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='triu'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -999,7 +984,6 @@ subroutine psb_s_base_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='base_mold'
logical, parameter :: debug=.false.
@ -1024,7 +1008,6 @@ subroutine psb_s_base_transp_2mat(a,b)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transp'
call psb_erractionsave(err_act)
@ -1039,8 +1022,7 @@ subroutine psb_s_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1062,7 +1044,6 @@ subroutine psb_s_base_transc_2mat(a,b)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transc'
call psb_erractionsave(err_act)
@ -1077,8 +1058,7 @@ subroutine psb_s_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1099,7 +1079,6 @@ subroutine psb_s_base_transp_1mat(a)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transp'
call psb_erractionsave(err_act)
@ -1131,7 +1110,6 @@ subroutine psb_s_base_transc_1mat(a)
type(psb_s_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='s_base_transc'
call psb_erractionsave(err_act)
@ -1181,7 +1159,6 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@ -1208,7 +1185,6 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmv'
logical, parameter :: debug=.false.
@ -1236,7 +1212,6 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_cssm'
logical, parameter :: debug=.false.
@ -1263,7 +1238,6 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_cssv'
logical, parameter :: debug=.false.
@ -1294,7 +1268,6 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_spk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -1311,14 +1284,12 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1338,8 +1309,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1362,8 +1332,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1387,8 +1356,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1402,16 +1370,13 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_base_cssm
@ -1430,7 +1395,6 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
real(psb_spk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -1447,14 +1411,12 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1474,8 +1436,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1493,8 +1454,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1518,8 +1478,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1579,7 +1538,6 @@ subroutine psb_s_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_scals'
logical, parameter :: debug=.false.
@ -1606,7 +1564,6 @@ subroutine psb_s_base_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_scal'
logical, parameter :: debug=.false.
@ -1633,7 +1590,6 @@ function psb_s_base_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1661,7 +1617,6 @@ function psb_s_base_csnmi(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
real(psb_spk_), allocatable :: vt(:)
@ -1700,7 +1655,6 @@ function psb_s_base_csnm1(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
real(psb_spk_), allocatable :: vt(:)
@ -1736,7 +1690,6 @@ subroutine psb_s_base_rowsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1759,7 +1712,6 @@ subroutine psb_s_base_arwsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1782,7 +1734,6 @@ subroutine psb_s_base_colsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1805,7 +1756,6 @@ subroutine psb_s_base_aclsum(d,a)
real(psb_spk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1832,7 +1782,6 @@ subroutine psb_s_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1900,7 +1849,6 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_s_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_cssm'
logical, parameter :: debug=.false.
@ -1917,14 +1865,12 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (x%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (y%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1947,8 +1893,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
allocate(tmpv, mold=y,stat=info)
@ -1966,8 +1911,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1993,8 +1937,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -2033,7 +1976,6 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_inner_vect_sv'
logical, parameter :: debug=.false.

104
base/serial/impl/psb_s_coo_impl.f90
Unescape Escape View File

@ -40,7 +40,6 @@ subroutine psb_s_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -51,8 +50,7 @@ subroutine psb_s_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -89,7 +87,6 @@ subroutine psb_s_coo_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
character :: side_
logical :: left
@ -114,8 +111,7 @@ subroutine psb_s_coo_scal(d,a,info,side)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -127,8 +123,7 @@ subroutine psb_s_coo_scal(d,a,info,side)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -159,7 +154,6 @@ subroutine psb_s_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -194,7 +188,6 @@ subroutine psb_s_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -227,7 +220,6 @@ subroutine psb_s_coo_mold(a,b,info)
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false.
@ -262,7 +254,6 @@ subroutine psb_s_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -309,7 +300,6 @@ subroutine psb_s_coo_trim(a)
implicit none
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -366,7 +356,6 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
class(psb_s_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -374,14 +363,12 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/ione,izero/))
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/))
goto 9999
endif
if (present(nz)) then
@ -391,8 +378,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/))
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -434,7 +420,6 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_print'
logical, parameter :: debug=.false.
@ -563,7 +548,6 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@ -593,14 +577,12 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -919,7 +901,6 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -943,14 +924,12 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1263,7 +1242,6 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
real(psb_spk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1297,16 +1275,15 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
nnz = a%get_nzeros()
if (alpha == szero) then
@ -1458,7 +1435,6 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1494,14 +1470,12 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -1655,7 +1629,6 @@ function psb_s_coo_maxval(a) result(res)
real(psb_spk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_maxval'
logical, parameter :: debug=.false.
@ -1686,7 +1659,6 @@ function psb_s_coo_csnmi(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra, is_unit
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csnmi'
logical, parameter :: debug=.false.
@ -1748,7 +1720,6 @@ function psb_s_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csnm1'
logical, parameter :: debug=.false.
@ -1787,7 +1758,6 @@ subroutine psb_s_coo_rowsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1795,10 +1765,10 @@ subroutine psb_s_coo_rowsum(d,a)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1836,7 +1806,6 @@ subroutine psb_s_coo_arwsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1846,8 +1815,7 @@ subroutine psb_s_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1884,7 +1852,6 @@ subroutine psb_s_coo_colsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1894,8 +1861,7 @@ subroutine psb_s_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
@ -1933,7 +1899,6 @@ subroutine psb_s_coo_aclsum(d,a)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1943,11 +1908,11 @@ subroutine psb_s_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
if (a%is_unit()) then
d = sone
else
@ -2007,7 +1972,6 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2282,7 +2246,6 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2557,7 +2520,6 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@ -2570,27 +2532,23 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz < 0) then
info = psb_err_iarg_neg_
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_/))
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_/))
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/4_psb_ipk_/))
goto 9999
end if
@ -2932,7 +2890,6 @@ subroutine psb_s_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2975,7 +2932,6 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3022,7 +2978,6 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3055,7 +3010,6 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3090,7 +3044,6 @@ subroutine psb_s_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3133,7 +3086,6 @@ subroutine psb_s_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3178,7 +3130,6 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3211,7 +3162,6 @@ subroutine psb_s_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3246,7 +3196,6 @@ subroutine psb_s_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3277,7 +3226,6 @@ subroutine psb_s_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3314,7 +3262,6 @@ subroutine psb_s_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3379,7 +3326,6 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
logical :: srt_inp, use_buffers

92
base/serial/impl/psb_z_base_mat_impl.F90
Unescape Escape View File

@ -51,7 +51,6 @@ subroutine psb_z_base_cp_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -76,7 +75,6 @@ subroutine psb_z_base_cp_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -102,7 +100,6 @@ subroutine psb_z_base_cp_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -145,7 +142,6 @@ subroutine psb_z_base_cp_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -191,7 +187,6 @@ subroutine psb_z_base_mv_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -229,7 +224,6 @@ subroutine psb_z_base_mv_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
@ -267,7 +261,6 @@ subroutine psb_z_base_mv_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -298,7 +291,6 @@ subroutine psb_z_base_mv_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
type(psb_z_coo_sparse_mat) :: tmp
@ -345,7 +337,6 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
@ -373,7 +364,6 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -424,7 +414,6 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -463,7 +452,6 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,&
integer(psb_ipk_), intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
integer(psb_ipk_) :: jmin_, jmax_
logical :: append_, rscale_, cscale_
@ -555,7 +543,6 @@ subroutine psb_z_base_csclip(a,b,info,&
logical, intent(in), optional :: rscale,cscale
integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -649,7 +636,6 @@ subroutine psb_z_base_tril(a,l,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
complex(psb_dpk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='tril'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -800,7 +786,6 @@ subroutine psb_z_base_triu(a,u,info,&
integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz
integer(psb_ipk_), allocatable :: ia(:), ja(:)
complex(psb_dpk_), allocatable :: val(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='triu'
logical :: rscale_, cscale_
logical, parameter :: debug=.false.
@ -999,7 +984,6 @@ subroutine psb_z_base_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='base_mold'
logical, parameter :: debug=.false.
@ -1024,7 +1008,6 @@ subroutine psb_z_base_transp_2mat(a,b)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transp'
call psb_erractionsave(err_act)
@ -1039,8 +1022,7 @@ subroutine psb_z_base_transp_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1)=ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1062,7 +1044,6 @@ subroutine psb_z_base_transc_2mat(a,b)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transc'
call psb_erractionsave(err_act)
@ -1077,8 +1058,7 @@ subroutine psb_z_base_transc_2mat(a,b)
info = psb_err_invalid_dynamic_type_
end select
if (info /= psb_success_) then
ierr(1) = ione;
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr)
call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/))
goto 9999
end if
call psb_erractionrestore(err_act)
@ -1099,7 +1079,6 @@ subroutine psb_z_base_transp_1mat(a)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transp'
call psb_erractionsave(err_act)
@ -1131,7 +1110,6 @@ subroutine psb_z_base_transc_1mat(a)
type(psb_z_coo_sparse_mat) :: tmp
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=*), parameter :: name='z_base_transc'
call psb_erractionsave(err_act)
@ -1181,7 +1159,6 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@ -1208,7 +1185,6 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmv'
logical, parameter :: debug=.false.
@ -1236,7 +1212,6 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_cssm'
logical, parameter :: debug=.false.
@ -1263,7 +1238,6 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_cssv'
logical, parameter :: debug=.false.
@ -1294,7 +1268,6 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_dpk_), allocatable :: tmp(:,:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -1311,14 +1284,12 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
nc = min(size(x,2), size(y,2))
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1338,8 +1309,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1362,8 +1332,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1387,8 +1356,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1402,16 +1370,13 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_base_cssm
@ -1430,7 +1395,6 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
complex(psb_dpk_), allocatable :: tmp(:)
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -1447,14 +1411,12 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (size(x,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (size(y,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1474,8 +1436,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (size(d,1) < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
@ -1493,8 +1454,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (size(d,1) < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1518,8 +1478,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -1579,7 +1538,6 @@ subroutine psb_z_base_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_scals'
logical, parameter :: debug=.false.
@ -1606,7 +1564,6 @@ subroutine psb_z_base_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_scal'
logical, parameter :: debug=.false.
@ -1633,7 +1590,6 @@ function psb_z_base_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='maxval'
logical, parameter :: debug=.false.
@ -1661,7 +1617,6 @@ function psb_z_base_csnmi(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnmi'
real(psb_dpk_), allocatable :: vt(:)
@ -1700,7 +1655,6 @@ function psb_z_base_csnm1(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csnm1'
real(psb_dpk_), allocatable :: vt(:)
@ -1736,7 +1690,6 @@ subroutine psb_z_base_rowsum(d,a)
complex(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1759,7 +1712,6 @@ subroutine psb_z_base_arwsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='arwsum'
logical, parameter :: debug=.false.
@ -1782,7 +1734,6 @@ subroutine psb_z_base_colsum(d,a)
complex(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1805,7 +1756,6 @@ subroutine psb_z_base_aclsum(d,a)
real(psb_dpk_), intent(out) :: d(:)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1832,7 +1782,6 @@ subroutine psb_z_base_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -1900,7 +1849,6 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
class(psb_z_base_vect_type), allocatable :: tmpv
integer(psb_ipk_) :: err_act, nar,nac,nc, i
character(len=1) :: scale_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
@ -1917,14 +1865,12 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
nc = 1
if (x%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/))
goto 9999
end if
if (y%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/))
goto 9999
end if
@ -1947,8 +1893,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
if (psb_toupper(scale_) == 'R') then
if (d%get_nrows() < nac) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nac;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/))
goto 9999
end if
allocate(tmpv, mold=y,stat=info)
@ -1966,8 +1911,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else if (psb_toupper(scale_) == 'L') then
if (d%get_nrows() < nar) then
info = psb_err_input_asize_small_i_
ierr(1) = 9; ierr(2) = nar;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/))
goto 9999
end if
@ -1993,8 +1937,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
else
info = 31
ierr(1) = 8; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr,a_err=scale_)
call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_)
goto 9999
end if
else
@ -2033,7 +1976,6 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
character, optional, intent(in) :: trans
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_inner_vect_sv'
logical, parameter :: debug=.false.

104
base/serial/impl/psb_z_coo_impl.f90
Unescape Escape View File

@ -40,7 +40,6 @@ subroutine psb_z_coo_get_diag(a,d,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
@ -51,8 +50,7 @@ subroutine psb_z_coo_get_diag(a,d,info)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -89,7 +87,6 @@ subroutine psb_z_coo_scal(d,a,info,side)
character, intent(in), optional :: side
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
character :: side_
logical :: left
@ -114,8 +111,7 @@ subroutine psb_z_coo_scal(d,a,info,side)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -127,8 +123,7 @@ subroutine psb_z_coo_scal(d,a,info,side)
m = a%get_ncols()
if (size(d) < m) then
info=psb_err_input_asize_invalid_i_
ierr(1) = 2; ierr(2) = size(d);
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/))
goto 9999
end if
@ -159,7 +154,6 @@ subroutine psb_z_coo_scals(d,a,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act,mnm, i, j, m
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
@ -194,7 +188,6 @@ subroutine psb_z_coo_reallocate_nz(nz,a)
integer(psb_ipk_), intent(in) :: nz
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_reallocate_nz'
logical, parameter :: debug=.false.
@ -227,7 +220,6 @@ subroutine psb_z_coo_mold(a,b,info)
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false.
@ -262,7 +254,6 @@ subroutine psb_z_coo_reinit(a,clear)
logical, intent(in), optional :: clear
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
@ -309,7 +300,6 @@ subroutine psb_z_coo_trim(a)
implicit none
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_) :: err_act, info, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
@ -366,7 +356,6 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
class(psb_z_coo_sparse_mat), intent(inout) :: a
integer(psb_ipk_), intent(in), optional :: nz
integer(psb_ipk_) :: err_act, info, nz_
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
@ -374,14 +363,12 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
info = psb_success_
if (m < 0) then
info = psb_err_iarg_neg_
ierr(1) = ione; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/ione,izero/))
goto 9999
endif
if (n < 0) then
info = psb_err_iarg_neg_
ierr(1) = 2; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/))
goto 9999
endif
if (present(nz)) then
@ -391,8 +378,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz)
end if
if (nz_ < 0) then
info = psb_err_iarg_neg_
ierr(1) = 3; ierr(2) = izero;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/))
goto 9999
endif
if (info == psb_success_) call psb_realloc(nz_,a%ia,info)
@ -434,7 +420,6 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc)
integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_print'
logical, parameter :: debug=.false.
@ -563,7 +548,6 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@ -593,14 +577,12 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -919,7 +901,6 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: tmp(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_cssv_impl'
logical, parameter :: debug=.false.
@ -943,14 +924,12 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
m = a%get_nrows()
if (size(x,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
if (.not. (a%is_triangle())) then
@ -1263,7 +1242,6 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_) :: acc
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csmv_impl'
logical, parameter :: debug=.false.
@ -1297,16 +1275,15 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
nnz = a%get_nzeros()
if (alpha == zzero) then
@ -1458,7 +1435,6 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
complex(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csmm_impl'
logical, parameter :: debug=.false.
@ -1494,14 +1470,12 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if (size(x,1) < n) then
info = psb_err_input_asize_small_i_
ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/))
goto 9999
end if
if (size(y,1) < m) then
info = psb_err_input_asize_small_i_
ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m;
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/))
goto 9999
end if
@ -1655,7 +1629,6 @@ function psb_z_coo_maxval(a) result(res)
real(psb_dpk_) :: res
integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_maxval'
logical, parameter :: debug=.false.
@ -1686,7 +1659,6 @@ function psb_z_coo_csnmi(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra, is_unit
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csnmi'
logical, parameter :: debug=.false.
@ -1748,7 +1720,6 @@ function psb_z_coo_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csnm1'
logical, parameter :: debug=.false.
@ -1787,7 +1758,6 @@ subroutine psb_z_coo_rowsum(d,a)
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1795,10 +1765,10 @@ subroutine psb_z_coo_rowsum(d,a)
if (a%is_dev()) call a%sync()
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1836,7 +1806,6 @@ subroutine psb_z_coo_arwsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='rowsum'
logical, parameter :: debug=.false.
@ -1846,8 +1815,7 @@ subroutine psb_z_coo_arwsum(d,a)
m = a%get_nrows()
if (size(d) < m) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = m
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/))
goto 9999
end if
@ -1884,7 +1852,6 @@ subroutine psb_z_coo_colsum(d,a)
complex(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='colsum'
logical, parameter :: debug=.false.
@ -1894,8 +1861,7 @@ subroutine psb_z_coo_colsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
@ -1933,7 +1899,6 @@ subroutine psb_z_coo_aclsum(d,a)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='aclsum'
logical, parameter :: debug=.false.
@ -1943,11 +1908,11 @@ subroutine psb_z_coo_aclsum(d,a)
n = a%get_ncols()
if (size(d) < n) then
info=psb_err_input_asize_small_i_
ierr(1) = 1; ierr(2) = size(d); ierr(3) = n
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/))
goto 9999
end if
if (a%is_unit()) then
d = done
else
@ -2007,7 +1972,6 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2282,7 +2246,6 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
logical :: append_, rscale_, cscale_
integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
@ -2557,7 +2520,6 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@ -2570,27 +2532,23 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
if (nz < 0) then
info = psb_err_iarg_neg_
ierr(1)=1
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/1_psb_ipk_/))
goto 9999
end if
if (size(ia) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=2
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/2_psb_ipk_/))
goto 9999
end if
if (size(ja) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=3
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/3_psb_ipk_/))
goto 9999
end if
if (size(val) < nz) then
info = psb_err_input_asize_invalid_i_
ierr(1)=4
call psb_errpush(info,name,i_err=ierr)
call psb_errpush(info,name,i_err=(/4_psb_ipk_/))
goto 9999
end if
@ -2932,7 +2890,6 @@ subroutine psb_z_cp_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nz
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -2975,7 +2932,6 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3022,7 +2978,6 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3055,7 +3010,6 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3090,7 +3044,6 @@ subroutine psb_z_mv_coo_to_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3133,7 +3086,6 @@ subroutine psb_z_mv_coo_from_coo(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3178,7 +3130,6 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
@ -3211,7 +3162,6 @@ subroutine psb_z_mv_coo_from_fmt(a,b,info)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: m,n,nz
@ -3246,7 +3196,6 @@ subroutine psb_z_coo_cp_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
@ -3277,7 +3226,6 @@ subroutine psb_z_coo_mv_from(a,b)
integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
@ -3314,7 +3262,6 @@ subroutine psb_z_fix_coo(a,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca
integer(psb_ipk_) :: i,j, irw, icl, err_act
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
info = psb_success_
@ -3379,7 +3326,6 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_
integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name = 'psb_fixcoo'
logical :: srt_inp, use_buffers

39
base/tools/psb_cdals.f90
Unescape Escape View File

@ -61,7 +61,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
integer(psb_ipk_) :: counter,i,j,loc_row,err,loc_col,&
& l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, nlx
integer(psb_lpk_) :: iglob
integer(psb_ipk_) :: int_err(5),exch(3)
integer(psb_ipk_) :: exch(3)
integer(psb_ipk_), allocatable :: temp_ovrlap(:)
integer(psb_lpk_), allocatable :: l_temp_ovrlap(:), loc_idx(:)
integer(psb_ipk_), allocatable :: prc_v(:)
@ -87,14 +87,12 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
if (m < 1) then
info = psb_err_iarg_neg_
err=info
int_err(1) = 1; int_err(2) = m;
call psb_errpush(err,name,int_err)
call psb_errpush(err,name,l_err=(/lone,m/))
goto 9999
else if (n < 1) then
info = psb_err_iarg_neg_
err=info
int_err(1) = 2 ; int_err(2) = n;
call psb_errpush(err,name,int_err)
call psb_errpush(err,name,l_err=(/lone*2,n/))
goto 9999
endif
@ -108,13 +106,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psb_bcast(ictxt,exch(1:3),root=psb_root_)
if (exch(1) /= m) then
err=550
int_err(1)=1
call psb_errpush(err,name,int_err)
call psb_errpush(err,name,m_err=(/1/))
goto 9999
else if (exch(2) /= n) then
err=550
int_err(1)=2
call psb_errpush(err,name,int_err)
call psb_errpush(err,name,m_err=(/2/))
goto 9999
endif
call psb_cd_set_large_threshold(exch(3))
@ -130,8 +126,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
err=info
int_err(1)=2*m+psb_mdata_size_+np
call psb_errpush(err,name,int_err,a_err='integer')
call psb_errpush(err,name,a_err='integer',l_err=(/2*m+psb_mdata_size_+np/))
goto 9999
endif
@ -168,8 +163,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
int_err(1)=loc_col
call psb_errpush(info,name,i_err=int_err,a_err='integer')
call psb_errpush(info,name,i_err=(/loc_col/),a_err='integer')
goto 9999
end if
@ -182,30 +176,17 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call parts(iglob,m,np,prc_v,nprocs)
if (nprocs > np) then
info=psb_err_partfunc_toomuchprocs_
int_err(1)=3
int_err(2)=np
int_err(3)=nprocs
int_err(4)=iglob
err=info
call psb_errpush(err,name,int_err)
call psb_errpush(info,name,l_err=(/3_psb_lpk_,np*lone,nprocs*lone,iglob/))
goto 9999
else if (nprocs <= 0) then
info=psb_err_partfunc_toofewprocs_
int_err(1)=3
int_err(2)=nprocs
int_err(3)=iglob
err=info
call psb_errpush(err,name,int_err)
call psb_errpush(info,name,l_err=(/3_psb_lpk_,nprocs*lone,iglob/))
goto 9999
else
do j=1,nprocs
if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then
info=psb_err_partfunc_wrong_pid_
int_err(1)=3
int_err(2)=prc_v(j)
int_err(3)=iglob
err=info
call psb_errpush(err,name,int_err)
call psb_errpush(info,name,l_err=(/3_psb_lpk_,prc_v(j)*lone,iglob/))
goto 9999
end if
end do

Write Preview
Loading…
Cancel
Save