! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 ! Salvatore Filippone ! Alfredo Buttari ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: ! 1. Redistributions of source code must retain the above copyright ! notice, this list of conditions and the following disclaimer. ! 2. Redistributions in binary form must reproduce the above copyright ! notice, this list of conditions, and the following disclaimer in the ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS ! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! ! ! ! Purpose: ! Provide a set of timers ! ! module psb_timers_mod use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_penv_mod public psb_init_timers, psb_get_timer_idx, psb_reset_timers,& & psb_tic, psb_toc, psb_print_timers, psb_get_timer, psb_free_timers private ! Reallocation integer(psb_ipk_), parameter :: ntchunk = 50 integer(psb_ipk_), save :: active_timers = 0 ! Indices integer(psb_ipk_), parameter :: timer_tic_ = 1, timer_toc_ = 2 integer(psb_ipk_), parameter :: timer_x_ = 3, timer_sum_ = 4 integer(psb_ipk_), parameter :: timer_max_ = 5 integer(psb_ipk_), parameter :: timer_avg_ = 6, timer_min_ = 7 integer(psb_ipk_), parameter :: timer_entries_ = 7 ! The data itself type psb_string_item character(len=40) :: data end type psb_string_item integer(psb_ipk_), allocatable :: nsamples(:) real(psb_dpk_), allocatable :: timers(:,:) type(psb_string_item), allocatable :: timers_descr(:) logical :: wanted(timer_entries_) type(psb_string_item) :: entries_descr(timer_entries_) save :: nsamples, timers, timers_descr, wanted, entries_descr interface psb_realloc module procedure psb_string_item_realloc end interface psb_realloc contains subroutine print_timer(me, timer, timer_descr, iout) implicit none integer(psb_ipk_), intent(in) :: me real(psb_dpk_), intent(in) :: timer(timer_entries_) type(psb_string_item), intent(in) :: timer_descr integer(psb_ipk_), optional :: iout character(len=36) :: tmpname integer(psb_ipk_) :: iout_, i if (present(iout)) then iout_ = iout else iout_ = psb_out_unit end if write(tmpname,'(a)') trim(timer_descr%data)//":" write(iout_,'(a36,4(1x,a,f10.2))') tmpname,& & "Sum: ",timer(timer_sum_), & & "Avg: ",timer(timer_avg_), & & "Max: ",timer(timer_max_), & & "Min: ",-timer(timer_min_) end subroutine print_timer subroutine psb_print_timers(ctxt, idx, proc, global, iout) implicit none type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in), optional :: idx, proc, iout logical, optional :: global ! ! ! integer(psb_ipk_) :: me,np,info,i,j, idxmin_, idxmax_, proc_ real(psb_dpk_) :: gtimers(timer_entries_) real(psb_dpk_), allocatable :: ptimers(:,:) logical :: global_ call psb_info(ctxt,me,np) if (present(global)) then global_ = global else global_ = .true. end if if (present(proc)) then proc_ = proc else proc_ = -1 end if if (present(idx)) then idxmin_ = idx idxmax_ = idx else idxmin_ = 1 idxmax_ = active_timers end if if (global_) then if (allocated(timers)) then allocate(ptimers(timer_entries_,size(timers,2)),stat=info) if (info /= 0) then write(0,*) 'Error while trying to allocate temporary ',info call psb_abort(ctxt) end if ptimers = timers call psb_max(ctxt,ptimers) if (me == psb_root_) then do i=idxmin_, idxmax_ call print_timer(me, ptimers(:,i), timers_descr(i), iout) end do end if end if else if ((proc_ == -1).or.(me==proc_)) then do i=idxmin_, idxmax_ call print_timer(me, ptimers(:,i), timers_descr(i), iout) end do end if end if end subroutine psb_print_timers subroutine psb_reset_timers() active_timers = 0 if (allocated(nsamples)) nsamples = 0 if (allocated(timers)) then timers = dzero timers(timer_min_,:) = -huge(dzero) end if wanted = .true. wanted(timer_tic_) = .false. wanted(timer_toc_) = .false. entries_descr(timer_tic_)%data = "tic" entries_descr(timer_toc_)%data = "toc" entries_descr(timer_x_)%data = "Time" entries_descr(timer_sum_)%data = "Total time" entries_descr(timer_max_)%data = "Max time " entries_descr(timer_avg_)%data = "Average time" entries_descr(timer_min_)%data = "Min time" end subroutine psb_reset_timers subroutine psb_init_timers(ntimers) implicit none integer(psb_ipk_), optional :: ntimers integer(psb_ipk_) :: ntimers_, info if (present(ntimers)) then ntimers_ = ntimers else ntimers_ = ntchunk end if call reallocate_timers(ntimers_,info) if (info == 0) call psb_reset_timers() end subroutine psb_init_timers subroutine psb_free_timers() implicit none integer(psb_ipk_) :: info if (allocated(nsamples)) deallocate(nsamples,stat=info) if (allocated(timers)) deallocate(timers,stat=info) if (allocated(timers_descr)) deallocate(timers_descr,stat=info) end subroutine psb_free_timers subroutine reallocate_timers(tsz,info) implicit none integer(psb_ipk_), intent(in) :: tsz integer(psb_ipk_), intent(out) :: info call psb_realloc(timer_entries_,tsz,timers,info) if (info == 0) call psb_realloc(tsz,nsamples,info) if (info == 0) call psb_realloc(tsz,timers_descr,info) end subroutine reallocate_timers function psb_get_timer_idx(string) result(val) implicit none integer(psb_ipk_) :: val character(len=*), intent(in), optional :: string integer(psb_ipk_) :: info val = -1 if (.not.allocated(timers)) call psb_init_timers() if (active_timers >= size(timers,2)) then call reallocate_timers((active_timers+ntchunk),info) if (info /= 0) return nsamples(active_timers+1:) = 0 timers(:,active_timers+1:) = dzero timers(timer_min_,active_timers+1:) = -huge(dzero) end if active_timers = active_timers + 1 if (present(string)) then timers_descr(active_timers)%data = string end if val = active_timers end function psb_get_timer_idx function psb_get_timer(idx) result(val) implicit none real(psb_dpk_) :: val integer(psb_ipk_), intent(in) :: idx ! integer(psb_ipk_) :: info val = dzero if ((1<=idx).and.(idx <= active_timers)) then val = timers(timer_x_,idx) end if end function psb_get_timer subroutine psb_tic(idx) implicit none integer(psb_ipk_), intent(in) :: idx if ((1<=idx).and.(idx <= active_timers)) & & timers(timer_tic_,idx) = psb_wtime() end subroutine psb_tic subroutine psb_toc(idx) implicit none integer(psb_ipk_), intent(in) :: idx if ((1<=idx).and.(idx <= active_timers)) then timers(timer_toc_,idx) = psb_wtime() timers(timer_x_,idx) = & & timers(timer_toc_,idx) - timers(timer_tic_,idx) nsamples(idx) = nsamples(idx) + 1 timers(timer_sum_,idx) = & & timers(timer_sum_,idx) + timers(timer_x_,idx) timers(timer_avg_,idx) = timers(timer_sum_,idx) / nsamples(idx) timers(timer_max_,idx) = & & max(timers(timer_max_,idx), timers(timer_x_,idx)) ! Trick: keep the MAX of negative times, so that ! a MAX over all processes for an entire section ! will give the MIN for the MIN entry. timers(timer_min_,idx) = & & max(timers(timer_min_,idx), (-timers(timer_x_,idx))) end if end subroutine psb_toc Subroutine psb_string_item_realloc(len,rrax,info,lb) use psb_const_mod use psb_error_mod implicit none ! ...Subroutine Arguments integer(psb_ipk_),Intent(in) :: len type(psb_string_item),allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info integer(psb_ipk_), optional, intent(in) :: lb ! ...Local Variables type(psb_string_item),allocatable :: tmp(:) integer(psb_ipk_) :: dim,err_act,err, lb_, lbi,ub_ character(len=20) :: name logical, parameter :: debug=.false. name='psb_string_item_realloc' call psb_erractionsave(err_act) info=psb_success_ if (present(lb)) then lb_ = lb else lb_ = 1 endif if ((len<0)) then err=4025 call psb_errpush(err,name, & & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') goto 9999 end if ub_ = lb_ + len-1 if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 call psb_errpush(err,name, & & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) call move_alloc(tmp,rrax) End If else dim = 0 Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 call psb_errpush(err,name, & & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') goto 9999 end if endif call psb_erractionrestore(err_act) return 9999 continue info = err call psb_error_handler(err_act) return End Subroutine psb_string_item_realloc end module psb_timers_mod