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

psblas3:

Browse Source 
util/psb_c_hbio_impl.f90
 util/psb_d_hbio_impl.f90
 util/psb_s_hbio_impl.f90
 util/psb_z_hbio_impl.f90

Fix error thrown by Cray FTN.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 6f542b538b
commit 26941924cc
4 changed files with 36 additions and 84 deletions
Show Stats Download Patch File Download Diff File

29
util/psb_c_hbio_impl.f90
Unescape Escape View File

@ -254,8 +254,7 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt11='(a3,11x,2i14)'
character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)'
type(psb_c_csc_sparse_mat), target :: acsc type(psb_c_csc_sparse_mat) :: acsc
type(psb_c_csc_sparse_mat), pointer :: acpnt
character(len=72) :: mtitle_ character(len=72) :: mtitle_
character(len=8) :: key_ character(len=8) :: key_
@ -297,23 +296,13 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
endif endif
select type(aa=>a%a) call acsc%cp_from_fmt(a%a, iret)
type is (psb_c_csc_sparse_mat) if (iret /= 0) return
acpnt => aa
class default nrow = acsc%get_nrows()
ncol = acsc%get_ncols()
call acsc%cp_from_fmt(aa, iret) nnzero = acsc%get_nzeros()
if (iret /= 0) return
acpnt => acsc
end select
nrow = acpnt%get_nrows()
ncol = acpnt%get_ncols()
nnzero = acpnt%get_nzeros()
neltvl = 0 neltvl = 0
@ -352,9 +341,9 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix
write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1)
write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero)
if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow)
if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow)
if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow)

30
util/psb_d_hbio_impl.f90
Unescape Escape View File

@ -207,8 +207,7 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt11='(a3,11x,2i14)'
character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)'
type(psb_d_csc_sparse_mat), target :: acsc type(psb_d_csc_sparse_mat) :: acsc
type(psb_d_csc_sparse_mat), pointer :: acpnt
character(len=72) :: mtitle_ character(len=72) :: mtitle_
character(len=8) :: key_ character(len=8) :: key_
@ -250,23 +249,13 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
endif endif
select type(aa=>a%a) call acsc%cp_from_fmt(a%a, iret)
type is (psb_d_csc_sparse_mat) if (iret /= 0) return
acpnt => aa
class default nrow = acsc%get_nrows()
ncol = acsc%get_ncols()
call acsc%cp_from_fmt(aa, iret) nnzero = acsc%get_nzeros()
if (iret /= 0) return
acpnt => acsc
end select
nrow = acpnt%get_nrows()
ncol = acpnt%get_ncols()
nnzero = acpnt%get_nzeros()
neltvl = 0 neltvl = 0
@ -305,9 +294,9 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix
write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1)
write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero)
if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow)
if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow)
if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow)
@ -325,4 +314,3 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write(psb_err_unit,*) 'Error while opening ',filename write(psb_err_unit,*) 'Error while opening ',filename
return return
end subroutine dhb_write end subroutine dhb_write

31
util/psb_s_hbio_impl.f90
Unescape Escape View File

@ -207,8 +207,7 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt11='(a3,11x,2i14)'
character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)'
type(psb_s_csc_sparse_mat), target :: acsc type(psb_s_csc_sparse_mat) :: acsc
type(psb_s_csc_sparse_mat), pointer :: acpnt
character(len=72) :: mtitle_ character(len=72) :: mtitle_
character(len=8) :: key_ character(len=8) :: key_
@ -250,23 +249,13 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
endif endif
select type(aa=>a%a) call acsc%cp_from_fmt(a%a, iret)
type is (psb_s_csc_sparse_mat) if (iret /= 0) return
acpnt => aa
class default nrow = acsc%get_nrows()
ncol = acsc%get_ncols()
call acsc%cp_from_fmt(aa, iret) nnzero = acsc%get_nzeros()
if (iret /= 0) return
acpnt => acsc
end select
nrow = acpnt%get_nrows()
ncol = acpnt%get_ncols()
nnzero = acpnt%get_nzeros()
neltvl = 0 neltvl = 0
@ -305,9 +294,9 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix
write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1)
write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero)
if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow)
if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow)
if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow)
@ -325,5 +314,3 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write(psb_err_unit,*) 'Error while opening ',filename write(psb_err_unit,*) 'Error while opening ',filename
return return
end subroutine shb_write end subroutine shb_write

30
util/psb_z_hbio_impl.f90
Unescape Escape View File

@ -254,8 +254,7 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt11='(a3,11x,2i14)'
character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)'
type(psb_z_csc_sparse_mat), target :: acsc type(psb_z_csc_sparse_mat) :: acsc
type(psb_z_csc_sparse_mat), pointer :: acpnt
character(len=72) :: mtitle_ character(len=72) :: mtitle_
character(len=8) :: key_ character(len=8) :: key_
@ -297,23 +296,13 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
endif endif
select type(aa=>a%a) call acsc%cp_from_fmt(a%a, iret)
type is (psb_z_csc_sparse_mat) if (iret /= 0) return
acpnt => aa
class default nrow = acsc%get_nrows()
ncol = acsc%get_ncols()
call acsc%cp_from_fmt(aa, iret) nnzero = acsc%get_nzeros()
if (iret /= 0) return
acpnt => acsc
end select
nrow = acpnt%get_nrows()
ncol = acpnt%get_ncols()
nnzero = acpnt%get_nzeros()
neltvl = 0 neltvl = 0
@ -352,9 +341,9 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix
write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1)
write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero)
if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow)
if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow)
if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow)
@ -372,4 +361,3 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
write(psb_err_unit,*) 'Error while opening ',filename write(psb_err_unit,*) 'Error while opening ',filename
return return
end subroutine zhb_write end subroutine zhb_write

Write Preview
Loading…
Cancel
Save