!-----------------------------------------------------------------------------
!
!  Copyright (C) 1997-2005 Krzysztof M. Gorski, Eric Hivon, 
!                          Benjamin D. Wandelt, Anthony J. Banday, 
!                          Matthias Bartelmann, Hans K. Eriksen, 
!                          Frode K. Hansen, Martin Reinecke
!
!
!  This file is part of HEALPix.
!
!  HEALPix is free software; you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation; either version 2 of the License, or
!  (at your option) any later version.
!
!  HEALPix is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with HEALPix; if not, write to the Free Software
!  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
!
!  For more information about HEALPix see http://healpix.jpl.nasa.gov
!
!-----------------------------------------------------------------------------
module misc_utils
!   subroutine fatal_error
!   function file_present
!   subroutine assert_present
!   subroutine assert_directory_present
!   subroutine assert_not_present
!   subroutine assert_alloc
!   subroutine assert
!   function strupcase
!   function strlowcase
!   function string
!   subroutine wall_clock_time
!   subroutine brag_openmp
!--------------------------------------------------------------------------------------
  ! edited 2006-10-31: fatal_error for gfortran gcc4.1.1 bug workaround (V. Stolyarov)
  !--------------------------------------------------------------------------------------
  use healpix_types
  use extension, only : exit_with_status
  implicit none
  private

  integer, parameter, private :: LCH=48
  interface string
     module procedure string_i, string_s, string_d
  end interface

  interface fatal_error
  	module procedure fatal_error_womsg, fatal_error_msg
  end interface

  public :: fatal_error, assert, assert_present, assert_not_present, &
       & assert_alloc, file_present, assert_directory_present
  public :: upcase, lowcase
  public :: wall_clock_time
  public :: brag_openmp
  public :: strupcase, strlowcase, string

contains
  !-----------------------------------------------------
