c
c     Copyright (c) 1999,2000, Compaq Computer Corporation
c
c     See the file "license.terms" for information on usage and redistribution
c     of this file, and for a DISCLAIMER OF ALL WARRANTIES.
c
c    Subroutine to get zoom information from a plot window
c
      subroutine window_zoom(window_id,
     1           h_win_min, h_win_max, v_win_min, v_win_max,
     2           x1_ndc, x2_ndc, y1_ndc, y2_ndc, linvert,
     3           x1, x2, y1, y2, do_zoom)
      implicit none
c
      integer window_id
      real h_win_min, h_win_max, v_win_min, v_win_max
      real x1_ndc, x2_ndc, y1_ndc, y2_ndc
      real x1, x2, y1, y2
      logical linvert, do_zoom
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, work_ws_type
      integer work_id, input_status,
     1        xform, pet_type, dev_num, data_record(2),
     2        record_buffer_length, err_stat
      real    echo_area(4), box_x(2), box_y(2), tmp, hscl, vscl
c
      if( .NOT. gks_is_open ) return
c
      work_id = lookup_ws_id(window_id)
      if( work_id .eq. PLT$EMPTY_WINDOW_SLOT ) then
c        Bad window id
         call plt$error_message('window_zoom','Bad window id')
         do_zoom = .FALSE.
         return
      endif
c
      hscl = h_win_max - h_win_min
      vscl = v_win_max - v_win_min
      if( hscl .le. 0.0 .or. vscl .le. 0.0 ) then
c        Bad window coordinates
         call plt$error_message('window_zoom','Bad window coordinates')
         do_zoom = .FALSE.
         return
      endif
c
      work_ws_type = ws_struct(work_id)%type
      if( work_ws_type .ne. GKS$K_VSII .and.
     1    work_ws_type .ne. GKS$K_VSII_GPX .and.
     2    work_ws_type .ne. GKS$K_DECWINDOWS .and.
     3    work_ws_type .ne. GKS$K_MOTIF ) then
         call plt$error_message('window_zoom','Not a workstation')
         do_zoom = .FALSE.
         return
      endif
c
      call activate_device_for_zoom(window_id,
     1       0.0, 1.0, 0.0, 1.0,
     2       x1_ndc, x2_ndc, y1_ndc, y2_ndc,
     3       echo_area, err_stat)
c
c     Put locator at initial point
c     Use echo type 2 to get cross hairs
      dev_num = 1
      xform = 1
      pet_type = 2
c     gks$init_locator modifies record_buffer_length.
c     Reset it to expected value.
      record_buffer_length = 0
      call gks$init_locator(work_id, dev_num, 0.5, 0.5,
     1     xform, pet_type, echo_area,
     2     data_record, record_buffer_length)
      call gks$request_locator(work_id, dev_num, input_status,
     1     xform, box_x(1), box_y(1))
      if( input_status .ne. 1 ) then
c        Input was cancelled
         err_stat = PLT$INPUT_CANCELLED
         goto 1000
      endif
c
c     Get upper right corner
c     Use echo type 5 to get rubber band box
      pet_type = 5
      record_buffer_length = 8
      data_record(1) = GKS$K_ACF_POLYLINE
      data_record(2) = GKS$K_ACF_CURRENT
      call gks$init_locator(work_id, dev_num,
     1     box_x(1), box_y(1),
     2     xform, pet_type, echo_area,
     3     data_record, record_buffer_length)
      call gks$request_locator(work_id, dev_num, input_status,
     1     xform, box_x(2), box_y(2))
      if( input_status .ne. 1 ) then
c        Input was cancelled
         err_stat = PLT$INPUT_CANCELLED
         goto 1000
      endif
c
1000  continue
c
c     Deactivate window
      call deactivate_plot_device
      if( err_stat .eq. PLT$INPUT_CANCELLED ) then
         do_zoom = .FALSE.
      else
