!> ------------------------------------------------------------------------------
!>  ULiège
!> ------------------------------------------------------------------------------
!>  
!>  UNIT: Allocation
!>  
!>  @author
!>  Michele ESPOSITO MARZINO
!>  
!>  @DESCRIPTION: 
!>  This module acts as interface for general variable allocation/deallocation.
!>  
!> ------------------------------------------------------------------------------
module Allocation
   
   implicit none
   private
   public  :: alloc

   logical :: is_unit_set = .false.
   integer :: iunit = 9999

   interface alloc
      module procedure allocI_
   end interface



contains


   subroutine allocI_(var, name, dims, file, line)
      integer, allocatable :: var(..)
      integer, intent(in)  :: dims(..)
      character(len = *), intent(in) :: name
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional :: line
      integer :: ndims, irank, istat
      character(len = 256) :: emsg
      integer :: dim_

      call printFileAndLine_(file, line)

      select rank (dims)
         rank (0)
            dim_ = dims
            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     allocate(var(dim_), stat=istat, errmsg=emsg)
                  endif
                  call allocOKMsg_(name, loc(var), sizeof(var))

               rank default
                  irank = rank(var)
                  call dimsMismatchMsg_(irank, 1)
                  error stop
            end select
         
         rank (1)

            ndims = size(dims)

            select rank (var)
               rank (1)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 1) then
                        allocate(var(dims(1)), stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(1, ndims)
                        error stop
                     endif
                  endif
                  call allocOKMsg_(name, loc(var), sizeof(var))

               rank (2)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 2) then
                        allocate(var(dims(1), dims(2)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(2, ndims)
                        error stop
                     endif
                  endif
                  call allocOKMsg_(name, loc(var), sizeof(var))

               rank (3)
                  if (allocated(var)) then
                     call varIsAllocatedMsg_(name)
                  else
                     if (ndims == 3) then
                        allocate(var(dims(1), dims(2), dims(3)), &
                           stat=istat, errmsg=emsg)
                     else
                        call dimsMismatchMsg_(3, ndims)
                        error stop
                     endif
                  endif
                  call allocOKMsg_(name, loc(var), sizeof(var))
            end select
         
         rank default
            call wrongDimsRankMsg_()
            error stop
      end select

      if (istat == 0) then

! ========================================================
! ========================================================
      
         ! call allocOKMsg_(name, loc(var), sizeof(var))
         ! call allocOKMsg_(name, loc(var))

! ========================================================
! ========================================================
         call printDims_(dims)

      else

         call allocKOMsg_(name, istat, emsg)
      
      endif
   end subroutine allocI_


















   subroutine printFileAndLine_(file, line)
      character(len = *), intent(in), optional :: file
      integer, intent(in), optional            :: line
      ! character(len = 32) :: fmt = ' '
      character(len = 64) :: buf
      integer :: ilen

      buf(:) = ' '

      write(iunit, fmt='(a)', advance='no') ' @Allocation::'
      if (.not. present(file)) return

      ! write(unit=fmt, fmt='(a)') '( " @", a )'
      write(unit=buf, fmt='(a)') file
      if (present(line)) then

         ilen = len_trim(buf)
         ilen = ilen + 1

         write(unit=buf(ilen:), fmt='( "(", i0, ")" )') line
      endif
      ilen = len_trim(buf)
      ilen = ilen + 1
      write(unit=buf(ilen:), fmt='(a)') ' :'

      write(iunit, '(a)', advance='no') buf(1 : len_trim(buf) + 2)
   end subroutine printFileAndLine_



   subroutine varIsAllocatedMsg_(name)
      character(len = *), intent(in) :: name

      write(iunit, '(3a)') &
         'variable  "', name, '"  is already allocated at this point in time.'
   end subroutine varIsAllocatedMsg_



   subroutine varIsDeallocatedMsg_(name)
      character(len = *), intent(in) :: name

      write(iunit, '(3a)') &
         'variable  "', name, '"  is already de-allocated at this point in time.'
   end subroutine varIsDeallocatedMsg_




   subroutine printDims_(dims)
      integer, intent(in) :: dims(..)
      integer :: ndims, i

      select rank (dims)

         rank(0)
            write(iunit, fmt='(a, i0)') &
               'Dimensions:  ', dims

         rank (1)

            ndims = size(dims)
            write(iunit, fmt='(a)', advance='no') 'Dimensions:  '

            do i = 1, ndims - 1
               write(iunit, fmt='(i0, " - ")', advance='no') dims(i)
            enddo
            write(iunit, fmt='(i0)') dims(ndims)

      end select
   end subroutine printDims_



   subroutine allocOKMsg_(name, iloc, nbytes)
      character(len = *), intent(in) :: name
      integer(kind = 8), intent(in)  :: iloc
      integer(kind = 8), intent(in), optional :: nbytes

      
      write(iunit, fmt='(3a, i0, ". ")', advance='no') &
         'variable  "', name, '"  allocated. Location in memory:  ', iloc

      if (present(nbytes)) then
         write(iunit, fmt='(a, i0, ".")', advance='no') &
            'Occupancy (bytes):  ', nbytes
         write(iunit, *) ''
      endif
   end subroutine allocOKMsg_


   subroutine allocKOMsg_(name, istat, emsg)
      character(len = *), intent(in) :: name, emsg
      integer, intent(in) :: istat

      write(iunit, fmt='(3a)') &
         '[ERROR] variable  "', name, '"  could not be allocated.'
      write(iunit, fmt='(15x, a, i0, 2a)') &
         'Exit code  ', istat, '. Error message:  ', emsg(1 : len_trim(emsg))
   end subroutine allocKOMsg_



   subroutine wrongDimsRankMsg_()

      write(*, fmt='(5x, "--", a)') &
         '[ERROR]  When allocating NDrank array, dimensions must be passed as 0D/1D-rank array.'
      write(iunit, fmt='(a)') &
         '[ERROR]  When allocating NDrank array, dimensions must be passed as 0D/1D-rank array.'
   end subroutine wrongDimsRankMsg_



   subroutine dimsMismatchMsg_(irank, ndims)
      integer, intent(in) :: irank, ndims

      write(iunit, fmt='( a, 2(i0, a) )') &
         '[ERROR]   Rank and number of dimensions do not match! (', &
         irank, '  vs.  ', ndims, ')'
   end subroutine dimsMismatchMsg_

end module Allocation