! gtool_history.f90 - traditional interface for `history' output
! vi: set sw=4 ts=8: 
! Copyright (C) GFD Dennou Club, 2000.  All rights reserved.

module gtool_history

    use gtdata_types
    implicit none

    private
    public:: GT_HISTORY
    public:: HistoryCreate, HistoryAddVariable, HistoryClose
    public:: HistoryPutEx, HistoryPut, HistoryAddAttr

    interface HistoryPut
        module procedure HistoryPut1, HistoryPut2, HistoryPut3
        module procedure HistoryPutDouble1, HistoryPutDouble2, HistoryPutDouble3
    end interface

    interface HistoryAddAttr
        module procedure HistoryAddAttrC, HistoryAddAttrS
        module procedure HistoryAddAttrL
        module procedure HistoryAddAttrR, HistoryAddAttrRA
        module procedure HistoryAddAttrD, HistoryAddAttrDA
        module procedure HistoryAddAttrI, HistoryAddAttrIA
    end interface

    type GT_HISTORY
        type(GT_VARIABLE), pointer:: dimvars(:)
        logical, pointer:: dim_value_written(:)
        integer:: unlimited_index
        type(GT_VARIABLE), pointer:: vars(:)
        real:: origin, interval
        integer, pointer:: count(:)
    end type

    type(GT_HISTORY), save, target:: default

contains

    subroutine HistoryCreate(file, title, source, institution, &
        & dims, dimsizes, longnames, units, origin, interval, &
        & xtypes, history)
        use gtdata_generic
        use dc_url
        use dc_error
        use dc_string
        implicit none
            character(len=*), intent(in):: file
        character(len=*), intent(in):: title, source, institution
        character(len=*), intent(in):: dims(:)
        integer, intent(in):: dimsizes(:)
        character(len=*), intent(in):: longnames(:)
        character(len=*), intent(in):: units(:)
        real, intent(in):: origin, interval
        character(len=*), intent(in), optional:: xtypes(:)
        type(GT_HISTORY), intent(out), optional, target:: history
        integer:: numdims, i
        type(GT_HISTORY), pointer:: hst
        character(len = 80):: my_xtype
        type(VSTRING):: x_inst, merged
    continue
        if (present(history)) then
            hst => history
        else
            hst => default
        endif
        numdims = size(dims)
        if (size(dimsizes) /= numdims .or. size(longnames) /= numdims .or. &
            & size(units) /= numdims) then
            call StoreError(GT_EARGSIZEMISMATCH, "HistoryCreate")
            return
        endif

        ! 次元変数表作成
        allocate(hst%dimvars(numdims), hst%dim_value_written(numdims))
        hst%dim_value_written(:) = .FALSE.
        hst%unlimited_index = 0

        my_xtype = ""
        do, i = 1, numdims
            if (present(xtypes)) my_xtype = xtypes(i)
            merged = UrlMerge(file=trim(file), var=trim(dims(i)))
            call Create(hst%dimvars(i), &
                & vchar(merged, len(merged)), &
                & dimsizes(i), xtype=trim(my_xtype), overwrite=.TRUE.)
            call put_attr(hst%dimvars(i), '+title', title)
            call put_attr(hst%dimvars(i), '+source', source)
            if (institution /= "") then
                x_inst = institution
            else
                x_inst = "a gtool_history (by GFD Dennou Club) user"
            endif
            call put_attr(hst%dimvars(i), '+institution', x_inst)
            call put_attr(hst%dimvars(i), 'long_name', trim(longnames(i)))
            call put_attr(hst%dimvars(i), 'units', trim(units(i)))
            if (dimsizes(i) == 0) hst%unlimited_index = i
        enddo

        ! 変数表
        nullify(hst%vars)

        ! 時間カウンタ
        hst%origin = origin
        hst%interval = interval
        hst%count = 0
    end subroutine

    subroutine HistoryAddAttrC(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        character(len = *), intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrS(varname, attrname, value, history)
        use dc_string, only: VSTRING    
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        type(VSTRING), intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrL(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        logical, intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrR(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        real, intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/))
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, (/value/))
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrRA(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        real, intent(in):: value(:)
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrD(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        double precision, intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/))
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, (/value/))
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrDA(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        double precision, intent(in):: value(:)
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrI(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        integer, intent(in):: value
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/))
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, (/value/))
            endif
        endif
     end subroutine

    subroutine HistoryAddAttrIA(varname, attrname, value, history)
        use gtdata_generic, only: Put_Attr
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: attrname
        integer, intent(in):: value(:)
        type(GT_HISTORY), target, optional:: history
         type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        integer:: v_ord
    continue
         ! 操作対象決定
         if (present(history)) then
             hst => history
         else
             hst => default
         endif
        if (varname == "") then
            ! とりあえず無駄だが大域属性を何度もつける
            do, v_ord = 1, size(hst%vars)
                call Put_Attr(hst%vars(v_ord), "+" // attrname, value)
            enddo
        else
                 var = lookup_variable(hst, varname, ord=v_ord)
            if (v_ord /= 0) then
                call Put_Attr(hst%vars(v_ord), attrname, value)
            endif
        endif
     end subroutine

    subroutine HistoryAddVariable(varname, dims, longname, units, xtype, history)
        use dc_string
        use gtdata_generic
        use dc_url
        implicit none
        character(len = *), intent(in):: varname
        character(len = *), intent(in):: dims(:)
        character(len = *), intent(in):: longname, units
        character(len = *), intent(in), optional:: xtype
        type(GT_HISTORY), intent(inout), optional, target:: history
        type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE), pointer:: vwork(:), dimvars(:)
        type(VSTRING):: fullname, time_name, url
        integer, pointer:: count_work(:)
        integer:: nvars, numdims, i
        logical:: ok
    continue
        ! 操作対象決定
        if (present(history)) then
            hst => history
        else
            hst => default
        endif

        ! 変数表拡張
        if (associated(hst%vars)) then
            nvars = size(hst%vars(:))
            vwork => hst%vars
            count_work => hst%count
            nullify(hst%vars, hst%count)
            allocate(hst%vars(nvars + 1), hst%count(nvars + 1))
            hst%vars(1:nvars) = vwork(1:nvars)
            hst%count(1:nvars) = count_work(1:nvars)
            deallocate(vwork, count_work)
        else
            allocate(hst%vars(1), hst%count(1))
        endif
        nvars = size(hst%vars(:))

        ! 変数添字次元を決定
        numdims = size(dims(:))
        allocate(dimvars(numdims))
        do, i = 1, numdims
            dimvars(i) = lookup_dimension(hst, dims(i))
        enddo

        ! 変数作成
        call Inquire(hst%dimvars(1), url=url)
        fullname = UrlResolve(var_str('@' // trim(varname)), url)
        call Create(hst%vars(nvars), vchar(fullname, len(fullname)), &
            & dimvars, xtype=xtype)
        if (hst%unlimited_index /= 0) then
            call Inquire(hst%dimvars(hst%unlimited_index), name=time_name)
            call Slice(hst%vars(nvars), hst%unlimited_index, start=1, count=1, stride=1)
        endif
        call put_attr(hst%vars(nvars), 'long_name', longname)
        call put_attr(hst%vars(nvars), 'units', units)
        hst%count(nvars) = 0
        deallocate(dimvars)
    end subroutine

    subroutine HistoryPutEx(varname, array, arraysize, history)
        use gtdata_generic
        character(len = *), intent(in):: varname
        integer, intent(in):: arraysize
        real, intent(in):: array(arraysize)
        type(GT_HISTORY), intent(inout), optional, target:: history
        type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        logical:: err
        integer:: v_ord, d_ord
        integer, pointer:: time
    continue
        if (present(history)) then
            hst => history
        else
            hst => default
        endif
        var = lookup_variable(hst, varname, ord=v_ord)
        if (v_ord == 0) then
              var = lookup_dimension(hst, varname, ord=d_ord)
            hst%dim_value_written(d_ord) = .TRUE.
        else if (hst%unlimited_index /= 0) then
              time => hst%count(v_ord)
            time = time + 1
            call Slice(var, hst%unlimited_index, start=time)
        endif
        call Put(var, array, arraysize, err)
        if (err) call DumpError()
    end subroutine

    subroutine HistoryPut1(varname, array, history)
        character(len = *), intent(in):: varname
        real, intent(in):: array(:)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutEx(varname, array, size(array), history)
    end subroutine

    subroutine HistoryPut2(varname, array, history)
        character(len = *), intent(in):: varname
        real, intent(in):: array(:, :)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutEx(varname, array, size(array), history)
    end subroutine

    subroutine HistoryPut3(varname, array, history)
        character(len = *), intent(in):: varname
        real, intent(in):: array(:, :, :)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutEx(varname, array, size(array), history)
    end subroutine

    subroutine HistoryPutExDouble(varname, array, arraysize, history)
        use gtdata_generic
        character(len = *), intent(in):: varname
        integer, intent(in):: arraysize
        double precision, intent(in):: array(arraysize)
        type(GT_HISTORY), intent(inout), optional, target:: history
        type(GT_HISTORY), pointer:: hst
        type(GT_VARIABLE):: var
        logical:: err
        integer:: v_ord, d_ord
        integer, pointer:: time
    continue
        if (present(history)) then
            hst => history
        else
            hst => default
        endif
        var = lookup_variable(hst, varname, ord=v_ord)
        if (v_ord == 0) then
              var = lookup_dimension(hst, varname, ord=d_ord)
            hst%dim_value_written(d_ord) = .TRUE.
        else if (hst%unlimited_index /= 0) then
              time => hst%count(v_ord)
            time = time + 1
            call Slice(var, hst%unlimited_index, start=time)
        endif
        call Put(var, array, arraysize, err)
        if (err) call DumpError()
    end subroutine

    subroutine HistoryPutDouble1(varname, array, history)
        character(len = *), intent(in):: varname
        double precision, intent(in):: array(:)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutExDouble(varname, array, size(array), history)
    end subroutine

    subroutine HistoryPutDouble2(varname, array, history)
        character(len = *), intent(in):: varname
        double precision, intent(in):: array(:, :)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutExDouble(varname, array, size(array), history)
    end subroutine

    subroutine HistoryPutDouble3(varname, array, history)
        character(len = *), intent(in):: varname
        double precision, intent(in):: array(:, :, :)
        type(GT_HISTORY), intent(inout), optional, target:: history
    continue
        call HistoryPutExDouble(varname, array, size(array), history)
    end subroutine

    subroutine HistoryClose(history)
        use gtdata_generic
        type(GT_HISTORY), intent(inout), optional, target:: history
        type(GT_HISTORY), pointer:: hst
        integer:: i
    continue
        if (present(history)) then
            hst => history
        else
            hst => default
        endif
        do, i = 1, size(hst%dimvars)
            if (.not. hst%dim_value_written(i)) &
                call set_fake_dim_value(hst, i)
            call Close(hst%dimvars(i))
        enddo
        deallocate(hst%dimvars)
        do, i = 1, size(hst%vars)
            call Close(hst%vars(i))
        enddo
        deallocate(hst%vars, hst%count)
    end subroutine

    subroutine set_fake_dim_value(history, dimord)
        use gtdata_generic
        use dc_error
        type(GT_HISTORY), intent(inout):: history
        integer, intent(in):: dimord
        integer:: length, i
        real, allocatable:: value(:)
        logical:: err
    continue
        if (dimord == history%unlimited_index) then
            length = maxval(history%count(:))
        else
            call Inquire(history%dimvars(dimord), size=length)
        endif
        allocate(value(length))
        value(:) = (/(real(i), i = 1, length)/)
        if (dimord == history%unlimited_index) then
            value(:) = history%origin + (value(:) - 1.0) * history%interval
            call Slice(history%dimvars(dimord), 1, start=1, count=length)
        endif

          call Put(history%dimvars(dimord), value, size(value), err)
        if (err) call DumpError
        deallocate(value)
    end subroutine

    type(GT_VARIABLE) &
    function lookup_variable(history, varname, ord) result(result)
        use dc_string
        use gtdata_generic
        type(GT_HISTORY), intent(in):: history
        character(len = *):: varname
        integer, intent(out), optional:: ord
        type(VSTRING):: name
        integer:: i
    continue
        if (associated(history%vars)) then
            do, i = 1, size(history%vars)
                call Inquire(history%vars(i), name=name)
                if (name == varname) then
                    result = history%vars(i)
                    if (present(ord)) ord = i
                    return
                endif
            enddo
        endif
        if (present(ord)) then
            ord = 0
        else
            print *, 'gtool_history: var lookup for ', varname, ' failed'
            stop
        endif
    end function

    type(GT_VARIABLE) &
    function lookup_dimension(history, dimname, ord) result(result)
        use gtdata_generic
        use dc_string
        type(GT_HISTORY), intent(in):: history
        character(len = *):: dimname
        integer, intent(out), optional:: ord
        type(VSTRING):: name
        integer:: i
    continue
        if (associated(history%dimvars)) then
            do, i = 1, size(history%dimvars)
                call Inquire(history%dimvars(i), name=name)
                if (name == dimname) then
                    result = history%dimvars(i)
                    if (present(ord)) ord = i
                    return
                endif
            enddo
        endif
        if (present(ord)) then
            ord = 0
        else
            print *, 'gtool_history: dim lookup for ', dimname, ' failed'
            stop
        endif
    end function

end module
