!== Memory variable support
!
! Authors::   Yasuhiro MORIKAWA, Eizi TOYODA
! Version::   $Id: gt_mem.f90,v 1.4 2006-10-09 10:35:42 morikawa Exp $
! Tag Name::  $Name: gt4f90io-20080812 $
! Copyright:: Copyright (C) GFD Dennou Club, 2001-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
module gt_mem
  ! いわゆるメモリ変数をサポートします (いまのところ１次元だけ)
  use dc_types, only: STRING, TOKEN, DP

  implicit none

  type attr_chain
    type(attr_chain), pointer:: next
    character(TOKEN):: name
    character, pointer:: cbuf(:)
  end type attr_chain

  type MEM_VARIABLE_ENTRY
    character(TOKEN):: name
    character(TOKEN):: xtype
    real(DP), pointer:: dbuf(:)
    type(attr_chain), pointer:: attr
    type(attr_chain), pointer:: current
  end type MEM_VARIABLE_ENTRY

  type MEM_VARIABLE
    integer:: id
  end type MEM_VARIABLE

  type(mem_variable_entry), allocatable, save, target:: memtab(:)
  private:: memtab

  interface Create
    module procedure MemCreateD
  end interface

  interface Close
    module procedure MemClose
  end interface

  interface Attr_Rewind
    module procedure MemAttrRewind
  end interface

  interface attr_next
    module procedure MemAttrNext
  end interface

  interface attr_true
    module procedure MemAttrTrue
  end interface

  interface del_attr
    module procedure MemAttrDel
  end interface

  interface put_attr
!!$    module procedure memattradd_v
    module procedure memattradd
  end interface

  interface get_attr
    module procedure MemAttrGet
!!$    module procedure MemAttrGetV
  end interface

  private:: memtab_add, memtab_lookup

contains

  integer function memtab_add(var, name) result(stat)
    use dc_error, only: gt_enomem
    type(mem_variable), intent(out):: var
    character(len = *), intent(in):: name
    type(mem_variable_entry), allocatable:: tmptab(:)
    integer:: i, n

    if (.not. allocated(memtab)) then
      allocate(memtab(16), stat=stat)
      if (stat /= 0) then
        stat = gt_enomem
        return
      endif
      do, i = 1, size(memtab)
        memtab(i)%name = ""
        memtab(i)%xtype = ""
        nullify(memtab(i)%dbuf)
        nullify(memtab(i)%attr, memtab(i)%current)
      enddo
    endif
    do, i = 1, size(memtab)
      if (memtab(i)%name == "") then
        stat = 0
        var = mem_variable(i)
        memtab(i)%name = name
        return
      endif
    end do

    n = size(memtab)
    allocate(tmptab(n), stat=stat)
    if (stat /= 0) then
      stat = gt_enomem
      return
    endif
    tmptab(:) = memtab(:)
    deallocate(memtab)
    allocate(memtab(n * 2), stat=stat)
    if (stat /= 0) then
      stat = gt_enomem
      return
    endif
    memtab(1:n) = tmptab(1:n)
    deallocate(tmptab)
    do, i = n + 1, n * 2
      memtab(i)%name = ""
      nullify(memtab(i)%dbuf)
      nullify(memtab(i)%attr, memtab(i)%current)
    enddo

    i = n + 1
    var = mem_variable(i)
    memtab(i)%name = name
  end function memtab_add

  subroutine memcreated(var, url, length, xtype, long_name, overwrite, err)
    type(MEM_VARIABLE), intent(out):: var
    character(*), intent(in):: url
    integer, intent(in):: length
    character(*), intent(in), optional:: xtype, long_name
    logical, intent(in), optional:: overwrite
    logical, intent(out), optional:: err
    type(mem_variable_entry), pointer:: ent
    integer:: stat
  continue
    stat = memtab_add(var, url)
    if (stat /= 0) then
      if (present(err)) err = .true.
      return
    endif
    ent => memtab(var%id)
    if (present(xtype)) then
      ent%xtype = xtype
    else
      ent%xtype = "real"
    endif
    allocate(ent%dbuf(length))
    nullify(ent%attr, ent%current)
    if (present(long_name)) call memattradd(var, "long_name", long_name)
    if (present(err)) err = .false.
  end subroutine memcreated

  integer function memtab_lookup(var, ent) result(stat)
    use netcdf_f77, only: nf_enotvar, nf_noerr
    type(mem_variable), intent(in):: var
    type(mem_variable_entry), pointer:: ent
    if (.not. allocated(memtab)) goto 999
    if (var%id <= 0 .or. var%id > size(memtab)) goto 999
    if (memtab(var%id)%name == "") goto 999
    ent => memtab(var%id)
    stat = 0
