! Copyright (C) GFD Dennou Club, 2000.  All rights reserved
! gtcontdefault.f90 - Definitions of Gtool Contours subroutines

subroutine GTContOpen(result, var)
    use gtgraph_types, only: GT_CONTOURS
    use gtgraph_generic, only: Open
    use gtdata_types, only: GT_VARIABLE
    use gtdata_generic, only: Open
    type(GT_CONTOURS), intent(out):: result
    type(GT_VARIABLE), intent(in):: var
    call Open(result%var, var, 0)
    result%contours = .TRUE.
    result%shade = .FALSE.
    result%animate = .FALSE.
    allocate(result%h_axis, result%v_axis)
    call Open(result%h_axis, var, 1)
    call Open(result%v_axis, var, 2)
    ! オプションの初期化
    result%interval = 0.0
    result%base = 0.0
    result%icycle = 0
    nullify(result%levels, result%skiplevels, result%tones)
end subroutine

subroutine GtContClose(cont)
    use gtgraph_types, only: GT_CONTOURS
    use gtgraph_generic, only: Close
    use gtdata_generic, only: Close
    type(GT_CONTOURS), intent(inout):: cont
    if (associated(cont%levels)) deallocate(cont%levels)
    if (associated(cont%skiplevels)) deallocate(cont%skiplevels)
    if (associated(cont%tones)) deallocate(cont%tones)
    call Close(cont%h_axis)
    call Close(cont%v_axis)
    deallocate(cont%h_axis, cont%v_axis)
    call Close(cont%var)
end subroutine

subroutine GtContOption(cont, optname, value, err)
    use gtgraph_types, only: GT_CONTOURS
    use gtdata_generic, only: slice_next
    use dc_string, only: stoi, stod, toUpper, get_array
    use dc_error, only: GT_ENOMOREDIMS, DC_NOERR
    type(GT_CONTOURS), intent(inout):: cont
    character(len = *), intent(in):: optname
    character(len = *), intent(in):: value
    logical, intent(out):: err
    character(len = len(optname)):: uc_name
    integer:: stat
continue
    err = .FALSE.
    uc_name = optname
    call toUpper(uc_name)
    select case(uc_name)
    case("-SHADE")
        cont%shade = .TRUE.
    case("-NOSHADE")
        cont%shade = .FALSE.
    case("-NOCONT")
        cont%shade = .TRUE.
        cont%contours = .FALSE.
    case("-ANIMATE")
        cont%animate = .TRUE.
    case("-NEXT")
        if (cont%animate) then
            call slice_next(cont%var, stat=stat)
            err = (stat /= DC_NOERR)
        else
            err = .TRUE.
        endif
    case("INTERVAL")
        cont%interval = stod(value)
    case("ICYCLE", "LABEL_CYCLE")
        cont%icycle = stoi(value)
    case("LEVELS")
        call get_array(cont%levels, value)
    case("SKIPLEVELS")
        call get_array(cont%skiplevels, value)
    case("TONE", "TONES")
        call get_array(cont%tones, value)
    case default
        err = .TRUE.
    end select
end subroutine

subroutine GTFigBindCont(fig, cont)
    use gtgraph_types, only: GT_FIGURE, GT_CONTOURS
    use gtdata_generic, only: get_attr, inquire
    use dc_string
    use dc_error
    use netcdf_f77, only: NF_ENOMEM
    type(GT_FIGURE), intent(inout):: fig
    type(GT_CONTOURS), intent(in):: cont
    type(GT_CONTOURS), pointer:: newconts(:)
    type(VSTRING):: title, units
    integer:: nconts, stat
    !
    stat = GT_EFAKE
    if (associated(fig%h_axis) .or. associated(fig%v_axis)) goto 999
    fig%h_axis => cont%h_axis
    fig%v_axis => cont%v_axis
    !
    call get_attr(cont%var, 'long_name', title)
    if (title == '') call Inquire(cont%var, name=title)
    call get_attr(cont%var, 'units', units, default='no units')
    title = title // ' [' // units // ']'
    if (fig%title == "untitled") then
        fig%title = title
    else
        fig%title = fig%title // ", " // title
    endif
    if (cont%animate) fig%animate = .TRUE.
    !
    stat = 0
    if (associated(fig%contours)) then
        nconts = size(fig%contours)
        allocate(newconts(nconts + 1), stat=stat)
        newconts(1: nconts) = fig%contours(1: nconts)
        deallocate(fig%contours)
    else
        nconts = 0
        allocate(newconts(1), stat=stat)
    endif
    if (stat /= 0) stat = NF_ENOMEM
    newconts(nconts + 1) = cont
    fig%contours => newconts
