! netcdf_attribute.f90 - object-oriented netCDF interface (attribute)
! vi: set sw=4:
! Copyright (C) TOYODA Eizi, 2000.  All rights reserved.
!
! 2000-01-11 豊田英司	初版
! 2000-02-22 豊田英司	ようやく安定してコンパイルできるようになった

module netcdf_attribute
    use iso_varying_string
    use netcdf_error
    use netcdf_filename
    use netcdf_file
    use netcdf_v3
    use netcdf_variable
    implicit none

    type NC_ATTRIBUTE
	type(NC_VARIABLE)::		var
	type(VARYING_STRING)::		name
    end type

    interface Attribute
	module procedure NetcdfGlobalAttribute
	module procedure NetcdfVariableAttribute
    end interface

    interface operator(.exists.)
    	module procedure NetcdfAttributeExists
    end interface

    interface operator(.error.)
    	module procedure NetcdfAttributeError
    end interface

    interface Dispose
	module procedure NetcdfAttributeDispose
    end interface

    interface Rename
	module procedure NetcdfAttributeRename
    end interface

    interface Delete
	module procedure NetcdfAttributeDelete
    end interface

    interface Len
	module procedure NetcdfAttributeLength
    end interface

    interface Type
	module procedure NetcdfAttributeType
    end interface

    interface assignment(=)
	module procedure NetcdfAttributePutChar
	module procedure NetcdfAttributePutString
	module procedure NetcdfAttributePutInt
	module procedure NetcdfAttributePutReal
	module procedure NetcdfAttributeCopyVA
	module procedure NetcdfAttributeGetString
	module procedure NetcdfAttributeGetInt
	module procedure NetcdfAttributeGetReal
    end interface


