! 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
    use dc_trace, only: beginsub, endsub
    implicit none
    type(GT_CONTOURS), intent(out):: result
    type(GT_VARIABLE), intent(in):: var
continue
    call beginsub('gtcontopen')
    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%cint = 0.0
    result%sint = 0.0
    result%base = 0.0
    result%icycle = 0
    result%map = ""
    nullify(result%srange, result%crange)
    nullify(result%levels, result%skiplevels, result%tones)
    call endsub('gtcontopen')
end subroutine

subroutine GtContClose(cont)
    use gtgraph_types, only: GT_CONTOURS
    use gtgraph_generic, only: Close
    use gtdata_generic, only: Close
    use dc_trace, only: beginsub, endsub
    implicit none
    type(GT_CONTOURS), intent(inout):: cont
    call beginsub('gtcontclose')
    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)
    call endsub('gtcontclose')
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
    use dc_trace, only: beginsub, endsub, message
    implicit none
    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
    real:: rtmp
    integer:: stat
continue
    err = .FALSE.
    uc_name = optname
    call toUpper(uc_name)
    call beginsub('gtcontoption', '%c=%c', c1=trim(uc_name), c2=trim(value))
    select case(uc_name)
    case("-SHADE")
        cont%shade = .TRUE.
    case("-NOSHADE")
        cont%shade = .FALSE.
    case("-NOCONT")
        cont%shade = .TRUE.
        cont%contours = .FALSE.
    case("-ANIMATE")
        call message('cont animation enabled')
        cont%animate = .TRUE.
    case("-NEXT")
        if (cont%animate) then
            call slice_next(cont%var, stat=stat)
            err = (stat /= DC_NOERR)
            call message('cont next okay=%y stat=%d', L=(/.not. err/), i=(/stat/))
        else
            err = .TRUE.
        endif
    case("INTERVAL", "INT")
        cont%cint = stod(value)
        cont%sint = cont%cint
    case("CINT")
        cont%cint = stod(value)
    case("SINT")
        cont%sint = 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("-MAP")
        cont%map = "coast_world"
    case("MAP")
        cont%map = value 
    case("-EXCH")
        call option_exch(cont, err)
    case("CRANGE", "CRG")
        call get_array(cont%crange, value)
        if (associated(cont%crange)) then
            if (size(cont%crange) == 1) then
                rtmp = cont%crange(1)
                deallocate(cont%crange)
                allocate(cont%crange(2))
                cont%crange(1:2) = rtmp
            endif
        endif
    case("SRANGE", "SRG")
        call get_array(cont%srange, value)
        if (associated(cont%srange)) then
            if (size(cont%srange) == 1) then
                rtmp = cont%srange(1)
                deallocate(cont%srange)
                allocate(cont%srange(2))
                cont%srange(1:2) = rtmp
            endif
        endif
    case default
        err = .TRUE.
    end select
    call endsub('gtcontoption')
    return

contains

    subroutine option_exch(cont, err)
        use gtgraph_types, only: GT_CONTOURS, GT_AXIS
        use gtdata_generic, only: exch_dim
        use dc_trace, only: beginsub, endsub, message
    implicit none
        type(GT_CONTOURS), intent(inout):: cont
        character(len = *), parameter:: subname &
            & = "GTContOption%%Option_Exch"
        type(GT_AXIS), pointer:: tmp_axis
        logical, intent(out):: err
    continue
        call beginsub(subname)
        tmp_axis => cont%h_axis
        cont%h_axis => cont%v_axis
        cont%v_axis => tmp_axis
        call exch_dim(cont%var, 1, 2, count_compact=.false., err=err)
        call endsub(subname)
    end subroutine

end subroutine

subroutine GTFigBindCont(fig, cont)
    use gtgraph_types, only: GT_FIGURE, GT_CONTOURS
    use gtdata_generic, only: get_attr, inquire
    use dc_string, only: STRING
    use dc_error
    use netcdf_f77, only: NF_ENOMEM
    use dc_trace, only: beginsub, endsub, message
    implicit none
    type(GT_FIGURE), intent(inout):: fig
    type(GT_CONTOURS), intent(inout):: cont
    type(GT_CONTOURS), pointer:: newconts(:)
    character(STRING):: title, units
    integer:: nconts, stat
    !
    call beginsub('gtfigbindcont')
    stat = GT_EFAKE
    if (associated(fig%h_axis)) then
	call message('resource for fig%h_axis may leak')
        cont%h_axis => fig%h_axis
    else
        fig%h_axis => cont%h_axis
    endif
    if (associated(fig%v_axis)) then
	call message('resource for fig%v_axis may leak')
        cont%v_axis => fig%v_axis
    else
        fig%v_axis => cont%v_axis
    endif
    !
    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 = trim(title) // ' [' // trim(units) // ']'
    if (fig%title == "untitled") then
        fig%title = title
    else
        fig%title = trim(fig%title) // ", " // trim(title)
    endif
    if (fig%aspect == 0.0) then
        call get_attr(cont%var, 'gt_graph_aspect_ratio', fig%aspect, &
            default=fig%aspect)
    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')
    call endsub('gtfigbindcont', 'stat=%d', i=(/stat/))
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
    use dc_trace, only: beginsub, endsub
    implicit none
    type(GT_CONTOURS), intent(inout):: cont
    type(GT_FIGURE), intent(in):: parent
    real, pointer:: buffer(:, :)
    character(len = 16):: fmt
continue
    call beginsub('gtcontdraw')
    ! ユーザ空間を確定するために座標軸を描画
    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 DclShadeContour(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)
    if (cont%map /= "") then
        call DclDrawMap(cont%map)
        if (cont%h_axis%upper > 180.0) then
            call DclSetWindow(cont%h_axis%lower - 360.0, &
                & cont%h_axis%upper - 360.0, &
                & cont%v_axis%lower, cont%v_axis%upper)
            call DclSetTransFunction()
            call DclDrawMap(cont%map)
            call DclSetWindow(cont%h_axis%lower, cont%h_axis%upper, &
                & cont%v_axis%lower, cont%v_axis%upper)
            call DclSetTransFunction()
        endif
    endif
    call GTAxesDrawGrid(cont%h_axis, cont%v_axis, parent)
    call endsub('gtcontdraw')
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%srange)) then
            call DclSetShadeLevel(cont%srange(1), cont%srange(2), cont%sint)
        ! デフォルトトーンはどうやってきめるか?
!       else 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%sint)
        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 (associated(cont%levels)) then
            do, i = 1, size(cont%levels)
                call DclSetContourLine(cont%levels(i))
            enddo
        else
            call DclSetContourLevel(buffer, cont%cint)
        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
