From 26941924cca94a8d1f4a6f7f095ce4a57961b770 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 10 Jan 2012 10:19:46 +0000 Subject: [PATCH] psblas3: 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. --- util/psb_c_hbio_impl.f90 | 29 +++++++++-------------------- util/psb_d_hbio_impl.f90 | 30 +++++++++--------------------- util/psb_s_hbio_impl.f90 | 31 +++++++++---------------------- util/psb_z_hbio_impl.f90 | 30 +++++++++--------------------- 4 files changed, 36 insertions(+), 84 deletions(-) diff --git a/util/psb_c_hbio_impl.f90 b/util/psb_c_hbio_impl.f90 index 96f8746c..37466f0d 100644 --- a/util/psb_c_hbio_impl.f90 +++ b/util/psb_c_hbio_impl.f90 @@ -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 :: fmt111='(1x,a8,1x,i8,1x,a10)' - type(psb_c_csc_sparse_mat), target :: acsc - type(psb_c_csc_sparse_mat), pointer :: acpnt + type(psb_c_csc_sparse_mat) :: acsc character(len=72) :: mtitle_ character(len=8) :: key_ @@ -297,23 +296,13 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) endif - select type(aa=>a%a) - type is (psb_c_csc_sparse_mat) + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return - acpnt => aa - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret /= 0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() 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,& & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(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 (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) diff --git a/util/psb_d_hbio_impl.f90 b/util/psb_d_hbio_impl.f90 index b31ed247..5e5e941c 100644 --- a/util/psb_d_hbio_impl.f90 +++ b/util/psb_d_hbio_impl.f90 @@ -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 :: fmt111='(1x,a8,1x,i8,1x,a10)' - type(psb_d_csc_sparse_mat), target :: acsc - type(psb_d_csc_sparse_mat), pointer :: acpnt + type(psb_d_csc_sparse_mat) :: acsc character(len=72) :: mtitle_ character(len=8) :: key_ @@ -250,23 +249,13 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) endif - select type(aa=>a%a) - type is (psb_d_csc_sparse_mat) + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return - acpnt => aa - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret /= 0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() 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,& & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(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 (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) @@ -325,4 +314,3 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine dhb_write - diff --git a/util/psb_s_hbio_impl.f90 b/util/psb_s_hbio_impl.f90 index 12969266..626ed3f8 100644 --- a/util/psb_s_hbio_impl.f90 +++ b/util/psb_s_hbio_impl.f90 @@ -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 :: fmt111='(1x,a8,1x,i8,1x,a10)' - type(psb_s_csc_sparse_mat), target :: acsc - type(psb_s_csc_sparse_mat), pointer :: acpnt + type(psb_s_csc_sparse_mat) :: acsc character(len=72) :: mtitle_ character(len=8) :: key_ @@ -250,23 +249,13 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) endif - select type(aa=>a%a) - type is (psb_s_csc_sparse_mat) + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return - acpnt => aa - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret /= 0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() 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,& & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(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 (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) @@ -325,5 +314,3 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine shb_write - - diff --git a/util/psb_z_hbio_impl.f90 b/util/psb_z_hbio_impl.f90 index ea1121fe..84d6ad8f 100644 --- a/util/psb_z_hbio_impl.f90 +++ b/util/psb_z_hbio_impl.f90 @@ -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 :: fmt111='(1x,a8,1x,i8,1x,a10)' - type(psb_z_csc_sparse_mat), target :: acsc - type(psb_z_csc_sparse_mat), pointer :: acpnt + type(psb_z_csc_sparse_mat) :: acsc character(len=72) :: mtitle_ character(len=8) :: key_ @@ -297,23 +296,13 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) endif - select type(aa=>a%a) - type is (psb_z_csc_sparse_mat) + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return - acpnt => aa - class default - - call acsc%cp_from_fmt(aa, iret) - if (iret /= 0) return - acpnt => acsc - - end select - - - nrow = acpnt%get_nrows() - ncol = acpnt%get_ncols() - nnzero = acpnt%get_nzeros() + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() 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,& & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) - write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(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 (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) @@ -372,4 +361,3 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine zhb_write -