basic_tools.F90

Go to the documentation of this file.

module basic_tools 

  implicit none
  private

  public :: inttostring        ! tested
  public :: quit, warning


  external clockget
  double precision :: clockget
  public :: clock

  public :: allocmem, freemem

  interface allocmem 
     module procedure alloc_ia1d, alloc_ia2d
     module procedure alloc_la1d
  end interface allocmem

  interface freemem 
     module procedure free_ia1d, free_ia2d
     module procedure free_la1d
  end interface freemem



contains


  subroutine inttostring(str, ii)
    character(len=*), intent(out) :: str
    integer         , intent(in)  :: ii

    !! positive integers
    !!
    if ( ii >= 0 ) then

       if ( ii <    10) then
          write (str,'(I1)') ii

       else if ( ii <   100) then
          write (str,'(I2)') ii
          
       else if ( ii <  1000) then
          write (str,'(I3)') ii
          
       else if ( ii < 10000) then
          write (str,'(I4)') ii

       else 
          call quit("basic_tools: intToString: n >= 10000")
       end if

    end if

    !! negative integers
    !!
    if ( ii < 0 ) then

       if ( ii > -10) then
          write (str,'(I2)') ii

       else if ( ii > -100) then
          write (str,'(I3)') ii

       else 
          call quit("basic_tools: intToString: n < -100")
       end if

    end if

    str = trim(str)

  end subroutine inttostring


  function clock() result(time)
    double precision :: time

    time = clockget()

  end function clock


  subroutine quit(message)
    character(len=*), intent(in) :: message
    
    write(*,*)
    write(*,*) "basic_tools     : quit"
    write(*,*) "ERROR = ", trim(message)
    stop -1

  end subroutine quit
  
  subroutine warning(message, verb)
    character(len=*), intent(in) :: message
    integer         , intent(in) :: verb
    
#ifdef NOWARN
    write(*,*) "basic_tools     : "
    write(*,*) "WARNING: ", trim(message)
    stop -1

#else
    if (verb>0) then
       write(*,*) "basic_tools     : "
       write(*,*) "WARNING: ", trim(message)       
    end if
#endif

  end subroutine warning


  subroutine alloc_ia1d(p,n)
    integer, dimension(:), allocatable :: p
    integer, intent(in) :: n

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n), stat=stat, errmsg=errmsg)
    if (stat > 0) then
       errmsg="alloc_LI: alloc_IA1D: "// trim(errmsg) 
       call quit(errmsg) 
    end if

  end subroutine alloc_ia1d

  subroutine alloc_la1d(p,n)
    logical, dimension(:), allocatable :: p
    integer, intent(in) :: n

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n), stat=stat, errmsg=errmsg)
    if (stat > 0) then
       errmsg="alloc_LI: alloc_LA1D: "// trim(errmsg) 
       call quit(errmsg) 
    end if

  end subroutine alloc_la1d

  subroutine alloc_ia2d(p,n1,n2)
    integer, dimension(:,:), allocatable :: p
    integer, intent(in) :: n1, n2

    integer :: stat
    character(len=100) :: errmsg

    call freemem(p)
    allocate(p(n1,n2), stat=stat, errmsg=errmsg)
    if (stat > 0) then
       errmsg="alloc_LI: alloc_IA2D: "// trim(errmsg) 
       call quit(errmsg) 
    end if

  end subroutine alloc_ia2d


  subroutine free_ia1d(p)
    integer, dimension(:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) call quit("alloc_LI: free_IA1D: "//trim(errmsg) )
    end if

  end subroutine free_ia1d

  subroutine free_ia2d(p)
    integer, dimension(:,:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) call quit("alloc_LI: free_IA2D: "//trim(errmsg) )
    end if

  end subroutine free_ia2d



  subroutine free_la1d(p)
    logical, dimension(:), allocatable :: p

    integer :: stat
    character(len=100) :: errmsg

    if (allocated(p)) then
       deallocate(p, stat=stat, errmsg=errmsg)
       if (stat > 0) call quit("alloc_LI: free_LA1D: "//trim(errmsg) )
    end if

  end subroutine free_la1d


end module basic_tools