! Copyright (C) GFD-Dennou Club, 2001.  All rights reserved.


module gt_mem 19,11
    !
    ! いわゆるメモリ変数サポート (いまのところ１次元だけ)

    use dc_types, only: string, token

    implicit none

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

    type MEM_VARIABLE_ENTRY
        character(token):: name
        character(token):: xtype
        double precision, pointer:: dbuf(:)
        type(attr_chain), pointer:: attr
        type(attr_chain), pointer:: current
    end type

    type MEM_VARIABLE
        integer:: id
    end type

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


    interface Create 10
        module procedure MemCreateD
    end interface


    interface Close 40
        module procedure MemClose
    end interface


    interface Attr_Rewind 3
        module procedure MemAttrRewind
    end interface


    interface attr_next 3
        module procedure MemAttrNext
    end interface


    interface attr_true
        module procedure MemAttrTrue
    end interface


    interface del_attr 2
        module procedure MemAttrDel
    end interface


    interface put_attr 47
        module procedure memattradd_v
        module procedure memattradd
    end interface


    interface get_attr 45
        module procedure MemAttrGet
        module procedure MemAttrGetV
    end interface

    private:: memtab_add, memtab_lookup

contains


    integer function memtab_add(var, name) result(stat) 1,1
        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


    subroutine memcreated(var, url, length, xtype, long_name, overwrite, err) 1,3
        use dc_error
        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


    integer function memtab_lookup(var, ent) result(stat) 9,1
        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


    subroutine memclose(var) 1,1
        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


    subroutine MemAttrGet(var, name, value, err) 1,4
        use dc_error
        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


    subroutine MemAttrGetV(var, name, value, err) 1,6
        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


    subroutine MemAttrDel(var, name, err) 1,6
        use dc_error
        use dc_string, only: operator(==)
        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


    logical function MemAttrTrue(var, name, default) result(result) 1,3
        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


    subroutine memAttrRewind(var) 1,2
        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


    subroutine memAttrNext(var, name, err) 1,3
        use dc_string
        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


    subroutine memattradd(var, attrname, attrval) 2,2
        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


    subroutine memattradd_v(var, attrname, attrval) 1,3
        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


end module