!===============================================================================
!
! misc.F90 - miscellaneous (service routines)
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-2016 Hinnerk Stueben
!               2008-2010 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
! BQCD 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 3 of the License, or
! (at your option) any later version.
!
! BQCD 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 BQCD.  If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
module module_misc
  
  integer, save :: trace_depth = 0

end

!-------------------------------------------------------------------------------
subroutine die(msg)  ! write "msg" to stderr and abort

  implicit none
  character(len = *) msg

  write(STDERR,*) msg
  call abbruch()

end

!-------------------------------------------------------------------------------
subroutine warn(msg)  ! write "msg" to stderr and unit UREC
  use module_function_decl
  implicit none
  character(len = *) msg

  if (my_pe() == 0) then
     write(STDERR,*) "WARNING: ", msg, " !!!"
     write(UREC,*)   "WARNING: ", msg, " !!!"
  endif
end

!-------------------------------------------------------------------------------
subroutine assertion_failed(file, line, condition)  !// used by ASSERT makro
  implicit none
  character(len = *) file, condition
  integer line

  character(len = 32) aline

  write(aline, *) line

  call die(file // " (" // trim(adjustl(aline)) // "): assertion failed: " // condition)

end

!-------------------------------------------------------------------------------
subroutine check_failed(file, line, condition)  !// used by CHECK makro
  implicit none
  character(len = *) file, condition
  integer line

  character(len = 32) aline

  write(aline, *) line

  call die(file // " (" // trim(adjustl(aline)) // "): check failed: " // condition)

end

!-------------------------------------------------------------------------------
subroutine begin(unit, str)  ! write "begin marker"

  use module_function_decl
  implicit none
  integer :: unit
  character(len = *) :: str

  if (my_pe() == 0) write(unit, "(1x,2a)") ">Begin", str

end

!-------------------------------------------------------------------------------
subroutine end(unit, str)  ! write "end marker"

  use module_function_decl
  implicit none
  integer :: unit
  character(len = *) :: str

  if (my_pe() == 0) write(unit, "(1x,2a)") ">End", str

end

!-------------------------------------------------------------------------------
function datum()  ! returns date as: YYYY-MM-DD

  implicit none
  character(len = 10) :: datum

  call date_and_time(date = datum)

  datum(9:10) = datum(7:8)
  datum(6:7) = datum(5:6)

  datum(5:5) = "-"
  datum(8:8) = "-"

end

!-------------------------------------------------------------------------------
function uhrzeit()  ! returns time as:  hh:mm:ss.sss

  implicit none
  character(len = 12) :: uhrzeit

  call date_and_time(time = uhrzeit)

  uhrzeit(7:12) = uhrzeit(5:10)
  uhrzeit(4:5) = uhrzeit(3:4)

  uhrzeit(3:3) = ":"
  uhrzeit(6:6) = ":"

end

!-------------------------------------------------------------------------------
function f_exist(file) ! check in file exists

  implicit none
  logical :: f_exist
  character(len = *) :: file
  
  inquire(file = file, exist = f_exist)

end

!-------------------------------------------------------------------------------
subroutine open_diag()  ! open debug file on each process

  use module_function_decl
  implicit none
  FILENAME :: name

  write(name, '(i4.4)') my_pe()
  name = 'diag.' // name

  open(UDIAG, file = trim(name))

  write(UDIAG,*) 'Output from PE ', my_pe()
  write(UDIAG,*) '~~~~~~~~~~~~~~~~~~~'
  write(UDIAG,*)

end

!-------------------------------------------------------------------------------
subroutine pos_keyword(unit, keyword)  ! positions unit at keyword

  implicit none
  integer, intent(in)               :: unit
  character(len = *), intent(in)    :: keyword 
  integer                           :: iostat
  character(len = len(keyword) + 1) :: word

  iostat = 0
  do while (iostat == 0)
     read(unit, *, iostat = iostat) word
     if (word == keyword) then
        backspace(unit)
        return
     endif
  enddo

  call die("pos_keyword(): " // keyword // ": not found")

end

!-------------------------------------------------------------------------------
subroutine read_keyword_line(unit, keyword, line)  ! read rest of line after keyw.

  implicit none
  integer, intent(in)               :: unit
  character(len = *), intent(in)    :: keyword
  character(len = *), intent(out)   :: line
  character(80)                     :: s
  integer                           :: i

  call pos_keyword(unit, keyword)
  read(unit, "(a)") s

  i = index(s, trim(keyword)) + len_trim(keyword)
  line = adjustl(s(i:))

end

!-------------------------------------------------------------------------------
subroutine read_keyword_char(unit, keyword, char, dim)  ! read char(s) at keyw.

  implicit none
  integer, intent(in)               :: unit, dim
  character(len = *), intent(in)    :: keyword
  character(len = *), intent(out)   :: char(dim)
  character                         :: c

  call pos_keyword(unit, keyword)
  read(unit, *) c, char

end

!-------------------------------------------------------------------------------
subroutine read_keyword_int(unit, keyword, int, dim)  ! read integer(s) at keyw.

  implicit none
  integer, intent(in)               :: unit, dim
  character(len = *), intent(in)    :: keyword 
  integer, intent(out)              :: int(dim)
  character                         :: c

  call pos_keyword(unit, keyword)
  read(unit, *) c, int

end

!-------------------------------------------------------------------------------
subroutine read_keyword_REAL(unit, keyword, x, dim)  ! read float(s) at keyword

  implicit none
  integer, intent(in)               :: unit, dim
  character(len = *), intent(in)    :: keyword 
  REAL, intent(out)                 :: x(dim)
  character                         :: c

  call pos_keyword(unit, keyword)
  read(unit, *) c, x

end

!-------------------------------------------------------------------------------
subroutine swap_endian4(n, a)

  implicit none
  INT8, intent(in)    :: n
  INT4                :: i
  INT4, intent(inout) :: a(n)
  INT4, save          :: mask1, mask2, mask3, mask4
  INT4                :: tmp
  logical, external   :: is_big_endian

  data mask1 /z'000000FF'/
  data mask2 /z'0000FF00'/
  data mask3 /z'00FF0000'/
  data mask4 /z'FF000000'/


  if (is_big_endian()) return

  do i = 1, n
     tmp = 0_4
     tmp = ior(tmp, ishft(iand(a(i), mask1), 24_4))
     tmp = ior(tmp, ishft(iand(a(i), mask2),  8_4))
     tmp = ior(tmp, ishft(iand(a(i), mask3), -8_4))
     tmp = ior(tmp, ishft(iand(a(i), mask4),-24_4))
     a(i) = tmp
  enddo

end

!-------------------------------------------------------------------------------
subroutine swap_endian8(n, a)

  implicit none
  INT8, intent(in)    :: n
  INT8                :: i
  INT8, intent(inout) :: a(n)
  INT8, save          :: mask1, mask2, mask3, mask4, &
                                mask5, mask6, mask7, mask8
  INT8                :: tmp
  logical, external   :: is_big_endian

  data mask1 /z'00000000000000FF'/
  data mask2 /z'000000000000FF00'/
  data mask3 /z'0000000000FF0000'/
  data mask4 /z'00000000FF000000'/
  data mask5 /z'000000FF00000000'/
  data mask6 /z'0000FF0000000000'/
  data mask7 /z'00FF000000000000'/
  data mask8 /z'FF00000000000000'/


  if (is_big_endian()) return

  do i = 1, n
     tmp = 0_8
     tmp = ior(tmp, ishft(iand(a(i), mask1), 56_8))
     tmp = ior(tmp, ishft(iand(a(i), mask2), 40_8))
     tmp = ior(tmp, ishft(iand(a(i), mask3), 24_8))
     tmp = ior(tmp, ishft(iand(a(i), mask4),  8_8))
     tmp = ior(tmp, ishft(iand(a(i), mask5), -8_8))
     tmp = ior(tmp, ishft(iand(a(i), mask6),-24_8))
     tmp = ior(tmp, ishft(iand(a(i), mask7),-40_8))
     tmp = ior(tmp, ishft(iand(a(i), mask8),-56_8))
     a(i) = tmp
  enddo

end

!-------------------------------------------------------------------------------
character(12) function itoa(i)

  implicit none
  integer, intent(in) :: i

  write(itoa,*) i
end


!-------------------------------------------------------------------------------
character(24) function i8toa(i)

  implicit none
  INT8, intent(in) :: i

  write(i8toa,*) i
end

!-------------------------------------------------------------------------------
character(24) function REALtoa(x, fmt)

  implicit none
  REAL, intent(in)         :: x
  character(*), intent(in) :: fmt

  write(REALtoa, fmt) x
end

!-------------------------------------------------------------------------------
integer function getdigit(i)

  implicit none
  integer, intent(in) :: i
  integer :: num

  getdigit = 1
  num = i
  do while (num >= 10)
     num = num / 10
     getdigit = getdigit + 1
  enddo

end

!-----------------------------------------------------------------------------
subroutine dump_string(unit, key, value)  ! writes to file: key "value"

  integer      :: unit
  character(*) :: key, value
  character(*), parameter :: fmt = "(x,a,x,3a)"

  write(unit,fmt) key, '"', trim(value), '"'

end

!-----------------------------------------------------------------------------
subroutine dump_string_to_string(s, key, value)  ! writes to string: key "value"

  character(*) :: s
  character(*) :: key, value
  character(*), parameter :: fmt = "(x,a,x,3a)"

  write(s,fmt) key, '"', trim(value), '"'

end

!-------------------------------------------------------------------------------
subroutine stderr2(msg)
  use module_function_decl
  implicit none
  character(len = *) msg
  if(my_pe()==0)write(STDERR,*) msg
!!  flush(STDERR)
end
!-------------------------------------------------------------------------------
subroutine stderr2_log(msg, n, a)
  use module_function_decl
  implicit none
  character(len = *) msg
  integer :: n
  logical :: a(n)
  if(my_pe()==0)write(STDERR,*) msg, a
!!  flush(STDERR)
end
!-------------------------------------------------------------------------------
subroutine stderr2_int(msg, n, a)
  use module_function_decl
  implicit none
  character(len = *) msg
  integer :: n, a(n)
  if(my_pe()==0)write(STDERR,*) msg, a
!!  flush(STDERR)
end
!-------------------------------------------------------------------------------
subroutine stderr2_real(msg, n, a)
  use module_function_decl
  implicit none
  character(len = *) msg
  integer :: n
  REAL :: a(n)
  if(my_pe()==0)write(STDERR,*) msg, a
!!  flush(STDERR)
end

!-------------------------------------------------------------------------------
subroutine trace_entry(routine)

  use module_misc
  use module_function_decl
  implicit none
  character(*), intent(in) :: routine
  character(16) :: fmt

  if (trace_depth == 0) then
     fmt = "(2a)"
  else
     write(fmt,"(a,i0,a)") "(a,", trace_depth*3, "x,a)"
  endif

  if (my_pe() == 0) write(0,fmt) "trace: ", routine

  trace_depth = trace_depth + 1
  CHECK(trace_depth < 20)

end

!-------------------------------------------------------------------------------
subroutine trace_return()

  use module_misc
  implicit none
  trace_depth = trace_depth - 1
  CHECK(trace_depth >= 0)

end

!-------------------------------------------------------------------------------
subroutine trace_entry_c(routine) bind(c)

  use iso_c_binding
  implicit none
  character(kind=c_char), intent(inout) :: routine(*)

  integer, parameter :: max_len = 100
  integer :: i, len
  character(max_len) :: r

  do i = 1, max_len
     if (routine(i) == c_null_char) then
        exit
     else
        r(i:i) = routine(i)
        len = i
     endif
  enddo

  call trace_entry(r(1:len))

end

!-------------------------------------------------------------------------------
subroutine trace_return_c() bind(c)

  call trace_return()

end

!===============================================================================