999 continue
    nullify(ent)
    stat = nf_enotvar
  end function memtab_lookup

  subroutine memclose(var)
    type(mem_variable), intent(in):: var
    type(mem_variable_entry), pointer:: ent
    if (memtab_lookup(var, ent) /= 0) return
    deallocate(ent%dbuf)
    if (associated(ent%attr)) deallocate(ent%attr)
    if (associated(ent%current)) deallocate(ent%current)
    ent%name = ""
  end subroutine memclose

  subroutine MemAttrGet(var, name, value, err)
    use dc_error, only: StoreError
    use netcdf_f77, only: nf_enotatt, nf_noerr
    type(mem_variable), intent(in):: var
    character(len = *), intent(in):: name
    character(len = *), intent(out):: value
    logical, intent(out), optional:: err
    type(mem_variable_entry), pointer:: ent
    type(attr_chain), pointer:: p
    integer:: i, stat
    stat = memtab_lookup(var, ent)
    if (stat == nf_noerr) then
      if (associated(ent%current)) then
        p => ent%current
        if (p%name == name) goto 100
      endif
      p => ent%attr
      do
        if (.not. associated(p)) exit
        if (p%name == name) goto 100
        p => p%next
      enddo
      stat = nf_enotatt
    endif
    call StoreError(stat, "MemAttrGet", err, cause_c=name)
    return

100 continue
    if (associated(p%cbuf)) then
      do, i = 1, len(value)
        value(i:i) = p%cbuf(i)
      enddo
    else
      value = ""
    endif

  end subroutine MemAttrGet

!  subroutine MemAttrGetV(var, name, value, err)
!    use dc_error
!    use dc_string, only: vstring, assignment(=), operator(==), len
!    use netcdf_f77, only: nf_enotatt, nf_noerr
!    type(mem_variable), intent(in):: var
!    character(len = *), intent(in):: name
!    type(vstring), intent(out):: value
!    logical, intent(out), optional:: err
!    type(mem_variable_entry), pointer:: ent
!    type(attr_chain), pointer:: p
!    integer:: i, stat
!    stat = memtab_lookup(var, ent)
!    if (stat == nf_noerr) then
!      if (associated(ent%current)) then
!        if (ent%current%name == name) then
!          p => ent%current
!          goto 100
!        endif
!      endif
!      p => ent%attr
!      do
!        if (.not. associated(p)) exit
!        if (p%name == name) goto 100
!        p => p%next
!      enddo
!      stat = nf_enotatt
!    endif
!    call StoreError(stat, "MemAttrGet", err, cause_c=name)
!    return
!
!100 continue
!    if (associated(p%cbuf)) then
!      do, i = 1, len(value)
!        value = p%cbuf(:)
!      enddo
!    else
!      value = ""
!    endif
!    call StoreError(nf_noerr, "MemAttrGet", err)
!    return
!
!  end subroutine MemAttrGetV

  subroutine MemAttrDel(var, name, err)
    use dc_error, only: StoreError
    use netcdf_f77, only: NF_ENOTATT, nf_noerr
    type(MEM_VARIABLE), intent(in):: var
    character(len = *), intent(in):: name
    logical, intent(out), optional:: err
    type(mem_variable_entry), pointer:: ent
    type(attr_chain), pointer:: p, prev
    integer:: stat
    stat = memtab_lookup(var, ent)
    if (stat /= nf_noerr) goto 999
    nullify(prev)
    p => ent%attr
    do
      if (.not. associated(p)) exit
      if (p%name == name) then
        if (associated(p%cbuf)) deallocate(p%cbuf)
        prev%next => p%next
        deallocate(p)
        call StoreError(nf_noerr, "MemAttrDel", err)
        return
      endif
      prev => p
      p => p%next
    enddo
    stat = nf_enotatt
