fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 12:52:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fixed error handling on ALLOCATE.

Browse Source
This commit is contained in:
Salvatore Filippone
2007-05-28 09:04:08 +00:00
parent 3801148fde
commit 88f0e7ef53
15 changed files with 174 additions and 157 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_error_mod.F90
+2 -2
View File
@@ -409,8 +409,6 @@ contains
write (0,'("BLACS error. Number of processes=-1")')
case(2011)
write (0,'("Initialization error: not enough processes available in the parallel environment")')
case(2025)
write (0,'("Cannot allocate ",i0," bytes")')i_e_d(1)
case(2030)
write (0,'("BLACS ERROR: Number of grid columns must be equal to 1\nCurrent value is ",i4," != 1.")')i_e_d(1)
case(2231)
@@ -466,6 +464,8 @@ contains
write (0,'("Error ",i0," from call to a subroutine ")')i_e_d(1)
case(4013)
write (0,'("Error from call to subroutine ",a," ",i0)')a_e_d,i_e_d(1)
case(4025)
write (0,'("Error on allocation request for ",i0," items of type ")')i_e_d(1),a_e_d
case(4110)
write (0,'("Error ",i0," from call to an external package in subroutine ",a)')i_e_d(1),a_e_d
case (5001)
base/modules/psb_realloc_mod.F90
+65 -30
View File
@@ -622,8 +622,8 @@ Contains
lb_ = 1
endif
if ((len<0)) then
err=2025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/))
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer')
goto 9999
end if
ub_ = lb_+len-1
@@ -634,8 +634,8 @@ Contains
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@@ -645,8 +645,8 @@ Contains
dim = 0
allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer')
goto 9999
end if
endif
@@ -698,8 +698,8 @@ Contains
lb_ = 1
endif
if ((len<0)) then
err=2025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/))
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
ub_ = lb_ + len-1
@@ -710,8 +710,8 @@ Contains
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@@ -721,8 +721,8 @@ Contains
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
endif
@@ -771,8 +771,8 @@ Contains
lb_ = 1
endif
if ((len<0)) then
err=2025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/))
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
ub_ = lb_+len-1
@@ -783,8 +783,8 @@ Contains
If ((dim /= len).or.(lbi /= lb_)) Then
Allocate(tmp(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim))
@@ -794,8 +794,8 @@ Contains
dim = 0
Allocate(rrax(lb_:ub_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
endif
@@ -851,6 +851,18 @@ Contains
ub1_ = lb1_ + len1 -1
ub2_ = lb2_ + len2 -1
if (len1 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
if (allocated(rrax)) then
dim = size(rrax,1)
lbi1 = lbound(rrax,1)
@@ -860,8 +872,8 @@ Contains
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@@ -873,8 +885,8 @@ Contains
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
endif
@@ -931,6 +943,18 @@ Contains
ub1_ = lb1_ + len1 -1
ub2_ = lb2_ + len2 -1
if (len1 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
if (allocated(rrax)) then
dim = size(rrax,1)
lbi1 = lbound(rrax,1)
@@ -940,8 +964,8 @@ Contains
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@@ -953,8 +977,8 @@ Contains
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(kind(1.d0))')
goto 9999
end if
endif
@@ -1010,6 +1034,17 @@ Contains
ub1_ = lb1_ + len1 -1
ub2_ = lb2_ + len2 -1
if (len1 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len1,0,0,0,0/),a_err='integer')
goto 9999
end if
if (len2 < 0) then
err=4025
call psb_errpush(err,name,i_err=(/len2,0,0,0,0/),a_err='integer')
goto 9999
end if
if (allocated(rrax)) then
dim = size(rrax,1)
lbi1 = lbound(rrax,1)
@@ -1019,8 +1054,8 @@ Contains
& .or.(lbi2 /= lb2_)) Then
Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer')
goto 9999
end if
tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = &
@@ -1032,8 +1067,8 @@ Contains
dim2 = 0
Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
err=4025
call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer')
goto 9999
end if
endif