! 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: GOpen => 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 GOpen(result%h_axis, var, 1)
    call GOpen(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: GClose => 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 GClose(cont%h_axis)
    call GClose(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, GT_AXIS
    use gtdata_generic, only: Get, get_attr
    use dcl
    use dc_trace, only: beginsub, endsub
    use dc_string
    use gtgraph_drawparam
    implicit none
    type(GT_CONTOURS), intent(inout):: cont
    type(GT_FIGURE), intent(in):: parent
    real, pointer:: buffer(:, :)
    real, pointer:: buffer1(:, :)
    character(len = 16):: fmt
    character(token):: topology

continue
    call beginsub('gtcontdraw')
    ! ユーザ空間を確定するために座標軸を描画
    call Draw(cont%h_axis, cont%v_axis, parent, set_space=.TRUE.)
    ! データの取得と描画
    call Get(cont%var, buffer)

   ! 周期的座標の処理. データ格子点を最後に一つ追加. 
    call get_attr(cont%h_axis%var, "topology", topology)
    if ( topology == "circular" ) then
       allocate(buffer1(size(buffer,1)+1,size(buffer,2)))
       buffer1(1:size(buffer,1),:) = buffer
       buffer1(size(buffer,1)+1,:) = buffer(1,:)
       deallocate(buffer)
       allocate(buffer(size(buffer1,1),size(buffer1,2)))
       buffer = buffer1
       deallocate(buffer1)
    endif

   ! 周期的座標の処理. データ格子点を最後に一つ追加.
    call get_attr(cont%v_axis%var, "topology", topology) ! added by S.Takehiro
    if ( topology == "circular" ) then               ! added by S.Takehiro
       allocate(buffer1(size(buffer,1),size(buffer,2)+1))
       buffer1(:,1:size(buffer,2)) = buffer
       buffer1(:,size(buffer,2)+1) = buffer(:,1)
       deallocate(buffer)
       allocate(buffer(size(buffer1,1),size(buffer1,2)))
       buffer = buffer1
       deallocate(buffer1)
    endif
    if (cont%shade) then
        call set_shade_levels
        call DclShadeContour(buffer)
        call draw_tonescale
    endif
    if (cont%contours) then
        ! コンターレベルを設定する前にデフォルト書式を決める
        call make_label_format(fmt, hi=maxval(buffer), lo=minval(buffer))
        call DclSetContourLabelFormat(fmt) 
        call set_contour_levels()
        call DclSetParmEX('CONTOUR:RSIZET',&
                           gt_contour_contour_msg_height)
        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 if (associated(cont%crange)) then
            call DclSetContourLevel(cont%crange(1), cont%crange(2), cont%cint)
        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

    ! トーンスケール描画ルーチン(2002/09/24 S.Takehiro)
    ! gt3-dcl5 を移植し Fortran90 スタイルに変更 
    !
    subroutine draw_tonescale

      integer, parameter :: LABELLEN=10
      character(len=LABELLEN), dimension(:), allocatable :: hlabel  ! ラベル文字列
      real, dimension(:), allocatable   :: ux1, ux2       ! メモリ位置(小,大)
      real, dimension(4)                :: upx, upy       ! トーン塗用四辺形座標

      ! 作業用変数
      integer :: ipat, itonl, itint
      real    :: tlev1,tlev2 
      integer :: it, il
      real    :: vmiss

      ! 正規化変換パラメターセーブ変数
      integer :: itr, nton                       
      real :: vxmin,vxmax,vymin,vymax
      real :: uxmin,uxmax,uymin,uymax
      real :: radi,vxoff,vyoff
      real :: longitude,latitude,rotation
      real :: roffxb

      ! ---- 正規化変換セーブ ----
      itr = DCLGetTransNumber()
      call DCLGetViewPort(vxmin,vxmax,vymin,vymax)
      select case (itr)
      case(1:4)
         call DCLGetWindow(uxmin,uxmax,uymin,uymax)
      case(5:6)
         call DCLGetSimilarity(radi,vxoff,vyoff)
      case(10:33)
         call DCLGetMapProjectionAngle(longitude,latitude,rotation)
      end select
      call UZPGET('ROFFXB',roffxb)   !" 座標軸からのラベルの距離(DCL 内部変数)

 !" 座標軸からのラベルの距離をセーブ

      ! ---- トーンスケール用正規化変換設定 ----
      nton = DCLGetShadeLevelNumber()             !" トーンレベル数
      itonl = min(gt_contour_tonescale_labelnum,nton+1)
      call DCLSetViewPort( &
            gt_contour_tonescale_vyloc, &
            gt_contour_tonescale_vxloc+gt_contour_tonescale_vxwidth, &
            gt_contour_tonescale_vyloc, &
            gt_contour_tonescale_vyloc+gt_contour_tonescale_vywidth )
      call DCLSetWindow( 1.0, real(nton+1), 0.0, 1.0 )
      call DCLSetTransNumber(1)
      call DCLSetTransFunction()
      call UZPSET('ROFFXB',0.0)      !" 座標軸からのラベルの距離(DCL 内部変数)

      ! ---- スケール描画 ----
      upy = (/ 0.0, 1.0, 1.0, 0.0/)
      do it=1,nton
         upx = (/it, it, it+1, it+1/)
         call DCLGetShadeLevel(it,tlev1,tlev2,ipat)
         call DCLShadeRegion(upx,upy,ipat)
      enddo

      ! ---- スケール目盛 ----
      call DCLSetParmEX('AXIS:RSIZEL1', &
                        gt_contour_tonescale_labelheit)  ! ラベル文字高さ設定
      call DCLSetParmEX('AXIS:INNER',1)                    ! 内向きに目盛を打つ

      allocate(ux1(nton+1))
      ux1 = (/(real(it),it=1,nton+1)/)

      allocate(ux2(itonl),hlabel(itonl))
      ux2 (1) = 1.0
      call DCLGetParm('GLOBAL:RMISS',vmiss)
      call DCLGetShadeLevel(1,tlev1,tlev2,ipat)
      if ( tlev1 .ne. vmiss ) then
         call chval( 'D', tlev1, hlabel(1) )
      else
         hlabel(1) = '-'//char(189)                            ! -∞
      endif

      il = 1
      itint = nton/itonl + 1
      do it = itint+1, nton-itint+1, itint
         il = il + 1
         ux2( il ) = real( it )
         call DCLGetShadeLevel( it, tlev1, tlev2, ipat )
         call chval( 'D', tlev1, hlabel(il) )
      enddo

      il = il + 1
      ux2 ( il ) = real( nton+1 )
      call DCLGetShadeLevel( nton, tlev1, tlev2, ipat )
      if ( tlev2 .ne. vmiss ) then
         call chval  ( 'D', tlev2, hlabel(IL) )
      else
         hlabel(il) = char(189)                                ! ∞
      endif

      call UXAXLB( 'B', UX1, NTON+1, UX2, HLABEL, LABELLEN, size(ux2) ) ! 目盛描画
      deallocate(ux1,ux2,hlabel)

     ! ---- 正規化変換を戻す ----
      call DCLSetViewPort(vxmin,vxmax,vymin,vymax)
      select case (itr)
      case(1:4)
         call DCLSetWindow(uxmin,uxmax,uymin,uymax)
      case(5:6)
         call DCLSetSimilarity(radi,vxoff,vyoff)
      case(10:33)
         call DCLSetMapProjectionAngle(longitude,latitude,rotation)
      end select
      call DCLSetTransNumber(itr)
      call DCLSetTransFunction()
      call UZPSET('ROFFXB',roffxb)   !" 座標軸からのラベルの距離(DCL 内部変数)

    end subroutine draw_tonescale

end subroutine

