diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 7e1a652c..d3f30599 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -58,6 +58,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_string_mod use psb_penv_mod implicit none @@ -74,7 +75,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& & err, liwork,data_ real(kind(1.d0)),pointer :: iwork(:), xp(:,:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -117,9 +118,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) end if if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(data)) then @@ -189,12 +190,16 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! exchange halo elements xp => x(iix:size(x,1),jjx:jjx+k-1) - if(ltran.eq.'N') then - call psi_swapdata(imode,k,0.d0,xp,& + if(tran_ == 'N') then + call psi_swapdata(imode,k,dzero,xp,& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,k,1.d0,xp,& + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,done,xp,& &desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -211,7 +216,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -278,6 +283,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) use psb_check_mod use psb_realloc_mod use psb_error_mod + use psb_string_mod use psb_penv_mod implicit none @@ -294,7 +300,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & err, liwork,data_ real(kind(1.d0)),pointer :: iwork(:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -321,9 +327,9 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) nrow = psb_cd_get_local_rows(desc_a) if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(data)) then data_ = data @@ -386,12 +392,16 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) end if ! exchange halo elements - if(ltran.eq.'N') then - call psi_swapdata(imode,0.d0,x(iix:size(x)),& + if(tran_ == 'N') then + call psi_swapdata(imode,dzero,x(iix:size(x)),& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,1.d0,x(iix:size(x)),& + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,done,x(iix:size(x)),& & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -408,7 +418,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 9e387881..c3c2d5f9 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -231,7 +231,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -454,7 +454,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 82f5ed07..49d39888 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -75,7 +75,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) & err_act, m, n, iix, jjx, ix, ijx, nrow, k, maxk, liwork,& & imode, err,data_ integer, pointer :: xp(:,:), iwork(:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -118,9 +118,9 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) end if if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(data)) then @@ -191,12 +191,16 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) xp => x(iix:size(x,1),jjx:jjx+k-1) ! exchange halo elements - if(ltran.eq.'N') then - call psi_swapdata(imode,k,0,xp,& + if(tran_ == 'N') then + call psi_swapdata(imode,k,izero,xp,& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,k,1,xp,& + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,ione,xp,& & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -213,7 +217,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -298,7 +302,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & err, liwork, data_ integer,pointer :: iwork(:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -327,9 +331,9 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(data)) then data_ = data @@ -392,12 +396,16 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) end if ! exchange halo elements - if(ltran.eq.'N') then - call psi_swapdata(imode,0,x(iix:size(x)),& + if(tran_ == 'N') then + call psi_swapdata(imode,izero,x(iix:size(x)),& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then - call psi_swaptran(imode,1,x(iix:size(x)),& + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,ione,x(iix:size(x)),& & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -414,7 +422,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 8c60f698..af526eab 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -74,7 +74,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) & err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& & err, liwork,data_ complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -117,9 +117,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) end if if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(mode)) then imode = mode @@ -187,12 +187,16 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! exchange halo elements xp => x(iix:size(x,1),jjx:jjx+k-1) - if(ltran.eq.'N') then + if(tran_ == 'N') then call psi_swapdata(imode,k,zzero,xp,& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then + else if((tran_ == 'T').or.(tran_ == 'C')) then call psi_swaptran(imode,k,zone,xp,& &desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -210,7 +214,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -294,7 +298,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) integer :: ictxt, np, me, err_act, & & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ complex(kind(1.d0)),pointer :: iwork(:) - character :: ltran + character :: tran_ character(len=20) :: name, ch_err logical :: aliw @@ -321,9 +325,9 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) nrow = psb_cd_get_local_rows(desc_a) if (present(tran)) then - ltran = tran + tran_ = toupper(tran) else - ltran = 'N' + tran_ = 'N' endif if (present(mode)) then imode = mode @@ -387,12 +391,16 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) end if ! exchange halo elements - if(ltran.eq.'N') then + if(tran_ == 'N') then call psi_swapdata(imode,zzero,x(iix:size(x)),& & desc_a,iwork,info,data=data_) - else if((ltran.eq.'T').or.(ltran.eq.'H')) then + else if((tran_ == 'T').or.(tran_ == 'C')) then call psi_swaptran(imode,zone,x(iix:size(x)),& & desc_a,iwork,info) + else + info = 4001 + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 end if if(info.ne.0) then @@ -410,7 +418,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index f52e2f06..7cebf154 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -232,7 +232,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if @@ -453,7 +453,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) 9999 continue call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then + if (err_act == psb_act_abort_) then call psb_error(ictxt) return end if