999 continue
    call StoreError(stat, "MemAttrDel", err, cause_c=name)
  end subroutine MemAttrDel

  logical function MemAttrTrue(var, name, default) result(result)
    use dc_string, only: str_to_logical
    use netcdf_f77, only: nf_noerr
    type(MEM_VARIABLE), intent(in):: var
    character(len = *), intent(in):: name
    logical, intent(in), optional:: default
    type(mem_variable_entry), pointer:: ent
    type(attr_chain), pointer:: p
    character(10):: s
    integer:: stat, i

    stat = memtab_lookup(var, ent)
    if (stat /= nf_noerr) goto 999
    p => ent%attr
    do
      if (.not. associated(p)) exit
      if (p%name == name) then
        if (associated(p%cbuf)) then
          s = ""
          do, i = 1, min(len(s), size(p%cbuf))
            s(i:i) = p%cbuf(i)
          enddo
          result = str_to_logical(s)
        else
          exit
        endif
        return
      endif
      p => p%next
    enddo
999 continue
    result = .false.
    if (present(default)) result = default
    return
  end function MemAttrTrue

  subroutine memAttrRewind(var)
    use netcdf_f77, only: nf_noerr
    type(MEM_VARIABLE), intent(in):: var
    type(mem_variable_entry), pointer:: ent

    if (memtab_lookup(var, ent) /= nf_noerr) return
    nullify(ent%current)
  end subroutine memAttrRewind

  subroutine memAttrNext(var, name, err)
    use netcdf_f77, only: nf_noerr
    type(MEM_VARIABLE), intent(in):: var
    character(len = *), intent(out):: name
    logical, intent(out), optional:: err
    type(mem_variable_entry), pointer:: ent

    if (memtab_lookup(var, ent) /= nf_noerr) goto 999
    if (.not. associated(ent%current)) then
      ent%current => ent%attr
    else
      ent%current => ent%current%next
    endif
    if (.not. associated(ent%current)) goto 999
    name = ent%current%name
    if (present(err)) err = .false.
    return
        !
999 continue
    if (present(err)) err = .true.
  end subroutine memAttrNext

  subroutine memattradd(var, attrname, attrval)
    use netcdf_f77, only: nf_noerr, nf_enotatt
    type(MEM_VARIABLE), intent(in):: var
    character(*), intent(in):: attrname
    character(*), intent(in):: attrval
    type(mem_variable_entry), pointer:: ent
    type(attr_chain), pointer:: p
    integer:: i, stat

    stat = memtab_lookup(var, ent)
    if (stat == nf_noerr) then
      if (associated(ent%current)) then
        if (ent%current%name == attrname) then
          p => ent%current
          goto 100
        endif
      endif
      p => ent%attr
      do
        if (.not. associated(p)) exit
        if (p%name == attrname) goto 100
        p => p%next
      enddo
      stat = nf_enotatt
    endif
    allocate(p)
    nullify(p%next)
    goto 120

100 continue
    if (associated(p%cbuf)) then
      deallocate(p%cbuf)
    endif

120 continue
    allocate(p%cbuf(len(attrval)))
    do, i = 1, len(attrval)
      p%cbuf(i) = attrval(i:i)
    enddo
    return
  end subroutine memattradd

!!$  subroutine memattradd_v(var, attrname, attrval)
!!$    use netcdf_f77, only: nf_noerr, nf_enotatt
!!$    use dc_string
!!$    type(MEM_VARIABLE), intent(in):: var
!!$    character(*), intent(in):: attrname
!!$    type(vstring), intent(in):: attrval
!!$    type(mem_variable_entry), pointer:: ent
!!$    type(attr_chain), pointer:: p
!!$    integer:: stat
!!$
!!$    stat = memtab_lookup(var, ent)
!!$    if (stat == nf_noerr) then
!!$      if (associated(ent%current)) then
!!$        if (ent%current%name == attrname) then
!!$          p => ent%current
!!$          goto 100
!!$        endif
!!$      endif
!!$      p => ent%attr
!!$      do
!!$        if (.not. associated(p)) exit
!!$        if (p%name == attrname) goto 100
!!$        p => p%next
!!$      enddo
!!$      stat = nf_enotatt
!!$    endif
!!$    allocate(p)
!!$    nullify(p%next)
!!$    goto 120
!!$
!!$100 continue
!!$    if (associated(p%cbuf)) then
!!$      deallocate(p%cbuf)
!!$    endif
!!$
!!$120 continue
!!$    allocate(p%cbuf(len(attrval)))
!!$    p%cbuf(:) = attrval
!!$    return
!!$  end subroutine memattradd_v


end module gt_mem