c        Remember: we are now using a [0,1] world coordinate window
c        to avoid a GKS V5.0 bug, so re-scale to the actual coordinate
c        system.
         x1 = box_x(1)*hscl + h_win_min
         x2 = box_x(2)*hscl + h_win_min
         box_y(1) = box_y(1)*vscl + v_win_min
         box_y(2) = box_y(2)*vscl + v_win_min
         if( linvert ) then
            y2 = (v_win_max+v_win_min) - box_y(1)
            y1 = (v_win_max+v_win_min) - box_y(2)
         else
            y1 = box_y(1)
            y2 = box_y(2)
         endif
c
c        Reorder if user gave the box arse backwards
         if( x1 .gt. x2 ) then
            tmp = x1
            x1 = x2
            x2 = tmp
         endif
         if( y1 .gt. y2 ) then
            tmp = y1
            y1 = y2
            y2 = tmp
         endif
c        Limit to current bounds
         if( x1 .lt. h_win_min ) x1 = h_win_min
         if( x1 .gt. h_win_max ) x1 = h_win_max
         if( x2 .lt. h_win_min ) x2 = h_win_min
         if( x2 .gt. h_win_max ) x2 = h_win_max
         if( y1 .lt. v_win_min ) y1 = v_win_min
         if( y1 .gt. v_win_max ) y1 = v_win_max
         if( y2 .lt. v_win_min ) y2 = v_win_min
         if( y2 .gt. v_win_max ) y2 = v_win_max
         do_zoom = .TRUE.
      endif
c
      return
      end
c
      subroutine activate_device_for_zoom(window_id,
     1           h_win_min, h_win_max, v_win_min, v_win_max,
     2           x1_ndc, x2_ndc, y1_ndc, y2_ndc,
     3           echo_area, err_stat)
      implicit none
c
c     Sets up the window for input from the locator device.
c     A portion of the window is mapped to correspond to the rectangular
c     region used by 2D contour subroutine.
c
c     Subroutine returns echo area of window (entire device).
c
      integer window_id, err_stat
      real    h_win_min, h_win_max, v_win_min, v_win_max, echo_area(4)
      real    x1_ndc, x2_ndc, y1_ndc, y2_ndc
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
c     locals
c
      integer dev_num, error_status, gks_units,
     1        ras_units_x, ras_units_y,
     2        work_id, lookup_ws_id
      real    dev_size_x, dev_size_y, delx1, delx2, dely1, dely2
c
      err_stat = PLT$NORMAL
      work_id = lookup_ws_id(window_id)
      if( work_id .eq. -1 ) then
         err_stat = PLT$BAD_WINDOW_ID
         return
      endif
c
      dev_num = 1
c     Activate window, do not clear it, do not start a segment
      call activate_plot_device(window_id, .false., .false.)
      call init_device_depend
c
c     Map entire window to expanded horizontal/vertical range, so any
c     locator points outside the contour plot area will return
c     a valid world coordinate.
c
c     Note well: ndc values passed in MUST match what are used in the
c     actual plot
      delx1 = x1_ndc*(h_win_max - h_win_min)/(x2_ndc - x1_ndc)
      delx2 = (1.0 - x2_ndc)*(h_win_max - h_win_min)/
     1                          (x2_ndc - x1_ndc)
      dely1 = y1_ndc*(v_win_max - v_win_min)/(y2_ndc - y1_ndc)
      dely2 = (1.0 - y2_ndc)  *(v_win_max - v_win_min)/
     1                            (y2_ndc - y1_ndc)
      call GKS$SET_WINDOW(1,h_win_min-delx1,h_win_max+delx2,
     1                      v_win_min-dely1,v_win_max+dely2)
      call GKS$SET_VIEWPORT(1, 0.0, ratio_x, 0.0, ratio_y)
      call gks$select_xform(1)
      call gks$set_viewport_priority(1,0,
     1     GKS$K_INPUT_PRIORITY_HIGHER)
      call gks$inq_max_ds_size(full_ws_type, error_status, gks_units,
     1         dev_size_x, dev_size_y, ras_units_x, ras_units_y)
      echo_area(1) = 0.0
      echo_area(2) = dev_size_x
      echo_area(3) = 0.0
      echo_area(4) = dev_size_y
      call gks$set_locator_mode(work_id, dev_num,
     1     GKS$K_INPUT_MODE_REQUEST, GKS$K_ECHO)
c
      return
      end

