From 66955001f20036b19b4a3b0323dc0e650e278bfe Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 21 Apr 2006 12:23:51 +0000 Subject: [PATCH] Fixes for spmat init in complex data. --- src/psblas/psb_dspsm.f90 | 9 +--- src/psblas/psb_zspmm.f90 | 105 +++++++++++++++++------------------- src/psblas/psb_zspsm.f90 | 103 ++++++++++++++++++----------------- src/tools/psb_zcdovrbld.f90 | 1 + 4 files changed, 108 insertions(+), 110 deletions(-) diff --git a/src/psblas/psb_dspsm.f90 b/src/psblas/psb_dspsm.f90 index 7976fb0d..38746cf6 100644 --- a/src/psblas/psb_dspsm.f90 +++ b/src/psblas/psb_dspsm.f90 @@ -168,12 +168,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if (present(trans)) then itrans = toupper(trans) - if((itrans.eq.'N').or.(itrans.eq.'T')) then - ! Ok - else if (itrans.eq.'C') then - info = 3020 - call psb_errpush(info,name) - goto 9999 + if((itrans.eq.'N').or.(itrans.eq.'T').or. (itrans.eq.'C')) then + ! OK else info = 70 call psb_errpush(info,name) @@ -505,7 +501,6 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& aliw=.true. end if - aliw=.true. if (aliw) then call psb_realloc(liwork,iwork,info) if(info.ne.0) then diff --git a/src/psblas/psb_zspmm.f90 b/src/psblas/psb_zspmm.f90 index 1203cebb..4fef1b64 100644 --- a/src/psblas/psb_zspmm.f90 +++ b/src/psblas/psb_zspmm.f90 @@ -95,7 +95,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - complex(kind(1.d0)), optional, pointer :: work(:) + complex(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans integer, intent(in), optional :: k, jx, jy,doswap @@ -108,6 +108,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& complex(kind(1.d0)),pointer :: tmpx(:), xp(:,:), yp(:,:), iwork(:) character :: itrans character(len=20) :: name, ch_err + logical :: aliw name='psb_zspmm' if(psb_get_errstatus().ne.0) return @@ -160,13 +161,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(trans)) then - if ((trans.eq.'N').or.(trans.eq.'T')& - & .or.(trans.eq.'n').or.(trans.eq.'t')) then - itrans = trans - else if ((trans.eq.'C').or.(trans.eq.'c')) then - info = 3020 - call psb_errpush(info,name) - goto 9999 + if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T').or. (toupper(trans).eq.'C')) then + itrans = toupper(trans) else info = 70 call psb_errpush(info,name) @@ -187,26 +183,28 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& liwork= 2*ncol if (a%pr(1) /= 0) liwork = liwork + n * ik if (a%pl(1) /= 0) liwork = liwork + m * ik - if (present(work)) then - if(size(work).lt.liwork) then - call psb_realloc(liwork,work,info) +if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + call psb_realloc(liwork,iwork,info) if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - end if - iwork => work else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if + iwork => work + endif + iwork(1)=zzero ! checking for matrix correctness @@ -342,7 +340,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& end if - if(.not.present(work)) deallocate(iwork) + if(aliw) deallocate(iwork) nullify(iwork) call psb_erractionrestore(err_act) @@ -432,7 +430,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info - complex(kind(1.d0)), optional, pointer :: work(:) + complex(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans integer, intent(in), optional :: doswap @@ -445,6 +443,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& complex(kind(1.d0)),pointer :: tmpx(:), iwork(:), xp(:), yp(:) character :: itrans character(len=20) :: name, ch_err + logical :: aliw name='psb_zspmv' if(psb_get_errstatus().ne.0) return @@ -482,17 +481,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& endif if (present(trans)) then - if((trans.eq.'N').or.(trans.eq.'T')) then - itrans = trans - else if (trans.eq.'C') then - info = 3020 - call psb_errpush(info,name) - goto 9999 - else - info = 70 - call psb_errpush(info,name) - goto 9999 - end if + if ( (toupper(trans).eq.'N').or.(toupper(trans).eq.'T') .or.(toupper(trans).eq.'C')) then + itrans = toupper(trans) + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if else itrans = 'N' endif @@ -504,33 +499,35 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& lldx = size(x) lldy = size(y) + iwork => null() ! check for presence/size of a work area liwork= 2*ncol if (a%pr(1) /= 0) liwork = liwork + n * ik if (a%pl(1) /= 0) liwork = liwork + m * ik -! write(0,*)'---->>>',work(1) - if (present(work)) then - if(size(work).ge.liwork) then - iwork => work - liwork=size(work) - else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if + ! write(0,*)'---->>>',work(1) + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + aliw=.true. + end if + + aliw=.true. + if (aliw) then + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if - end if + end if + else + iwork => work + endif + ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) @@ -643,9 +640,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& end if - if(.not.present(work)) then - deallocate(iwork) - end if + if(aliw) deallocate(iwork) nullify(iwork) call psb_erractionrestore(err_act) diff --git a/src/psblas/psb_zspsm.f90 b/src/psblas/psb_zspsm.f90 index 97abed25..a57ec8d9 100644 --- a/src/psblas/psb_zspsm.f90 +++ b/src/psblas/psb_zspsm.f90 @@ -90,7 +90,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info complex(kind(1.d0)), intent(in), optional, target :: d(:) - complex(kind(1.d0)), optional, pointer :: work(:) + complex(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans, unitd integer, intent(in), optional :: choice integer, intent(in), optional :: k, jx, jy @@ -106,6 +106,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& complex(kind(1.d0)),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) character :: itrans character(len=20) :: name, ch_err + logical :: aliw name='psb_zspsm' if(psb_get_errstatus().ne.0) return @@ -159,16 +160,16 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(unitd)) then - lunitd = unitd + lunitd = toupper(unitd) else lunitd = 'U' endif if (present(trans)) then - if ((trans.eq.'N').or.(trans.eq.'T')& - & .or.(trans.eq.'n').or.(trans.eq.'t')) then - itrans = trans - else if ((trans.eq.'C').or.(trans.eq.'c')) then + itrans = toupper(trans) + if((itrans.eq.'N').or.(itrans.eq.'T')) then + ! Ok + else if (itrans.eq.'C') then info = 3020 call psb_errpush(info,name) goto 9999 @@ -194,29 +195,32 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& end if ! check for presence/size of a work area + iwork => null() liwork= 2*ncol if (a%pr(1) /= 0) llwork = liwork + m * ik if (a%pl(1) /= 0) llwork = llwork + m * ik - if (present(work)) then - if(size(work).lt.liwork) then - call psb_realloc(liwork,work,info) + if (present(work)) then + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif + else + aliw=.true. + end if + + if (aliw) then + call psb_realloc(liwork,iwork,info) if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - end if - iwork => work else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if + iwork => work + endif + iwork(1)=0.d0 if(present(d)) then @@ -301,7 +305,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& end select end if - if(.not.present(work)) deallocate(iwork) + if(aliw) deallocate(iwork) if(.not.present(d)) deallocate(id) call psb_erractionrestore(err_act) @@ -388,6 +392,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& use psi_mod use psb_check_mod use psb_error_mod + use psb_string_mod complex(kind(1.D0)), intent(in) :: alpha, beta complex(kind(1.d0)), intent(in), target :: x(:) @@ -396,7 +401,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info complex(kind(1.d0)), intent(in), optional, target :: d(:) - complex(kind(1.d0)), optional, pointer :: work(:) + complex(kind(1.d0)), optional, target :: work(:) character, intent(in), optional :: trans, unitd integer, intent(in), optional :: choice @@ -411,6 +416,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& complex(kind(1.d0)),pointer :: iwork(:), xp(:), yp(:), id(:) character :: itrans character(len=20) :: name, ch_err + logical :: aliw name='psb_zspsv' if(psb_get_errstatus().ne.0) return @@ -448,23 +454,20 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& endif if (present(unitd)) then - lunitd = unitd + lunitd = toupper(unitd) else lunitd = 'U' endif if (present(trans)) then - if((trans.eq.'N').or.(trans.eq.'T')) then - itrans = trans - else if (trans.eq.'C') then - info = 3020 - call psb_errpush(info,name) - goto 9999 - else - info = 70 - call psb_errpush(info,name) - goto 9999 - end if + itrans = toupper(trans) + if((itrans.eq.'N').or.(itrans.eq.'T').or.(itrans.eq.'C')) then + ! Ok + else + info = 70 + call psb_errpush(info,name) + goto 9999 + end if else itrans = 'N' endif @@ -481,30 +484,34 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if + iwork => null() ! check for presence/size of a work area liwork= 2*ncol if (a%pr(1) /= 0) llwork = liwork + m * ik if (a%pl(1) /= 0) llwork = llwork + m * ik + if (present(work)) then - if(size(work).lt.liwork) then - call psb_realloc(liwork,work,info) - if(info.ne.0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - iwork => work + if (size(work) >= liwork) then + aliw =.false. + else + aliw=.true. + endif else - call psb_realloc(liwork,iwork,info) - if(info.ne.0) then + aliw=.true. + end if + + if (aliw) then + call psb_realloc(liwork,iwork,info) + if(info.ne.0) then info=4010 ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if - end if + end if + else + iwork => work + endif + iwork(1)=0.d0 if(present(d)) then @@ -588,7 +595,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& end select end if - if(.not.present(work)) deallocate(iwork) + if (aliw) deallocate(iwork) if(.not.present(d)) deallocate(id) call psb_erractionrestore(err_act) diff --git a/src/tools/psb_zcdovrbld.f90 b/src/tools/psb_zcdovrbld.f90 index ab03f0e3..5b77555b 100644 --- a/src/tools/psb_zcdovrbld.f90 +++ b/src/tools/psb_zcdovrbld.f90 @@ -96,6 +96,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& icontxt = desc_a%matrix_data(psb_ctxt_) !!$ call blacs_barrier(icontxt,'All') Call blacs_gridinfo(icontxt,np,npcol,myrow,mycol) + call psb_nullify_sp(blk) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) tl = 0.0