999 continue
    call StoreError(stat, 'GTFigPutCont')
end subroutine

subroutine GTContDraw(cont, parent)
    use gtgraph_generic, only: Draw
    use gtgraph_types, only: GT_CONTOURS, GT_FIGURE
    use gtdata_generic, only: Get
    use dcl
    implicit none
    type(GT_CONTOURS), intent(inout):: cont
    type(GT_FIGURE), intent(in):: parent
    real, pointer:: buffer(:, :)
    character(len = 16):: fmt
    ! ユーザ空間を確定するために座標軸を描画
    call Draw(cont%h_axis, cont%v_axis, parent, set_space=.TRUE.)
    ! データの取得と描画
    call Get(cont%var, buffer)
    if (cont%shade) then
        call set_shade_levels
        call DclShadeContourEx(buffer)
    endif
    if (cont%contours) then
        ! コンターレベルを設定する前にデフォルト書式を決める
        call make_label_format(fmt, hi=maxval(buffer), lo=minval(buffer))
        call DclSetContourLabelFormat(fmt) 
        call set_contour_levels()
        call DclDrawContour(buffer)
    endif
    deallocate(buffer)
contains

    subroutine set_shade_levels
        integer:: i, nlevs
        logical, save:: lfirst = .TRUE.
        if (lfirst) then
            call GLLSTX('LEPSL', .TRUE.)
            lfirst = .FALSE.
        endif
        ! デフォルトトーンはどうやってきめるか?
!        if (associated(cont%levels)) then
!            if (.not. associated(cont%tones)) then
!                nlevs = size(cont%levels)
!                allocate(cont%tones(nlevs - 1))
!                cont%tones = (/(i, i = nlevs, 0, -1)/)
!            endif
!            call DclSetShadeLevel(buffer, )
!        else
            call DclSetShadeLevel(buffer, cont%interval)
!        endif
    end subroutine

    subroutine set_contour_levels
        integer:: i, my_icycle
        ! ここでやらなくちゃ
        my_icycle = cont%icycle
        if (my_icycle == 0) my_icycle = 2
        call UDISET("ICYCLE", my_icycle)
        ! いまのところ base は無視
        if (cont%interval /= 0.0 .or. .not. associated(cont%levels)) then
            call DclSetContourLevel(buffer, cont%interval)
        endif
        if (associated(cont%levels)) then
            do, i = 1, size(cont%levels)
                call DclSetContourLine(cont%levels(i))
            enddo
        endif
        if (associated(cont%skiplevels)) then
            do, i = 1, size(cont%skiplevels)
                call DclDelContourLevel(cont%skiplevels(i))
            enddo
        endif
    end subroutine

    ! CHVAL が理解できるような書式仕様を与える。
    ! 本サブルーチンの身勝手な目的は天気図をマトモに描くことにある。
    ! CHVAL は有効数字 3 桁であるが、最大8桁なのだから 5 桁くらい
    ! にはしてくれてもいいじゃないの、というわけである。
    ! 
    subroutine make_label_format(fmt, hi, lo)
        character(len = *), intent(out):: fmt
        real, intent(in):: hi, lo
        real:: order, interval
    continue
        ! デフォルト
        fmt = "D"
        order = max(abs(hi), abs(lo))
        ! ほとんどの場合小さめに見積もってよかろう
        interval = abs(hi - lo) / 100.0
        ! 整数で書けそうならば
        if (interval < 10.0) then
            ! 切捨てが起こる場合書き換えをする
            if (order >= 1000.0 .and. order < 1.0e5) then
                fmt = "(f5.0,tl1,' ')"
            else if (order >= 1.0e5 .and. order < 1.0e6) then
                fmt = "(f6.0,tl1,' ')"
            else if (order >= 1.0e6 .and. order < 1.0e7) then
                fmt = "(f7.0,tl1,' ')"
            endif
        endif
    end subroutine

end subroutine