contains

    !
    ! --- コンストラクタ ---
    !
    ! コンストラクタが呼ばれた後も属性が存在するかどうかは不定.
    ! 属性の存在は .exists. 演算子で検査せよ
    !

    function NetcdfGlobalAttribute(file, name) result(result)
	type(NC_ATTRIBUTE)::				result
	type(NC_FILE), intent(in)::			file
	character(len = *), intent(in)::		name
    continue
	result%var = NC_VARIABLE(file, NF_GLOBAL)
	result%name = name
    end function

    function NetcdfVariableAttribute(var, name) result(result)
	type(NC_ATTRIBUTE)::				result
	type(NC_VARIABLE), intent(in)::			var
	character(len = *), intent(in)::		name
    continue
	result%var = var
	result%name = name
    end function

    !
    ! --- デストラクタ --- 
    !

    subroutine NetcdfAttributeDispose(attr)
    	type(NC_ATTRIBUTE), intent(inout)::		attr
    continue
	attr%name = ''
    end subroutine

    !
    ! --- 単項演算子 ---
    !

    logical function NetcdfAttributeError(attr) result(result)
	type(NC_ATTRIBUTE), intent(in)::	attr
    continue
	result = (id(attr%var) < 0) .or. (.error. attr%var%file)
    end function

    logical function NetcdfAttributeExists(attr) result(result)
	type(NC_ATTRIBUTE), intent(in)::	attr
	integer::				status, xid
	type(VARYING_STRING)::			n
    continue
	status = 0
	n = attr%name
	status = nf_inq_attid(id(attr%var%file), id(attr%var), char(n), xid)
	n = ''
	result = (status == NF_NOERR)
    end function

    !
    ! --- 削除 ---
    !

    subroutine NetcdfAttributeDelete(attr, fail)
	type(NC_ATTRIBUTE), intent(inout):: attr
	logical, intent(out), optional:: fail
	integer:: status
	type(VARYING_STRING):: n
    continue
	n = attr%name
	status = nf_del_att(id(attr%var%file), id(attr%var), char(n))
	n = ''
	call NetcdfSaveError(status, 'AttributeDelete', attr%name)
	if (present(fail)) then
	    fail = (status /= NF_NOERR)
	else
	    call NetcdfAssert()
	endif
	call dispose(attr)
    end subroutine

    !
    ! --- 改名 ---
    !

    subroutine NetcdfAttributeRename(attr, newname, fail)
	type(NC_ATTRIBUTE), intent(inout):: attr
	character(len = *), intent(in):: newname
	logical, intent(out), optional:: fail
	integer:: status
	type(VARYING_STRING):: n
    continue
	n = attr%name
	status = nf_rename_att(id(attr%var%file), id(attr%var), &
	    & char(n), newname)
	call NetcdfSaveError(status, 'AttributeRename', n)
	n = ''
	attr%name = newname
	if (present(fail)) then
	    fail = (status /= NF_NOERR)
	else
	    call NetcdfAssert()
	endif
    end subroutine

    !
    ! --- 属性書き出し ---
    !

    subroutine NetcdfAttributePutInt(attr, value)
	type(NC_ATTRIBUTE), intent(inout)::	attr
	integer, intent(in)::			value(:)
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_put_att_int(id(attr%var%file), id(attr%var), &
	    & char(n), NF_INT, size(value), value)
	call NetcdfSaveError(status, 'AttributePutInt', n)
	n = ''
    end subroutine

    subroutine NetcdfAttributePutReal(attr, value)
	type(NC_ATTRIBUTE), intent(inout)::	attr
	real, intent(in)::			value(:)
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_put_att_real(id(attr%var%file), id(attr%var), &
	    & char(n), NF_FLOAT, size(value), value)
	n = ''
	call NetcdfSaveError(status, 'AttributePutReal', attr%name)
    end subroutine

    subroutine NetcdfAttributePutChar(attr, value)
	type(NC_ATTRIBUTE), intent(inout)::	attr
	character(len = *), intent(in)::	value
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_put_att_text(id(attr%var%file), id(attr%var), &
	    & char(n), len(value), value)
	n = ''
	call NetcdfSaveError(status, 'AttributePutChar', attr%name)
    end subroutine

    subroutine NetcdfAttributePutString(attr, value)
	type(NC_ATTRIBUTE), intent(inout)::	attr
	type(VARYING_STRING), intent(in)::	value
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_put_att_text(id(attr%var%file), id(attr%var), &
	    & char(n), len(value), char(value))
	n = ''
	call NetcdfSaveError(status, 'AttributePutString', attr%name)
    end subroutine

    !
    ! --- 属性値転送 ---
    !

    subroutine NetcdfAttributeCopyVA(lhs, rhs)
	type(NC_VARIABLE), intent(inout)::	lhs
	type(NC_ATTRIBUTE), intent(in)::	rhs
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = rhs%name
	status = nf_copy_att(id(rhs%var%file), id(rhs%var), char(n), &
	    & id(lhs%file), id(lhs)) 
	n = ''
	call NetcdfSaveError(status, 'AttributeCopyVA', rhs%name)
    end subroutine

    !
    ! --- 属性に関係する検査 ---
    !

    integer function NetcdfAttributeLength(attr) result(result)
	type(NC_ATTRIBUTE), intent(in)::	attr
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_inq_attlen(id(attr%var%file), id(attr%var), &
	    & char(n), result)
	call NetcdfSaveError(status, 'AttributeLength', n)
	n = ''
    end function

    integer function NetcdfAttributeType(attr) result(result)
	type(NC_ATTRIBUTE), intent(in)::	attr
	integer::				status
	type(VARYING_STRING)::			n
    continue
	n = attr%name
	status = nf_inq_atttype(id(attr%var%file), id(attr%var), &
	    & char(n), result)
	call NetcdfSaveError(status, 'AttributeType', attr%name)
	n = ''
    end function

    !
    ! --- 属性値の入力 ---
    !
    ! * メモリ割付はできないので出力用変数の大きさぶんだけ代入する
    ! * 型の検査はしない
    !

    subroutine NetcdfAttributeGetInt(value, attr)
	integer, intent(out), target::		value(:)
	type(NC_ATTRIBUTE), intent(in)::	attr
	integer, pointer::			buffer(:)
	integer::				status, length
	type(VARYING_STRING)::			n
    continue
	length = len(attr)
	if (length > size(value)) then
	    allocate(buffer(1: length))
	else
	    buffer => value
	endif
	n = attr%name
	status = nf_get_att_int(id(attr%var%file), id(attr%var), &
	    & char(n), buffer)
	call NetcdfSaveError(status, 'AttributeGetInt', n)
	n = ''
	if (length > size(value)) then
	    value(:) = buffer(1: size(value))
	    deallocate(buffer)
	endif
    end subroutine

    subroutine NetcdfAttributeGetReal(value, attr)
	real, intent(out), target::		value(:)
	type(NC_ATTRIBUTE), intent(in)::	attr
	real, pointer::				buffer(:)
	integer::				status, length
	type(VARYING_STRING)::			n
    continue
	length = len(attr)
	if (length > size(value)) then
	    allocate(buffer(1: length))
	else
	    buffer => value
	endif
	n = attr%name
	status = nf_get_att_real(id(attr%var%file), id(attr%var), &
	    & char(n), buffer)
	call NetcdfSaveError(status, 'AttributeGetReal', n)
	n = ''
	if (length > size(value)) then
	    value(:) = buffer(1: size(value))
	    deallocate(buffer)
	endif
    end subroutine

    subroutine NetcdfAttributeGetString(value, attr)
	type(VARYING_STRING), intent(inout)::	value
	type(NC_ATTRIBUTE), intent(in)::	attr
	integer::				status
    continue
	call setbuf(len(attr), attr%name)
	call NetcdfSaveError(status, 'AttributeGetString', attr%name)
	if (status /= NF_NOERR) value = ''
    contains
	subroutine setbuf(nagasa, name)
	    integer::				nagasa
	    type(VARYING_STRING)::		name
	    character(len = nagasa)::		buffer
	continue
	    status = nf_get_att_text(id(attr%var%file), id(attr%var), &
	       & char(name), buffer)
	    value = buffer
	end subroutine
    end subroutine

end module