!  subroutine fatal_error (msg)
!    character(len=*), intent(in), optional :: msg
!
!    if (present(msg)) then
!       print *,'Fatal error: ', trim(msg)
!    else
!       print *,'Fatal error'
!    endif
!    call exit_with_status(1)
!  end subroutine fatal_error

  subroutine fatal_error_msg (msg)
    character(len=*), intent(in) :: msg
       print *,'Fatal error: ', trim(msg)
    call exit_with_status(1)
  end subroutine fatal_error_msg

  subroutine fatal_error_womsg
      print *,'Fatal error'
    call exit_with_status(1)
  end subroutine fatal_error_womsg

  !-----------------------------------------------------
  function file_present (filename)
    character(len=*), intent(in) :: filename
    logical :: file_present

    inquire(file=trim(filename),exist=file_present)
  end function file_present

  !-----------------------------------------------------
  subroutine assert_present (filename)
    character(len=*), intent(in) :: filename

    if (.not. file_present(trim(filename))) then
       print *, 'Error:  file ' // trim(filename) // ' does not exist!'
       call exit_with_status(1)
    end if
  end subroutine assert_present

  !-----------------------------------------------------
  subroutine assert_directory_present (filename)
    character(len=*), intent(in) :: filename
    integer pos

    pos = scan(filename,'/',.true.)
    if (pos<=0) return

    if (.not. file_present(filename(:pos-1))) then
       print *, 'Error:  directory ' // filename(:pos-1) // ' does not exist!'
       call exit_with_status(1)
    end if
  end subroutine assert_directory_present

  !-----------------------------------------------------
  subroutine assert_not_present (filename)
    character(len=*), intent(in) :: filename

    if (file_present(trim(filename))) then
       print *, 'Error:  file ' // trim(filename) // ' already exists!'
       call exit_with_status(1)
    end if
  end subroutine assert_not_present

  !-----------------------------------------------------
  subroutine assert_alloc (stat,code,arr)
    integer, intent(in) :: stat
    character(len=*), intent(in) :: code, arr

    if (stat==0) return

    print *, trim(code)//'> cannot allocate memory for array: '//trim(arr)
    call exit_with_status(1)
  end subroutine assert_alloc

  !-----------------------------------------------------
  subroutine assert (testval,msg,errcode)
    logical, intent(in) :: testval
    character(len=*), intent(in), optional :: msg
    integer, intent(in), optional :: errcode

    if (testval) return

    print *,"Assertion failed: "
    if (present(msg)) print *, trim(msg)
    if (present(errcode)) call exit_with_status (errcode)
    call exit_with_status(1)
  end subroutine assert

  !-----------------------------------------------------
  subroutine upcase(instr, outstr)
    ! turns a string to upper case
    ! instr and outstr can be the same variable
    character(len=*), intent(in)  :: instr
    character(len=*), intent(out) :: outstr

    integer(i4b) :: i, j, ascii, ll, la, ua

    la = iachar('a')
    ua = iachar('A')

    ll = len_trim(outstr)
    do i = 1, min(len_trim(instr),ll)
       ascii = iachar( instr(i:i) )
       if (ascii >= la .and. ascii < la+26) then ! in [a,z]
          outstr(i:i) = achar( ascii - la + ua )
       else
          outstr(i:i) = instr(i:i)
       endif
    enddo
    do j = i, ll ! pad with blanks
       outstr(j:j) = ' '
    enddo
    return
  end subroutine upcase

  !-----------------------------------------------------
  subroutine lowcase(instr, outstr)
    ! turns a string to lower case
    ! instr and outstr can be the same variable
    character(len=*), intent(in)  :: instr
    character(len=*), intent(out) :: outstr

    integer(i4b) :: i, j, ascii, ll, la, ua

    la = iachar('a')
    ua = iachar('A')

    ll = len_trim(outstr)
    do i = 1, min(len_trim(instr),ll)
       ascii = iachar( instr(i:i) )
       if (ascii >= ua .and. ascii < ua+26) then ! in [A,Z]
          outstr(i:i) = achar( ascii - ua + la )
       else
          outstr(i:i) = instr(i:i)
       endif
    enddo
    do j = i, ll ! pad with blanks
       outstr(j:j) = ' '
    enddo
    return
  end subroutine lowcase
  !-----------------------------------------------------
  function strupcase(instr) result(outstr)
    ! turns a character string to upper case
    character(len=*), intent(in)  :: instr
    character(len=FILENAMELEN)    :: outstr

    integer(i4b) :: i, ascii, la, ua

    la = iachar('a')
    ua = iachar('A')

    outstr = instr
    do i = 1, min(len_trim(instr),len_trim(outstr))
       ascii = iachar( instr(i:i) )
       if (ascii >= la .and. ascii < la+26) then ! in [a,z]
          outstr(i:i) = achar( ascii - la + ua )
       endif
    enddo

    return
  end function strupcase

  !-----------------------------------------------------
  function strlowcase(instr) result(outstr)
    ! turns a string to lower case
    character(len=*), intent(in)  :: instr
    character(len=FILENAMELEN)    :: outstr

    integer(i4b) :: i, ascii, la, ua

    la = iachar('a')
    ua = iachar('A')

    outstr = instr
    do i = 1, min(len_trim(instr),len_trim(outstr))
       ascii = iachar( instr(i:i) )
       if (ascii >= ua .and. ascii < ua+26) then ! in [A,Z]
          outstr(i:i) = achar( ascii - ua + la )
       endif
    enddo

    return
  end function strlowcase

  !========================================
  ! function string(arg, format)
  !=======================================
  function string_i(arg, format) result(str)
    integer(i4b) :: arg
    character(len=*),   optional :: format
    character(len=LCH)           :: str
    if (present(format)) then
       write(str,format) arg
    else
       write(str,*) arg
    endif
    return
  end function string_i
  !--------------------------------
  function string_s(arg, format) result(str)
    real(sp) :: arg
    character(len=*),   optional :: format
    character(len=LCH)           :: str
    if (present(format)) then
       write(str,format) arg
    else
       write(str,*) arg
    endif
    return
  end function string_s
  !--------------------------------
  function string_d(arg, format) result(str)
    real(dp) :: arg
    character(len=*),   optional :: format
    character(len=LCH)           :: str
    if (present(format)) then
       write(str,format) arg
    else
       write(str,*) arg
    endif
    return
  end function string_d
  !--------------------------------

  !-----------------------------------------------------
  subroutine wall_clock_time(time_sec)
    real(sp), intent(out) :: time_sec

    integer :: clock, clock_rate, clock_max
    integer, dimension(8) :: values_time

    time_sec = 0.

    call system_clock(count=clock, count_rate=clock_rate, count_max=clock_max)

    if (clock < 0 .or. clock_rate <= 0 .or. clock_max <= 0) then
       call date_and_time(values = values_time) ! y, m, d, x, h, m, s, ms
       if (minval(values_time) >= 0) then
          time_sec = ((values_time(3)*24. &
               &     + values_time(5)    )*60. &
               &     + values_time(6)        )*60. &
               &     + values_time(7) + values_time(8)/1000.
       endif
    else
       time_sec = clock/real(clock_rate)
    endif

    return
  end subroutine wall_clock_time
  !================================================
  subroutine brag_openmp()
  !================================================
    ! OpenMP bragging
    !================================================
    ! OpenMP variables
    !$     integer :: omp_get_thread_num, omp_get_num_threads, omp_get_num_procs
    !IBMP  integer :: omp_get_thread_num, omp_get_num_threads, omp_get_num_procs

!$OMP parallel
!
!$   if (omp_get_thread_num() == 0) then
!$       write(*,9000) ' --------------------------------------'
!$       write(*,9010) ' Number of OpenMP threads in use: ', omp_get_num_threads()
!$       write(*,9010) ' Number of CPUs available:        ', omp_get_num_procs()
!$       write(*,9000) ' --------------------------------------'
!$   end if
!
!IBMP   if (omp_get_thread_num() == 0) then
!IBMP       write(*,9000) ' --------------------------------------'
!IBMP       write(*,9010) ' Number of OpenMP threads in use: ', omp_get_num_threads()
!IBMP       write(*,9010) ' Number of CPUs available:        ', omp_get_num_procs()
!IBMP       write(*,9000) ' --------------------------------------'
!IBMP   end if
!
!$OMP end parallel
9000 format(a)
9010 format(a,i4)

    return
  end subroutine brag_openmp

end module misc_utils