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
      subroutine open_plot_device(new_window_id, device_type,
     1                            vs_window_title, return_stat)
      implicit none
c
      integer new_window_id
      integer device_type
      character*(*) vs_window_title
      integer return_stat
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
      include 'defaults.cmn'
c
c     locals
c
      real temp_x, temp_y, temp_ratio_x, temp_ratio_y
      real ws_window_lx, ws_window_ly, ws_window_ux, ws_window_uy
      real ws_viewport_lx, ws_viewport_ly, ws_viewport_ux,
     1     ws_viewport_uy
      real dev_size_x, dev_size_y
      integer rc
      integer ras_units_x, ras_units_y, units, idisplay_len
      integer get_new_ws_id, lookup_ws_id
      integer new_ws_id, new_ws_type, temp_color_or_mono
      integer err_stat, num_colors, num_color_indices
      logical l_portrait
c
      integer gks$open_ws, get_logical_name
      integer ilen, string_len
      character*(MAX_VS_TITLE_LEN) temp_string
      character*256 translated_name, display
c
      return_stat = PLT$NORMAL
c
c     Valid window id?
      if( new_window_id .le. 0 ) then
         return_stat = PLT$BAD_WINDOW_ID
         return
      endif
c
      if( .NOT. gks_is_open ) call open_gks
c
c     If device_type is "generic" (GKS$K_WSTYPE_DEFAULT) then
c     attempt to translate logical GKS$WSTYPE.
c     For this subroutine to work robustly, we must know the exact
c     device type.
c     With this information, we can also do workstation specific opens.
      if( device_type .eq. GKS$K_WSTYPE_DEFAULT ) then
         rc = get_logical_name(PM_GKS_WSTYPE,translated_name)
         if( rc .eq. 0 ) then  ! logical name found
c           convert to integer
c           WSTYPE may be a string of the form
c           %xnnn (hex), %onnn (octal) or %dnnn (decimal)
            ilen = string_len(translated_name)
            if( translated_name(1:2) .eq. '%x' .OR.
     1          translated_name(1:2) .eq. '%X' ) then
               read(translated_name(3:ilen),500,err=100) full_ws_type
500            format(Z<ilen-2>)
            else if( translated_name(1:2) .eq. '%o' .OR.
     1               translated_name(1:2) .eq. '%O' ) then
               read(translated_name(3:ilen),501,err=100) full_ws_type
501            format(O<ilen-2>)
            else if( translated_name(1:2) .eq. '%d' .OR.
     1               translated_name(1:2) .eq. '%D' ) then
               translated_name(1:2) = '  '
               read(translated_name,*,err=100) full_ws_type
            else
               read(translated_name,*,err=100) full_ws_type
            endif
            goto 101
c           Error reading workstation type. Return an error.
100         return_stat = PLT$BAD_DEF_WSTYPE
            return
101         continue
c           Mask out any bit masks in upper word of workstation type
            new_ws_type = IAND(full_ws_type,PM_HEX_FFFF)
         else
c           Logical name not found or an error occurred. Return an error.
            return_stat = PLT$BAD_DEF_WSTYPE
            return
         endif
      else
c        Mask out any bit masks in upper word of workstation type
         new_ws_type = IAND(device_type,PM_HEX_FFFF)
         full_ws_type = device_type
      endif
c
c     Define GKS conid for workstations or terminals, since system defaults
c     may be lacking or really silly.
      if( new_ws_type .eq. GKS$K_DECWINDOWS .or.
     1    new_ws_type .eq. GKS$K_MOTIF ) then
c        Find DISPLAY environment variable
c        First, look for DECW$DISPLAY/DISPLAY
         rc = get_logical_name(PM_X_DISPLAY,translated_name)
         if( rc .ne. 0 .or. string_len(translated_name) .eq. 0 ) then
c           DISPLAY environment variable not there (or all blanks)
c           Try the GKS conid environment variable
            rc = get_logical_name(PM_GKS_CONID,translated_name)
            if( rc .ne. 0 ) then
               return_stat = PLT$BAD_DEF_WSTYPE
               return
            endif
         endif
         display = translated_name
         idisplay_len = string_len(translated_name)
c
      else if( new_ws_type .eq. GKS$K_VT125BW .or.
     1         new_ws_type .EQ. GKS$K_VT240BW .or.
     2         new_ws_type .EQ. GKS$K_VT125   .or.
     3         new_ws_type .EQ. GKS$K_VT240   .or.
     4         new_ws_type .EQ. GKS$K_VT330   .or.
     5         new_ws_type .EQ. GKS$K_VT340   .or.
     6         new_ws_type .EQ. GKS$K_TEK4014 .or.
     7         new_ws_type .EQ. GKS$K_TEK4014_OUTPUT ) then
c        Use tty name for conid
         display = PM_TTY_NAME
         idisplay_len = string_len(display)
      endif
c
c     Is this window already open?
      new_ws_id = lookup_ws_id(new_window_id)
      if( new_ws_id .ne. PLT$EMPTY_WINDOW_SLOT ) then
c        Window id already in use
c        If device types match, then assume we are re-using old window.
c        Else return an error.
         if( new_ws_type .ne. ws_struct(new_ws_id)%type ) then
            return_stat = PLT$WINDOW_INUSE
         endif
         return
      endif
c
c     Can we support another open window?
      new_ws_id = get_new_ws_id(new_window_id)
      if( new_ws_id .eq. -1 ) then  ! Plot window array exhausted
         return_stat = PLT$TOO_MANY_WINDOWS
         return
      endif
c
c     Set bit if we want portrait mode for selected hard copy types
      if( .NOT. hc_is_landscape .and.
     1    ((new_ws_type .eq. GKS$K_POSTSCRIPT) .or.
     2    (new_ws_type .eq. GKS$K_EPSF) .or.
     3    (new_ws_type .eq. GKS$K_COLOR_POSTSCRIPT) .or.
     4    (new_ws_type .eq. GKS$K_COLOR_EPSF) .or.
     5    (new_ws_type .eq. GKS$K_LN03_PLUS) .or.
     6    (new_ws_type .eq. GKS$K_LJ250) .or.
     7    (new_ws_type .eq. GKS$K_LJ250_180DPI) .or.
     8    (new_ws_type .eq. GKS$K_LASERJETII) .or.
     9    (new_ws_type .eq. GKS$K_DDIF)) ) then
         full_ws_type = IOR(full_ws_type,GKS$M_PORTRAIT)
      endif
c
c     Branch on device type
c
      if( new_ws_type .EQ. GKS$K_VT125BW ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VT240BW ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VT125 ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VT240 ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VT330 ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VT340 ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VSII ) then
c        Create a "unique" connection ID (window title name)
c        GKS requires this if we open more than one window at a time.
         ilen = MIN((MAX_VS_TITLE_LEN-2),string_len(vs_window_title))
         write(temp_string,1000) vs_window_title(1:ilen), new_ws_id
1000     format(a,'-',i2)
         ilen = string_len(temp_string)
         rc = gks$open_ws(new_ws_id, temp_string(1:ilen), full_ws_type)
      else if( new_ws_type .EQ. GKS$K_VSII_GPX ) then
c        Create a "unique" connection ID (window title name)
c        GKS requires this if we open more than one window at a time.
         ilen = MIN((MAX_VS_TITLE_LEN-2),string_len(vs_window_title))
         write(temp_string,1000) vs_window_title(1:ilen), new_ws_id
         ilen = string_len(temp_string)
         rc = gks$open_ws(new_ws_id, temp_string(1:ilen), full_ws_type)
      else if( new_ws_type .EQ. GKS$K_DECWINDOWS ) THEN
c        Connection ID is DECwindows display
c        Must be unique, so append ws_id number (converted to
c        non-numeric character)
c        Multiple workstations won't work correctly until VMS V5.2
         display(idisplay_len+1:idisplay_len+1) =
     1           CHAR(new_ws_id + ICHAR('@'))
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len+1),
     1                    full_ws_type)
         if( rc .eq. GKS$_SUCCESS ) then
c           Set window title bar
            ilen = MIN((MAX_VS_TITLE_LEN-2),string_len(vs_window_title))
            write(temp_string,1000) vs_window_title(1:ilen), new_ws_id
            call pm_escape_set_window_title(new_ws_id, temp_string)
         endif
      else if( new_ws_type .EQ. GKS$K_MOTIF ) THEN
c        Connection ID is display variable
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
         if( rc .eq. GKS$_SUCCESS ) then
c           Set window title bar
            ilen = MIN((MAX_VS_TITLE_LEN-2),string_len(vs_window_title))
            write(temp_string,1000) vs_window_title(1:ilen), new_ws_id
            call pm_escape_set_window_title(new_ws_id, temp_string)
         endif
      else if( new_ws_type .EQ. GKS$K_HP7550 ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_POSTSCRIPT ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_COLOR_POSTSCRIPT ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_EPSF ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_COLOR_EPSF ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_LN03_PLUS ) then
         rc = gks$open_ws(new_ws_id, temp_plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_LJ250 ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_LJ250_180DPI ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_TEK4014_OUTPUT .or.
     1         new_ws_type .EQ. GKS$K_TEK4014 ) then
         rc = gks$open_ws(new_ws_id, display(1:idisplay_len),
     1                    full_ws_type)
**         rc = gks$open_ws(new_ws_id, temp_plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_LCG01 ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_DDIF ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else if( new_ws_type .EQ. GKS$K_LASERJETII ) then
         rc = gks$open_ws(new_ws_id, plot_file_name, full_ws_type)
      else
         write(luttyo,110) new_ws_type
110      format(' ','open_plot_device: Warning: unsupported GKS ',
     1              'workstation type: ', i5)
         rc = gks$open_ws(new_ws_id, GKS$K_CONID_DEFAULT, full_ws_type)
      endif
c
c     Did the open suceed?
      if( rc .NE. GKS$_SUCCESS ) then
c        Free window slot, return
         window_dict(new_ws_id) = PLT$EMPTY_WINDOW_SLOT
         return_stat = PLT$GKS_OPEN_FAILED
         return
      endif
c
c     Get device limits (use actual value of ws type, including bit masks)
      call GKS$INQ_MAX_DS_SIZE( full_ws_type, rc, units,
     1            dev_size_x, dev_size_y, ras_units_x, ras_units_y)
c
c     Determine portion of output device we will be using,
c     depending on user scaling/offset
      l_portrait = .NOT. hc_is_landscape
      call pm_get_ws_viewport(new_ws_type,
     1               dev_size_x, dev_size_y,
     2               plot_scale_factor,
     3               hc_xoffset, hc_yoffset,
     4               hc_scale, hc_aspect_ratio,
     5               l_portrait,
     6               ws_viewport_lx, ws_viewport_ly,
     7               ws_viewport_ux, ws_viewport_uy)
c
c     Set up GKS workstation window (NDC space) to maintain aspect ratio
c     of GKS workstation viewport (device space).
c     If an X window is resized, DEC GKS will plot in the new window
c     with the same aspect ratio we asked for originally (Motif workstation).
c     So these values of ratio_x/y will remain valid.
c
      temp_x = ws_viewport_ux - ws_viewport_lx
      temp_y = ws_viewport_uy - ws_viewport_ly
      if( temp_x .gt. temp_y ) then
         temp_ratio_x = 1.0
         temp_ratio_y = temp_y/temp_x
      else
         temp_ratio_x = temp_x/temp_y
         temp_ratio_y = 1.0
      endif
c   
      ws_window_lx = 0.0
      ws_window_ly = 0.0
      ws_window_ux = temp_ratio_x
      ws_window_uy = temp_ratio_y
c   
      call GKS$SET_WS_WINDOW(new_ws_id, ws_window_lx, ws_window_ux,
     1                 ws_window_ly, ws_window_uy)
      call GKS$SET_WS_VIEWPORT(new_ws_id, ws_viewport_lx,
     1     ws_viewport_ux, ws_viewport_ly, ws_viewport_uy)
c
c     Is workstation color or monochrome?
      call GKS$INQ_COLOR_FAC(full_ws_type, err_stat, num_colors,
     1                   temp_color_or_mono, num_color_indices)
c
c     Store workstation specifics into workstation structure
      ws_struct(new_ws_id)%full_type = full_ws_type
      ws_struct(new_ws_id)%type    = new_ws_type
      ws_struct(new_ws_id)%ratio_x = temp_ratio_x
      ws_struct(new_ws_id)%ratio_y = temp_ratio_y
      ws_struct(new_ws_id)%color_or_mono = temp_color_or_mono
c
      ws_open = .TRUE.
C
      return
      end
c
      subroutine activate_plot_device(window_id, clear_flag,
     1                                segment_flag)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      logical clear_flag, segment_flag
c
      integer lookup_ws_id, err_stat
      real viewport_lx, viewport_ly, viewport_ux, viewport_uy
      character*1 ESC, BACKSLASH, CTRLL
      parameter ( ESC = CHAR(27) )
      parameter ( BACKSLASH = CHAR(92) )
      parameter ( CTRLL = CHAR(12) )
c
c     If a device is active, deactivate it and open a new one
      if( ws_active ) call deactivate_plot_device
c
c     Recall workstation specific parameters from workstation struct
      ws_id = lookup_ws_id(window_id)
c     Bad window id, or closed already
      if( ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) return
      full_ws_type = ws_struct(ws_id)%full_type
      ws_type = ws_struct(ws_id)%type
      ratio_x = ws_struct(ws_id)%ratio_x
      ratio_y = ws_struct(ws_id)%ratio_y
      color_or_mono = ws_struct(ws_id)%color_or_mono
c
c     Send ReGIS enter graphics mode for VT330/340 terminals, since we
c     now keep them open, rather than close them after each plot.
c     GKS still thinks the device is in ReGIS mode. We've turned ReGIS
c     mode off after deactivation so we can send ASCII text to the terminal.
      if( ws_type .eq. GKS$K_VT330 .or.
     1    ws_type .eq. GKS$K_VT340 ) then
         write(luttyo,100) ESC
100      format('+',a1,'Pp',$)
      endif
c
c     Emit enter DECTEK sequence for 4014 emulation (xterm)
      if( ws_type .eq. GKS$K_TEK4014 .or.
     1    ws_type .eq. GKS$K_TEK4014_OUTPUT ) then
         write(luttyo,101) ESC
101      format('+',a1,'[?38h',$)
      endif
c   
      call gks$activate_ws(ws_id)
c
c     Update transformation 1 
c
      viewport_lx = 0.0
      viewport_ly = 0.0
      viewport_ux = ratio_x
      viewport_uy = ratio_y
      call GKS$SET_VIEWPORT(1, viewport_lx, viewport_ux,
     1                 viewport_ly, viewport_uy)
c     Make transformations current 
      call GKS$SELECT_XFORM( 1 )
      if( clear_flag ) then
c         
c        Clear ws also removes any segments associated with this workstation.
c        Since we use only one segment per workstation, the segment
c        is implicitly deleted. This also gets around a bug in GKS V3
c        where delete segment doesn't delete memory.
         call GKS$CLEAR_WS(ws_id, GKS$K_CLEAR_CONDITIONALLY)
c
c        Reset color map to default
         call set_default_colormap
c
c        Due to a bug/feature in ReGIS emulation in DECterm's on 24-plane
c        systems, the above clear/set color sequence causes the screen
c        to go all black. The ever so kind Andy Vesper suggested the
c        following workaround.
         if( ws_type .eq. GKS$K_VT330 .or.
     1       ws_type .eq. GKS$K_VT340 ) then
            call GKS$CLEAR_WS(ws_id, GKS$K_CLEAR_ALWAYS)
         endif
c
c        The GKS graphics handler doesn't seem to clear the screen
c        the very first time the Tek device is opened, so force a clear...
         if( ws_type .eq. GKS$K_TEK4014 .or.
     1       ws_type .eq. GKS$K_TEK4014_OUTPUT ) then
            call GKS$CLEAR_WS(ws_id, GKS$K_CLEAR_ALWAYS)
         endif
c
c        Free any associated annotations
         call anno_free_note_structs(window_id, err_stat)
      endif
c     Changed from PERFORM to POSTPONE due to change/bug in GKS V6.0+
c     that caused this to emit a blank first page to color PostScript
c     device.
      call GKS$UPDATE_WS(ws_id, GKS$K_POSTPONE_FLAG)
c
c     Use a segment on VAXstations to support effort-free window resize
c     Multiple segments per window are suppored.
c     To create a new segment, set the segment_flag to .TRUE.
c     All output primitives will be entered into a new segment.
c     The segment is closed when deactivate_plot_device() is called.
c     Remember, the clear_flag will also delete any segments
c     associated with the window!
      if( ws_type .eq. GKS$K_VSII .or.
     1    ws_type .eq. GKS$K_VSII_GPX .or.
     2    ws_type .eq. GKS$K_DECWINDOWS .or.
     3    ws_type .eq. GKS$K_MOTIF ) then
         if( segment_flag ) then
            call GKS$CREATE_SEG(cur_segment_id)
         endif
      endif
      ws_active = .TRUE.
c
      return
      end
c
      subroutine deactivate_plot_device
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      character*1 ESC, CTRLC
      parameter ( ESC   = CHAR(27) )
      parameter ( CTRLC = CHAR(3) )
c
      integer state
c
      if( .NOT. ws_active ) return
c
c     Update current workstation
c
      call GKS$UPDATE_WS(ws_id, GKS$K_POSTPONE_FLAG)
c
c     Only use segments on workstations
      if( ws_type .eq. GKS$K_VSII .or.
     1    ws_type .eq. GKS$K_VSII_GPX .or.
     2    ws_type .eq. GKS$K_DECWINDOWS .or.
     3    ws_type .eq. GKS$K_MOTIF ) then
c        Some graphic cards (e.g. ZLXp-L2) reguire an extra kick in the pants
c        to get the graphics out...
         call GKS$UPDATE_WS(ws_id, GKS$K_PERFORM_FLAG)
         call GKS$INQ_OPERATING_STATE(state)
         if( state .eq. GKS$K_SGOP ) then
            call GKS$CLOSE_SEG
            cur_segment_id = cur_segment_id + 1
         endif
      endif
c   
      call gks$deactivate_ws(ws_id)
      ws_active = .FALSE.
c
c     Emit exit Tek sequence for 4014 emulation (xterm)
      if( ws_type .eq. GKS$K_TEK4014 .or.
     1    ws_type .eq. GKS$K_TEK4014_OUTPUT ) then
         write(luttyo,101) ESC,CTRLC
101      format('+',2a1,$)
      endif
c
      return
      end
c
      subroutine open_gks
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer i
      character*80 errfile
c
      if( gks_is_open ) return
c
c     Create a unique name for the GKS error file
      call pm_make_gkserrfile(errfile)
c
      call gks$open_gks(errfile,0)
c     Initialize window dictionary, workstation structure
      do 100 i=1,MAX_WS_STRUCT_SIZE
         window_dict(i) = PLT$EMPTY_WINDOW_SLOT
         ws_struct(i)%type      = -1
         ws_struct(i)%full_type = -1
         ws_struct(i)%ratio_x  = 1.0
         ws_struct(i)%ratio_y  = 1.0
         ws_struct(i)%color_or_mono = GKS$K_MONOCHROME
100   continue
      gks_is_open = .TRUE.
c     Make default style RETAINED (new: 13 Jul 92)
      plot_window_style = PLT$USE_RETAINED_WINDOWS
      current_window_id = -1
      reactivation_window_id = -1
c     Initialize retained window feature
      if( plot_window_style .eq. PLT$USE_RETAINED_WINDOWS ) then
         last_window_id = -1
         current_window_id = PLT$FIRST_RETAINED_WINDOW_ID
         save_last_window = .FALSE.
         do 200 i=1,MAX_RETAINED_WINDOWS
            window_is_retained(i) = .FALSE.
            retained_window_file(i) = ' '
200      continue
      endif
c
c     Initialize segment id counter
      cur_segment_id = 1
c
c     Initialize note structure tables
      call anno_init_note_structs
c
      return
      end
c
      subroutine close_plot_device(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type, err_stat
      integer iret, rc, string_len, unlink
      character*1 ESC, BACKSLASH
      parameter ( ESC = CHAR(27) )
      parameter ( BACKSLASH = CHAR(92) )
c
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) return  !  Bad window id, or closed already
c
c     If current device is to be closed, first deactivate it
      if( temp_ws_id .eq. ws_id .and. ws_active )
     1    call deactivate_plot_device
c
c     Since we are keeping VTxxx terminals open, rather than close them
c     after each plot, put VT330/340 terminals back into ReGIS mode
c     so GKS can send it a closing ReGIS sequence (when gks$close_ws is
c     called). This started out as a bug workaround for GKS V4.0, but
c     now plot save for VTxxx won't work correctly if this isn't done.
      if( ws_type .eq. GKS$K_VT330 .or.
     1    ws_type .eq. GKS$K_VT340 ) then
         write(luttyo,100) ESC
100      format('+',a1,'Pp',$)
      endif
c
      call gks$close_ws(temp_ws_id)
c
c     Another workaround for a GKS bug introduced in V5.0A.
c     Final buffer not flushed out.
c     Send terminal exit ReGIS command. Should be fixed in V5.1
CC      if( ws_type .eq. GKS$K_VT330 .or.
CC     1    ws_type .eq. GKS$K_VT340 ) then
CC         write(luttyo,101) ESC, BACKSLASH
CC101      format('+',a1,a1,$)
CC      endif
c
c     Envelope 4014 code with DEC enter/exit Tektronix mode escape codes
      temp_ws_type = ws_struct(temp_ws_id)%type
**      if( temp_ws_type .eq. GKS$K_TEK4014_OUTPUT )
**     1    call add_dectek_to_plotfile
c     Envelope LN03 sixels with LN03 reset escape code
      if( temp_ws_type .eq. GKS$K_LN03_PLUS )
     1    call add_ln03reset_to_plotfile
c     Mark window dictionary slot as free
      window_dict(temp_ws_id) = PLT$EMPTY_WINDOW_SLOT
c
c     Delete any associated annotations
      call anno_free_note_structs(window_id, err_stat)
c
c     Delete any file associated with a saved window
      if( temp_ws_type .eq. GKS$K_VSII .or.
     1    temp_ws_type .eq. GKS$K_VSII_GPX .or.
     2    temp_ws_type .eq. GKS$K_DECWINDOWS .or.
     3    temp_ws_type .eq. GKS$K_MOTIF ) then
         if (plot_window_style .eq. PLT$USE_RETAINED_WINDOWS) then
c           Delete any kept window description files
            iret = window_id -
     1             PLT$FIRST_RETAINED_WINDOW_ID + 1
            if (string_len(retained_window_file(iret)) .ne. 0) then
               rc = unlink(retained_window_file(iret))
               retained_window_file(iret) = ' '
            endif
         endif
      endif
c
      return
      end
c
      subroutine close_if_vtxxx(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type
c
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT )
     1    return  !  Bad window id, or closed already
c
c     If workstation is not a VTxxx series, return
      temp_ws_type = ws_struct(temp_ws_id)%type
      if( temp_ws_type .ne. GKS$K_VT125BW  .and.
     1    temp_ws_type .ne. GKS$K_VT125    .and.
     1    temp_ws_type .ne. GKS$K_VT240BW  .and.
     1    temp_ws_type .ne. GKS$K_VT240    .and.
     1    temp_ws_type .ne. GKS$K_VT330    .and.
     1    temp_ws_type .ne. GKS$K_VT340  ) return
c
c     If current device is to be closed, first deactivate it
      if( temp_ws_id .eq. ws_id .and. ws_active )
     1    call deactivate_plot_device
c
CC      For the meantime, we are keeping VTxxx workstations open
CC      across plots...
CC      call gks$close_ws(temp_ws_id)
c     Restore default color map
      call reset_vt_colormap
c     Mark window dictionary slot as free
CC      window_dict(temp_ws_id) = PLT$EMPTY_WINDOW_SLOT
c
      return
      end
c
      logical function is_vtxxx(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type
c
      is_vtxxx = .FALSE.
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) then
c        Bad window id, or closed already
         return
      endif
c
c     If workstation is a VTxxx series, return true
      temp_ws_type = ws_struct(temp_ws_id)%type
      if( temp_ws_type .eq. GKS$K_VT125BW  .or.
     1    temp_ws_type .eq. GKS$K_VT125    .or.
     1    temp_ws_type .eq. GKS$K_VT240BW  .or.
     1    temp_ws_type .eq. GKS$K_VT240    .or.
     1    temp_ws_type .eq. GKS$K_VT330    .or.
     1    temp_ws_type .eq. GKS$K_VT340  ) then
         is_vtxxx = .TRUE.
      endif
c
      return
      end
c
      logical function is_graphics_terminal(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type
c
      is_graphics_terminal = .FALSE.
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) then
c        Bad window id, or closed already
         return
      endif
c
c     If workstation is a VTxxx series or Tek4014 (xterm), return true
      temp_ws_type = ws_struct(temp_ws_id)%type
      if( temp_ws_type .eq. GKS$K_VT125BW  .or.
     1    temp_ws_type .eq. GKS$K_VT125    .or.
     1    temp_ws_type .eq. GKS$K_VT240BW  .or.
     1    temp_ws_type .eq. GKS$K_VT240    .or.
     1    temp_ws_type .eq. GKS$K_VT330    .or.
     1    temp_ws_type .eq. GKS$K_VT340    .or.
     1    temp_ws_type .eq. GKS$K_TEK4014  .or.
     1    temp_ws_type .eq. GKS$K_TEK4014_OUTPUT ) then
         is_graphics_terminal = .TRUE.
      endif
c
      return
      end
c
      subroutine close_gks
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer i, temp_window_id
c
      if( .NOT. gks_is_open ) return
c
      if( ws_open ) then
c        Run down all open plot devices
         do 100 i=1,MAX_WS_STRUCT_SIZE
           temp_window_id = window_dict(i)
           if( temp_window_id .ne. PLT$EMPTY_WINDOW_SLOT ) then
              call close_plot_device(temp_window_id)
           endif
100      continue
      endif
      ws_open = .FALSE.
c
      call gks$close_gks
      gks_is_open = .FALSE.
c
c     Reset segment id counter
      cur_segment_id = 1
      return
      end
c
      integer function lookup_ws_id(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer i
c
      if( .NOT. gks_is_open ) call open_gks
c
      do 100 i=1,MAX_WS_STRUCT_SIZE
         if( window_id .eq. window_dict(i) ) then
            lookup_ws_id = i
            return
         endif
100   continue
c
c     Else window_id not found, return PLT$EMPTY_WINDOW_SLOT
      lookup_ws_id = PLT$EMPTY_WINDOW_SLOT
      return
      end
c
      integer function get_new_ws_id(window_id)
      implicit none
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer i
c
      if( .NOT. gks_is_open ) call open_gks
c
      do 100 i=1,MAX_WS_STRUCT_SIZE
         if( window_dict(i) .eq. PLT$EMPTY_WINDOW_SLOT ) then
c           Found empty slot
            get_new_ws_id = i
            window_dict(i) = window_id
            return
         endif
100   continue
c
c     Else no free slot found, return -1
      get_new_ws_id = -1
      return
      end
c
      subroutine add_dectek_to_plotfile
      implicit none
c
c     Opens plot file with Tektronix 4014 plot codes,
c     and envelopes contents with DECTEK enter and exit sequences
c     so file can be plotted on an LN03 Plus.
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      character*1 ESC
      parameter ( ESC = CHAR(27) )
      character*6 DECTEK_ENTER
      parameter( DECTEK_ENTER = ESC // '[?38h' )
      character*6 DECTEK_EXIT
      parameter( DECTEK_EXIT  = ESC // '[?38l' )
      integer BUFLEN
      parameter( BUFLEN = 1024 ) ! Determined empirically from 4014 plot files
c
      integer ioerr, ilen, lrecl
      character*(BUFLEN) buffer
c
c     Check to make sure that we have a big enough record buffer
      inquire(file=temp_plot_file_name,recl=lrecl)
      if( lrecl .gt. BUFLEN ) then
      write(luttyo,10) lrecl
10    format(' ','convert_plotfile: Internal error: temporary plot ',
     1       'file record length (',i5,')'/
     2       ' ','   too long for internal buffer')
         goto 10000
      endif
c
      open(unit=50,file=temp_plot_file_name,err=1000,iostat=ioerr,
     1     status='OLD',carriagecontrol='NONE')
      open(unit=51,file=plot_file_name,err=1010,iostat=ioerr,
     1     status='UNKNOWN',carriagecontrol='NONE',recl=1024)
c
c     Enter Tekronix mode (DECTEK sequence)
c
      write(51,50) DECTEK_ENTER
50    format(a)
c
c     Copy file
c
100   continue
c        Three cheers for VAX/FORTRAN Q format !!!
c        It gives us input record length
         read(50,150,end=200,err=1020,iostat=ioerr) ilen, buffer
150      format(q,a)
         write(51,151,err=1030,iostat=ioerr) buffer(1:ilen)
151      format(a)
      goto 100
c
c     Write exit DECTEK sequence to exit 4014 mode
c
200   write(51,300) DECTEK_EXIT
300   format(a)
c
      close(unit=50)
      close(unit=51)
c
c     Delete older file. temp_plot_file_name has ; at end of filename
c     (as defined in block data).
c
      call unlink(temp_plot_file_name)
      goto 10000
c
c     Error handling
c
1000  write(luttyo,1001)
1001  format(' ','convert_plotfile: Internal error: can''t find ',
     1       'temporary plot file')
      goto 10000
c
1010  write(luttyo,1011)
1011  format(' ','convert_plotfile: Error: can''t open ',
     1       'LN03+ plot file')
      goto 10000
c
1020  write(luttyo,1031) ioerr
1021  format(' ','convert_plotfile: FORTRAN error ', i5,
     1       ' during read of temporary plot file')
      goto 10000
c
1030  write(luttyo,1031) ioerr
1031  format(' ','convert_plotfile: FORTRAN error ',i5,
     1       ' during write of LN03+ plot file')
c
10000 return
      end
c
      subroutine add_ln03reset_to_plotfile
      implicit none
c
c     Opens plot file with LN03 PLUS sixels and prepends the
c     LN03 reset code (ESC c). This clears any setup done by the
c     print symbiont that can mess up the plot.
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      character*1 ESC
      parameter ( ESC = CHAR(27) )
      character*2 LN03_RESET
      parameter( LN03_RESET = ESC // 'c' )
      integer BUFLEN
      parameter( BUFLEN = 8192 ) ! LN03 sixel files seem to use recl=80
                                 ! but give them a little more to be sure
c
      integer ioerr, ilen, lrecl
      character*(BUFLEN) buffer
c
c     Check to make sure that we have a big enough record buffer
      inquire(file=temp_plot_file_name,recl=lrecl)
      if( lrecl .gt. BUFLEN ) then
      write(luttyo,10) lrecl
10    format(' ','add_ln03reset_to_plotfile: Internal error: ',
     1       'temporary plot file record length (',i5,')'/
     2       ' ','   too long for internal buffer')
         goto 10000
      endif
c
      open(unit=50,file=temp_plot_file_name,err=1000,iostat=ioerr,
     1     status='OLD',carriagecontrol='NONE')
      open(unit=51,file=plot_file_name,err=1010,iostat=ioerr,
     1     status='UNKNOWN',carriagecontrol='NONE',recl=8192)
c
c     Write reset code
c
      write(51,50) LN03_RESET
50    format(a)
c
c     Copy file
c
100   continue
c        Three cheers for VAX/FORTRAN Q format !!!
c        It gives us input record length
         read(50,150,end=200,err=1020,iostat=ioerr) ilen, buffer
150      format(q,a)
         write(51,151,err=1030,iostat=ioerr) buffer(1:ilen)
151      format(a)
      goto 100
c
200   continue
c
      close(unit=50)
      close(unit=51)
c
c     Delete older file. temp_plot_file_name has ; at end of filename
c     (as defined in block data).
c
      call unlink(temp_plot_file_name)
      goto 10000
c
c     Error handling
c
1000  write(luttyo,1001)
1001  format(' ','add_ln03reset_to_plotfile: Internal error: ',
     1       'can''t find temporary plot file')
      goto 10000
c
1010  write(luttyo,1011)
1011  format(' ','add_ln03reset_to_plotfile: Error: can''t open ',
     1       'LN03+ plot file')
      goto 10000
c
1020  write(luttyo,1031) ioerr
1021  format(' ','add_ln03reset_to_plotfile: FORTRAN error ', i5,
     1       ' during read of temporary plot file')
      goto 10000
c
1030  write(luttyo,1031) ioerr
1031  format(' ','add_ln03reset_to_plotfile: FORTRAN error ',i5,
     1       ' during write of LN03+ plot file')
c
10000 return
      end
c
      subroutine write_data_menu(topic)
      implicit none
c
c     Types variable menu to terminal.
c
      character*(*) topic
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'data.cmn'
      include 'io.cmn'
c
      integer i, ii, imid,  ilen1, ilen2, string_len
c
      write(luttyo,100) topic
100   format(' ',a/)
c
c     Format data in two columns if more than 15 items...
      if( max_menu_num .le. 15 ) then
         imid = max_menu_num
      else
         imid = max_menu_num/2 + MOD(max_menu_num,2)
      endif
      do 1000 i=1, imid
         ilen1 = string_len(data_name(i))
         ii = i+imid
         if( ii .le. max_menu_num ) then
            ilen2 = string_len(data_name(ii))
            write(luttyo,200) i, data_name(i)(1:ilen1),
     1                        ii, data_name(ii)(1:ilen2)
         else
            write(luttyo,200) i, data_name(i)(1:ilen1)
         endif
200      format(' ',i2,' - ',a,t40,2x,i2,' - ',a)
1000  continue
c
      write(luttyo,300)
300   format(/' ','999, q, e, or <return> - Previous menu')
      return
      end
c
      subroutine format_axis_label(value,major_tic_value,
     1                             string,exp_flag)
      implicit none
c
c     Formats real 'value' into character 'string' using
c     the minimum number of decimal places to guarantee accuracy.
c     Make sure that the number of decimal places is the same as
c     needed for the major tic mark delta value.
c
c     Following algorithm is used:
c
c     ABS(value) .lt. 0.001      ->   Exponential format
c     ABS(value) .ge. 1000.      ->   Exponential format
c     value .eq. 0.0             ->   0
c
c     Else format value and major_tic_value using f8.3 (if ABS(value) > 0)
c     or f9.4 (if ABS(value) < 0) into two strings.
c     Beginning from right end of strings, compare strings.
c     If both characters are zero, replace them with a blank, next char.
c     If both characters are a period, replace with a blank and end loop.
c     Else end loop.
c
c     The different f formats are used to try to avoid printing fractional
c     digits when value is corrupted by round-off.
c
c     Special case: We can mistakenly use exponential format for a
c     number that is supposed to be zero, but is not (but very small)
c     due to round off. We make a decision about this case by
c     dividing value by major_tic_value. If it is smaller than 0.001,
c     (the number of decimal digits we print in E format)
c     we consider it to be exactly zero.
c
c     Returns formatted value in string. Caller has responsibility
c     to strip off trailing blanks when actually outputing label.
c     This is necessary in any event, since FORTRAN does not support
c     varying character strings.
c
c     String must be at least nine characters long.
c     Exp_flag is set to .TRUE. if exponential notation is used.
c
      logical exp_flag
      real value, major_tic_value
      character*(*) string
c
c     locals
c
      real abs_value
      integer LEN, ilen, i, j, isize
      character*9 temp1, temp2
c
      exp_flag = .FALSE.
      ilen = LEN(string)
      if( ilen .lt. 9 ) then
         call plt$error_message('format_axis_label',
     1      'Internal error: Label string too small (< 9 chars)')
         string = '*'
         return
      endif
c
      abs_value  = ABS(value)
c     Our complicated test for 0.0
c     Loosen 'zero' criteria. jvf
      if( abs_value .lt. 1.0E-3 .and.
     1    abs_value/major_tic_value .lt. 1.0E-3 ) then
         write(string,200) 0
200      format(i1)
      else if( abs_value .ge. 1000.0  .or.
     1         abs_value .lt. 0.0009999 ) then
         write(string,300) value
300      format(1pe9.2)
         exp_flag = .TRUE.
      else
         if( abs_value .ge. 0.01 ) then
            write(temp1,401) value
            write(temp2,401) major_tic_value
401         format(f9.3)
            isize = 3
         else
            write(temp1,400) value
            write(temp2,400) major_tic_value
400         format(f9.4)
            isize = 4
         endif
c        Examine last isize chars, blank out trailing zeros (and decimal point)
c        common to data and tic value.
c        Sorry about the convoluted code. I should rewrite this loop!
         do i=9,9-isize,-1
            if( temp1(i:i) .eq. temp2(i:i) ) then
               if( temp1(i:i) .eq. '0' ) then
                  temp1(i:i) = ' '
               else if ( temp1(i:i) .eq. '.' ) then
                  temp1(i:i) = ' '
               else
                  goto 500
               endif
            else
               goto 500
            endif
         end do
500      continue
c        Return formatted string minus any initial blanks
         j = 0
         do i=1,9
            j = j + 1
            if( temp1(i:i) .ne. ' ' ) goto 600
         end do
600      continue
         string = temp1(j:9)
      endif
c
      return
      end
c
      subroutine init_device_depend
      implicit none
c
c     Initialize plot device dependent parameters
c     such as line type, font, font precision, etc.
c     This is sorta like reinventing GKS bundled attributes.
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'defaults.cmn'
c
      integer local_ps_font_id
c
      if ( l_curv ) then
c        Curv used Times Roman font for text
         local_ps_font_id = -101
      else
         local_ps_font_id = ps_font_id
      endif
c
      use_stroke_prec = .TRUE.
c
      if( default_hidden_method .ne. 0 ) then
         hidden_line_method = default_hidden_method
      else if( ws_type .eq. GKS$K_VT340 .or.
     1         ws_type .eq. GKS$K_VSII  .or.
     2         ws_type .eq. GKS$K_DECWINDOWS .or.
     3         ws_type .eq. GKS$K_MOTIF .or.
     4         ws_type .eq. GKS$K_LJ250 .or.
     5         ws_type .eq. GKS$K_LJ250_180DPI .or.
     6         ws_type .eq. GKS$K_LCG01 .or.
     7         ws_type .eq. GKS$K_COLOR_POSTSCRIPT .or.
     8         ws_type .eq. GKS$K_COLOR_EPSF .or.
     9         ws_type .eq. GKS$K_LASERJETII ) then
         hidden_line_method = HIDDEN_LINES_WITH_FILL_AREA
      else
         hidden_line_method = HIDDEN_LINES_WITH_HORIZON_FCN
      endif
c
c     Set flag if device can do color contours
      if( (ws_type .eq. GKS$K_VT340 .or.
     1     ws_type .eq. GKS$K_VSII  .or.
     2     ws_type .eq. GKS$K_DECWINDOWS .or.
     3     ws_type .eq. GKS$K_MOTIF .or.
     4     ws_type .eq. GKS$K_HP7550 .or.
     5     ws_type .eq. GKS$K_LJ250 .or.
     6     ws_type .eq. GKS$K_LJ250_180DPI .or.
     7     ws_type .eq. GKS$K_LCG01  .or.
     8     ws_type .eq. GKS$K_COLOR_POSTSCRIPT .or.
     9     ws_type .eq. GKS$K_COLOR_EPSF ) .and.
     A    color_or_mono .eq. GKS$K_COLOR) then
         can_do_color_contours = .TRUE.
      else
         can_do_color_contours = .FALSE.
      endif
c
      if( ws_type .eq. GKS$K_VT125BW .or.
     1    ws_type .eq. GKS$K_VT240BW ) then
         use_stroke_prec = .FALSE.
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 0.5
         call GKS$SET_TEXT_FONTPREC(1, GKS$K_TEXT_PRECISION_STRING)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_COLOR_INDEX(VT_NORMAL_INTEN)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PMARK_COLOR_INDEX(VT_NORMAL_INTEN)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(VT_NORMAL_INTEN)
      else if( ws_type .eq. GKS$K_VT125 .or.
     1         ws_type .eq. GKS$K_VT240   ) then
         use_stroke_prec = .FALSE.
         ncolors = 3
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 0.5
         call GKS$SET_TEXT_FONTPREC(1, GKS$K_TEXT_PRECISION_STRING)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_COLOR_INDEX(VT_NORMAL_INTEN)
         call GKS$SET_PMARK_COLOR_INDEX(VT_NORMAL_INTEN)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(VT_NORMAL_INTEN)
      else if( ws_type .eq. GKS$K_VT330 ) then
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 0.5
         use_stroke_prec = .FALSE.
         call GKS$SET_TEXT_FONTPREC(1, GKS$K_TEXT_PRECISION_STRING)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_VT340 ) then
         ncolors = 7
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 0.5
         use_stroke_prec = .FALSE.
         call GKS$SET_TEXT_FONTPREC(1, GKS$K_TEXT_PRECISION_STRING)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
c     All monochrome workstations (VWS or DECwindows/Motif)
      else if ( (ws_type .eq. GKS$K_VSII .or.
     1           ws_type .eq. GKS$K_DECWINDOWS .or.
     2           ws_type .eq. GKS$K_MOTIF) .and.
     3          color_or_mono .eq. GKS$K_MONOCHROME) then
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
c     All color workstations (VWS or DECwindows/Motif)
      else if ( (ws_type .eq. GKS$K_VSII .or.
     1           ws_type .eq. GKS$K_DECWINDOWS .or.
     2           ws_type .eq. GKS$K_MOTIF) .and.
     3          color_or_mono .eq. GKS$K_COLOR) then
c        Actually, it is possible under DECwindows to have less than
c        7 distinct colors at once, but we ignore this possibility!
         ncolors = 15
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_HP7550 ) then
         ncolors = 8
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 0.5
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_TEK4014_OUTPUT ) then
c        Can be output to LN03 PLUS (after calling convert_plotfile
c        to envelop 4014 code with enter/exit TEK mode sequences).
c        Or can use with LPS40 with TEK4014 translator.
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_LN03_PLUS ) then
         ncolors = 1
         hw_tuned_width = 1.2*global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_POSTSCRIPT .or.
     1          ws_type .eq. GKS$K_EPSF ) then
         ncolors = 1
         hw_tuned_width = 2.0*global_linewidth_scale
c        DEC GKS PostScript driver creates markers than don't scale
c        with changes in workstation window (and hence won't 'shrink'
c        with the hardcopy scale factor). So modify pmark size manually.
c        Now that we have individual x/y scaling, we take the minimum
c        of the two (arbitrary).
         hw_tuned_pmark_size = 1.0*hc_scale
c        Set font (-107 is Helvetica bold), solid black lines and text.
c        Use STRING precision for GKS-3D compatibility
c        GKS 2D/3D actually use STROKE precision for built-in Postscript fonts
         call GKS$SET_TEXT_FONTPREC(local_ps_font_id,
     1                              GKS$K_TEXT_PRECISION_STRING)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(local_ps_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_COLOR_POSTSCRIPT .or.
     1          ws_type .eq. GKS$K_COLOR_EPSF ) then
         ncolors = 15
         hw_tuned_width = 2.0*global_linewidth_scale
c        DEC GKS PostScript driver creates markers than don't scale
c        with changes in workstation window (and hence won't 'shrink'
c        with the hardcopy scale factor). So modify pmark size manually.
c        Now that we have individual x/y scaling, we take the minimum
c        of the two (arbitrary).
         hw_tuned_pmark_size = 1.0*hc_scale
c        Font -107 is Helvetica bold, solid black lines and text.
c        Use STRING precision for GKS-3D compatibility
c        GKS 2D/3D actually use STROKE precision for built-in Postscript fonts
         call GKS$SET_TEXT_FONTPREC(local_ps_font_id,
     1                              GKS$K_TEXT_PRECISION_STRING)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(local_ps_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_LJ250 ) then
         ncolors = 15
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.3
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_TEXT_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
      else if ( ws_type .eq. GKS$K_LJ250_180DPI ) then
         ncolors = 7
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.3
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_TEXT_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
      else if ( ws_type .eq. GKS$K_LCG01 ) then
         ncolors = 7
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_DDIF ) then
         ncolors = 8
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else if ( ws_type .eq. GKS$K_LASERJETII ) then
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      else  ! a generic device
         ncolors = 1
         hw_tuned_width = global_linewidth_scale
         hw_tuned_pmark_size = 1.0
c        Set font, solid black lines and text.
         call GKS$SET_TEXT_FONTPREC(default_font_id,
     1                              GKS$K_TEXT_PRECISION_STROKE)
c        Tell mathmode what text font we are using
         call mathmode_set_text_font(default_font_id)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PMARK_SIZE(hw_tuned_pmark_size)
         call GKS$SET_TEXT_COLOR_INDEX(1)
      endif
c
      return
      end
c
      subroutine set_line_index(index)
      implicit none
c
c     Set line type to distinguish different parts of plot
c     Index is an integer starting at 1. Any value of integer
c     may be given; the routine will create a number of different
c     lines, and will eventually repeat them.
c
c     Special line indices (defined in const.h).
c        DEFAULT_LINE - "normal" intensity == 1
c        POLY_LINE    - For plotting one piece of data == -1
c        BORDER_LINE  - For boxes around plot == -2
c
c     If logical use_solid_lines is .TRUE. then do not change line type/width
c     to distinguish different indices for monochrome hardcopy output
c     devices.
c
      integer index
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer ilinetype, ilinewidth, ilinecolor
c
      if( index .eq. DEFAULT_LINE ) then
         call GKS$SET_PLINE_COLOR_INDEX(1)
         call GKS$SET_PMARK_COLOR_INDEX(1)
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
         call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
      else if ( index .eq. BORDER_LINE ) then
         if( ncolors .eq. 1 ) then
            call GKS$SET_PLINE_COLOR_INDEX(1)
            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            call GKS$SET_PLINE_LINEWIDTH(2.0*hw_tuned_width)
         else
            call GKS$SET_PLINE_COLOR_INDEX(2)
            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         endif
      else if ( index .eq. POLY_LINE ) then
         if( ncolors .eq. 1 ) then
            call GKS$SET_PLINE_COLOR_INDEX(1)
            call GKS$SET_PMARK_COLOR_INDEX(1)
            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         else
            call GKS$SET_PLINE_COLOR_INDEX(1)
            call GKS$SET_PMARK_COLOR_INDEX(1)
            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         endif
      else
c        Model line types with available hardware resources
         if( ncolors .eq. 1 ) then
            call GKS$SET_PLINE_COLOR_INDEX(1)
            call GKS$SET_PMARK_COLOR_INDEX(1)
            ilinetype = MOD((index-1),4) + 1
            if( plot_device .eq. hardcopy_device .and.
     1          use_solid_lines ) ilinetype = 1
            if( ilinetype .eq. 8 ) then
               call GKS$SET_PLINE_LINETYPE(
     1              GKS$K_LINETYPE_LONG_SHORT_DASH)
            else if( ilinetype .eq. 7 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_LONG_DASH)
            else if( ilinetype .eq. 6 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASH_3_DOT)
            else if( ilinetype .eq. 5 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASH_2_DOT)
            else if( ilinetype .eq. 4 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASHED_DOTTED)
            else if( ilinetype .eq. 3 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DOTTED)
            else if( ilinetype .eq. 2 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASHED)
            else
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            endif
            ilinewidth = MOD((index-1),8) + 1
            if( plot_device .eq. hardcopy_device .and.
     1          use_solid_lines ) ilinewidth = 1
            if( ilinewidth .gt. 4 ) then
               call GKS$SET_PLINE_LINEWIDTH(3.0*hw_tuned_width)
            else
               call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
            endif
         else if( ncolors .eq. 3 ) then ! VT125/240
c           Alternate normal, low, high intensity
c                     solid, dashed, dotted lines
            ilinecolor = MOD((index-1),3) + 1
            call GKS$SET_PLINE_COLOR_INDEX(ilinecolor)
            call GKS$SET_PMARK_COLOR_INDEX(ilinecolor)
            ilinetype = MOD((index-1),9) + 1
            if( ilinetype .gt. 6 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DOTTED)
            else if( ilinetype .gt. 3 ) then
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASHED)
            else
               call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
            endif
            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         else if( ncolors .eq. 7 ) then  ! VT340
            ilinecolor = MOD((index-1),7) + 1
            call GKS$SET_PLINE_COLOR_INDEX(ilinecolor)
            call GKS$SET_PMARK_COLOR_INDEX(ilinecolor)
CC            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
CC            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         else
c           All other supported color device have more than 8
c           separate colors. Yeah.
            call GKS$SET_PLINE_COLOR_INDEX(index)
            call GKS$SET_PMARK_COLOR_INDEX(index)
CC            call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
CC            call GKS$SET_PLINE_LINEWIDTH(hw_tuned_width)
         endif
      endif
c
      return
      end
c
      subroutine move_abs(x,y)
      implicit none
c
c     Simulate MOVE/DRAW paradigm with GKS
c
      real last_x, last_y
      common/sim_mov_draw/ last_x, last_y
c
      real x,y
c
      last_x = x
      last_y = y
c
      return
      end
c
      subroutine draw_abs(x,y)
      implicit none
c
c     Simulate MOVE/DRAW paradigm with GKS
c
      real x,y
c
      real last_x, last_y
      common/sim_mov_draw/ last_x, last_y
      real xcoord(2), ycoord(2)
c
      xcoord(1) = last_x
      ycoord(1) = last_y
      xcoord(2) = x
      ycoord(2) = y
      call GKS$POLYLINE(2, xcoord, ycoord)
      last_x = x
      last_y = y
c
      return
      end
c
      subroutine tune_charsize(char_width, char_height, char_spacing,
     1                   stroke_width, stroke_height, stroke_spacing)
      implicit none
c
c     Used to tune character size, depending on whether we use
c     character or stroke precision. All devices, except VT125/240
c     devices use stroke, so this is mainly a kludge for those
c     devices. We also try to account for size differences
c     between PostScript fonts and the GKS device independent fonts
c     by a simple scaling rule (why are they different?)
c
      real char_width, char_height, stroke_width, stroke_height
      real char_spacing, stroke_spacing
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'defaults.cmn'
c
      real ratio
      data ratio /1.15/  ! Approx. ratio between PS and GKS font size
                         ! Ratio found by experiment with Helvetica Bold
                         ! font and GKS device independent font -9
                         ! No idea if this will work with other PS fonts
      real ps_scale, hscale, wscale, sin_theta, cos_theta, hypot,
     1     hc_xscale, hc_yscale
c
c     Variables for callt to GKS$INQ_PRIM_ATTB
      integer err_stat, list_bundle_indexes(4), char_path, char_align(2)
      real pat_width(2), pat_height(2), pat_ref(2),
     1     height, width, char_upvec(2), extent_bv(2)
c
      if( use_stroke_prec ) then
         if( ws_type .ne. GKS$K_POSTSCRIPT .and.
     1       ws_type .ne. GKS$K_COLOR_POSTSCRIPT .and.
     2       ws_type .ne. GKS$K_EPSF .and.
     3       ws_type .ne. GKS$K_COLOR_EPSF ) then
            call GKS$SET_TEXT_HEIGHT(global_text_scale*stroke_height)
            call GKS$SET_TEXT_EXPFAC(stroke_width/stroke_height)
            call GKS$SET_TEXT_SPACING(global_text_scale*stroke_spacing)
         else
c           Call GKS$INQ_PRIM_ATTB to get character up vector
            call GKS$INQ_PRIM_ATTB(err_stat, list_bundle_indexes,
     1              height, char_upvec, width, extent_bv,
     2              char_path, char_align,
     3              pat_width, pat_height, pat_ref)
            if( hc_aspect_ratio .ge. 0.77 ) then
               hc_xscale = 0.77/hc_aspect_ratio
               hc_yscale = 1.0
            else
               hc_xscale = 1.0
               hc_yscale = hc_aspect_ratio/0.77
            endif
            ps_scale = sqrt(hc_xscale*hc_yscale)
            hypot = SQRT(char_upvec(1)**2 + char_upvec(2)**2)
            sin_theta = ABS(char_upvec(1)/hypot)
            cos_theta = ABS(char_upvec(2)/hypot)
            wscale   = 1/(hc_xscale*cos_theta + hc_yscale*sin_theta)
            hscale   = 1/(hc_xscale*sin_theta + hc_yscale*cos_theta)
            call GKS$SET_TEXT_HEIGHT(ps_scale*hscale*
     1                               global_text_scale*stroke_height/
     1                               ratio)
            call GKS$SET_TEXT_EXPFAC(ps_scale*wscale*
     1                               stroke_width/
     1                              (stroke_height*ratio))
            call GKS$SET_TEXT_SPACING(ps_scale*
     1                                global_text_scale*stroke_spacing/
     1                                ratio)
         endif
      else
         call GKS$SET_TEXT_HEIGHT(char_height)
         call GKS$SET_TEXT_EXPFAC(char_width/char_height)
         call GKS$SET_TEXT_SPACING(char_spacing)
      endif
      return
      end
c
      subroutine format_mathmode_exponent(value, label)
      implicit none
c
c     Format real value in range [-99..99] into mathmode string
c     which will plot as
c                             value
c                           10
c
      real value
      character*(*) label
c
      integer itmp, iwidth
      character*1 BACKSLASH
      parameter (BACKSLASH = CHAR(92))
c
c     Test for exponent out of range
      if( ABS(value) .gt. 99.0 ) then
         label = '10^{**}' // BACKSLASH // ';'
         return
      endif
c
c     Width of format of exponent depends on magnitude and sign of "value".
      itmp = INT(value*1.001)  ! 1.001 is fuzz factor to account for roundoff
      iwidth = 1
      if( itmp .lt. 0 )      iwidth = iwidth + 1  ! sign
      if( ABS(itmp) .gt. 9 ) iwidth = iwidth + 1  ! two digits in exponent
c     Use variable format (VAX FORTRAN extension). Oh, for C %d format!!
      write(label,100) itmp
100   format('10^{',i<iwidth>,'}')
c
      return
      end
c
      subroutine vs_window_manager
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
c     locals
c
      logical invalid
      character*10 answer
c
100   call clear_screen
      write(luttyo,200)
200   format(' ','Manage workstation windows:'//
     1    ' ','Delete     - Delete any or all plot windows'/
     1    ' ','Reactivate - Reactivate a plot window'/
     1    ' ','Style      - Determine how to manage plot windows'/
     1    ' ','Quit       - Quit (return to main menu)'//
     1    ' ','Note: these functions are meant for workstations only')
300   write(luttyo,310)
310   format(/' ','Request? ',$)
      read(luttyi,320) answer
320   format(a)
      call upcase(answer)
c
c     switch on answer
c
      invalid = .FALSE.
      if( answer(1:1) .eq. 'D' ) then
          call delete_vs_windows
      else if( answer(1:1) .eq. 'R' ) then
          call reactivate_vs_window
          goto 10000
      else if( answer(1:1) .eq. 'S' ) then
          call set_vs_window_style
      else if( answer(1:1) .eq. 'Q' ) then
          goto 10000
      else
         invalid = .TRUE.
      endif
c
      if( invalid ) then
         write(luttyo,330) answer
330      format(' ','Invalid request: ''',a,'''')
         goto 300
      else
         goto 100
      endif
c
10000 return
      end
c
      subroutine delete_vs_windows
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
c     locals
c
      integer i, id, iret
      logical none_found
      character*1 answer
      character*2 id_string
c
      if(.NOT. gks_is_open) call open_gks  ! Initialize window management
c
50    none_found = .TRUE.
      call clear_screen
      write(luttyo,100)
100   format(' ','Plot windows:'//)
c
      do 200 i=1,MAX_WS_STRUCT_SIZE
         if( window_dict(i) .ne. PLT$EMPTY_WINDOW_SLOT ) then
            none_found = .FALSE.
            write(luttyo,210) i
210         format(' ','   Window ',i2)
         endif
200   continue
c
      if( none_found ) then
         call get_char(answer,
     1        'No plot windows found. Hit return to continue...',0)
      else
         write(luttyo,310)
310      format(' ',
     1     'Enter number of window to delete, or A to delete all: ',$)
c        Code assumes window numbers are less than 100
         read(luttyi,320) id_string
320      format(a)
         call upcase(id_string)
         if( id_string(1:1) .eq. 'A') then
            do 325 i=1,MAX_WS_STRUCT_SIZE
               if( window_dict(i) .ne. PLT$EMPTY_WINDOW_SLOT ) 
     1            call close_plot_device(window_dict(i))
325         continue
            do 326 i=1,MAX_RETAINED_WINDOWS
               window_is_retained(i) = .FALSE.
326         continue
         else
c           line 330 is catch all error handler
            read(id_string,*,err=330) id  ! Convert to integer
c           Test for id out of range
            if( id .lt. 1 .or. id .gt. MAX_WS_STRUCT_SIZE ) goto 330
c           Test for deletion of window that is already deleted
            if( window_dict(id) .eq. PLT$EMPTY_WINDOW_SLOT ) goto 330
            if( plot_window_style .eq. PLT$USE_RETAINED_WINDOWS ) then
c              Retained window id's are in range
c                 PLT$FIRST_RETAINED_WINDOW_ID to
c                 PLT$FIRST_RETAINED_WINDOW_ID + MAX_RETAINED_WINDOWS - 1
c              window_is_retained index is 1..MAX_RETAINED_WINDOWS
               iret = window_dict(id) - PLT$FIRST_RETAINED_WINDOW_ID + 1
               window_is_retained(iret) = .FALSE.
            endif
            call close_plot_device(window_dict(id))
            goto 340
330         write(luttyo,335) id_string
335         format(' ','Window number  ',a2,' is invalid')
340         continue
            call get_char(answer,
     1         'More windows to delete (y/n)? ',0)
            call upcase(answer)
            if( answer .eq. 'Y' ) goto 50
         endif
      endif
      return
      end
c
      subroutine reactivate_vs_window
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
c     locals
c
      integer i, id, iret, int_vec(1), string_len
      logical none_found, err, lgui_save
      character*1 answer
c
      if(.NOT. gks_is_open) call open_gks  ! Initialize window management
c
      if( plot_window_style .ne. PLT$USE_RETAINED_WINDOWS ) then
c        Reactivate only works for retained window style
         write(luttyo,25)
25       format(' ','Plot window style must be "retained" to ',
     1              'reactivate windows.')
         call get_char(answer,'Hit return to continue...',0)
      endif
c
50    none_found = .TRUE.
      call clear_screen
      write(luttyo,100)
100   format(' ','Saved plot windows:'//)
c
      do 200 i=1,MAX_WS_STRUCT_SIZE
         if( window_dict(i) .ne. PLT$EMPTY_WINDOW_SLOT ) then
            iret = window_dict(i) - PLT$FIRST_RETAINED_WINDOW_ID + 1
            if( string_len(retained_window_file(iret)) .ne. 0 ) then
               none_found = .FALSE.
               write(luttyo,210) i
210            format(' ','   Window ',i2)
            endif
         endif
200   continue
c
      if( none_found ) then
         call get_char(answer,
     1        'No saved plot windows. Hit return to continue...',0)
      else
         call get_ints(int_vec,1,
     1      'Enter number of window to reactivate: ',0)
         id = int_vec(1)
         if( id .lt. 1 .or. id .gt. MAX_WS_STRUCT_SIZE ) then
c           Id out of range
            write(luttyo,330) id
330         format(' ','Window number  ',i5,' is invalid')
            call get_char(answer,'Want to retry (y/n)? ',0)
            call upcase(answer)
            if( answer .eq. 'Y' ) goto 50
         else if( window_dict(id) .eq. PLT$EMPTY_WINDOW_SLOT ) then
c           Attempt to reactivate window that is already deleted
            write(luttyo,330) id
            call get_char(answer,'Want to retry (y/n)? ',0)
            call upcase(answer)
            if( answer .eq. 'Y' ) goto 50
         else
c           Retained window id's are in range
c              PLT$FIRST_RETAINED_WINDOW_ID to
c              PLT$FIRST_RETAINED_WINDOW_ID + MAX_RETAINED_WINDOWS - 1
c           window_is_retained index is 1..MAX_RETAINED_WINDOWS
c           Do an implicit save of the current window...
c           Create file to store pmi file to restore window contents
            iret = current_window_id -
     1             PLT$FIRST_RETAINED_WINDOW_ID + 1
            if( string_len(retained_window_file(iret)) .eq. 0 ) then
               call pm_make_tempfile('PM_TMPWIN',
     1              retained_window_file(iret))
            endif
c           Third argument says to overwrite any existing file (VMS only)
c           Special hack: turn on "gui" mode to avoid writing
c           messages to the terminal. Messages go to the gui message
c           buffers...
            lgui_save = lgui
            lgui = .TRUE.
            call write_savefile(retained_window_file(iret),
     1                          current_window_id,.TRUE.,err)
            lgui = lgui_save
c
c           Now restore current window
            iret = window_dict(id) - PLT$FIRST_RETAINED_WINDOW_ID + 1
            reactivation_window_id = window_dict(id)
            call do_restore_plot(retained_window_file(iret),err)
         endif
      endif
      return
      end
c
      subroutine set_vs_window_style
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      integer i
      character*1 answer
      character*35 ptype
c
      if( .NOT. gks_is_open ) call open_gks
c
      call clear_screen
      write(luttyo,100)
100   format(' ','The following window styles available:'/
     1       ' ','Single :  All plots go to the same window on the',
     1           ' workstation'/
     1       ' ','Multple:  Each plot type (e.g. 1D, contour, 3D)',
     1           ' goes to a separate window'/
     1       ' ','Retained: All plots go to a single window, but',
     1           ' the user can save any window'/)
      if( plot_window_style .eq. PLT$USE_SINGLE_WINDOW) then
         ptype = 'single'
      else if( plot_window_style .eq. PLT$USE_MULTIPLE_WINDOWS) then
         ptype = 'multiple'
      else
         ptype = 'retained'
      endif
c
      write(luttyo,120) ptype
120   format(' ','Current window style is ',a)
200   call get_char(answer,
     1  'Enter new style: single, multiple, retained, quit' //
     1  ' (don''t change)? (s/m/r/q) ', 0)
      call upcase(answer)
      if(      answer .eq. 'S' ) then
         plot_window_style = PLT$USE_SINGLE_WINDOW
         current_window_id = -1
      else if( answer .eq. 'M' ) then
         plot_window_style = PLT$USE_MULTIPLE_WINDOWS
         current_window_id = -1
      else if( answer .eq. 'R' ) then
         plot_window_style = PLT$USE_RETAINED_WINDOWS
         last_window_id = -1
         current_window_id = PLT$FIRST_RETAINED_WINDOW_ID
         save_last_window = .FALSE.
         do 250 i=1,MAX_RETAINED_WINDOWS
            window_is_retained(i) = .FALSE.
250      continue
      else if( answer .eq. 'Q' ) then
         return
      else
         write(luttyo,300)
300      format(' ','Please enter S, M, R or Q')
         goto 200
      endif
c
c     Delete all windows so things start fresh.
      do 400 i=1,MAX_WS_STRUCT_SIZE
         if( window_dict(i) .ne. PLT$EMPTY_WINDOW_SLOT )
     1      call close_plot_device(window_dict(i))
400   continue
c
      return
      end
c
      integer function get_new_window_id(multiple_win_id)
      implicit none
c
c     Use this window id if style is one window per plot type
      integer multiple_win_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'io.cmn'
c
      integer i, islot, iret
      logical found_slot
c
      if( .NOT. gks_is_open ) call open_gks
c
      if( plot_device .ne. hardcopy_device ) then
c
c        current/last_window_id only tracks interactive windows
         if( plot_window_style .eq. PLT$USE_SINGLE_WINDOW ) then
            last_window_id    = current_window_id
            current_window_id = PLT$CATCHALL_WINDOW_ID
            get_new_window_id = current_window_id
         else if( plot_window_style .eq. PLT$USE_MULTIPLE_WINDOWS )then
            last_window_id    = current_window_id
            current_window_id = multiple_win_id
            get_new_window_id = current_window_id
         else  ! Retained style
            if( reactivation_window_id .gt. 0 ) then
c              Mark current window as "kept"
               iret = current_window_id -
     1             PLT$FIRST_RETAINED_WINDOW_ID + 1
               window_is_retained(iret) = .TRUE.
c              Now make current window the window to be restored.
               last_window_id = current_window_id
               current_window_id = reactivation_window_id
               get_new_window_id = current_window_id
               reactivation_window_id = 0
               save_last_window = .FALSE.
            else if( save_last_window ) then
c              Find next free window id
c              Be careful! Don't count the currently open window
c              as free!
               islot = -1
               do 100 i=1,MAX_RETAINED_WINDOWS
                  if( (.NOT. window_is_retained(i)) .AND.
     1                i .ne. (current_window_id -
     1                        PLT$FIRST_RETAINED_WINDOW_ID + 1) ) then
                     islot = i
                     goto 101
                  endif
100            continue
101            continue
c              Check to see if there is a free ws_struct slot
               found_slot = .FALSE.
               do 150 i=1,MAX_WS_STRUCT_SIZE
                  if( window_dict(i) .eq. PLT$EMPTY_WINDOW_SLOT ) then
                      found_slot = .TRUE.
                      goto 151
                   endif
150            continue
151            continue
               if( found_slot .and. islot .ne. -1 ) then
c                 Mark current window as saved
                  window_is_retained(current_window_id - 
     1               PLT$FIRST_RETAINED_WINDOW_ID + 1) = .TRUE.
                  last_window_id = current_window_id
                  current_window_id = PLT$FIRST_RETAINED_WINDOW_ID + 
     1                                islot - 1
                  get_new_window_id = current_window_id
                  save_last_window = .FALSE.
               else
c                 No more windows left
                  get_new_window_id = -1
               endif
            else
               get_new_window_id = current_window_id
            endif
         endif
      else
         get_new_window_id = PLT$HARDCOPY_WINDOW_ID
      endif
c
      return
      end
c
      subroutine ask_to_retain_window
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      character*1 answer
c
c     We retain windows only for that plot style, and only when
c     we are on a VAXstation...
      if( plot_window_style .eq. PLT$USE_RETAINED_WINDOWS ) then
         if( ws_type .eq. GKS$K_VSII  .or.
     1       ws_type .eq. GKS$K_VSII_GPX .or.
     2       ws_type .eq. GKS$K_DECWINDOWS .or.
     3       ws_type .eq. GKS$K_MOTIF ) then
            call get_char(answer,'Save this window on screen (y/n)? ',0)
            call upcase(answer)
            if( answer .eq. 'Y' ) then
               save_last_window = .TRUE.
            else
               save_last_window = .FALSE.
            endif
         endif
      endif
c
      return
      end
c
      subroutine pop_vs_window(window_id)
      implicit none
c
c     If the workstation id is a VAXstation, then call a GKS escape
c     function to pop the window to the top of the window stack.
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type
c
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) return  !  Bad window id
c
      temp_ws_type = ws_struct(temp_ws_id)%type
CC      if( temp_ws_type .eq. GKS$K_VSII .or.
CC     1    temp_ws_type .eq. GKS$K_VSII_GPX ) then
CC         call pm_escape_pop_workstation(temp_ws_id)
CC      endif
c
      return
      end
c
      subroutine push_vs_window(window_id)
      implicit none
c
c     If the workstation id is a VAXstation, then call a GKS escape
c     function to push the window to the bottom of the window stack.
c
c
      integer window_id
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer lookup_ws_id, temp_ws_id, temp_ws_type
c
      if( .NOT. gks_is_open ) return
c
      temp_ws_id = lookup_ws_id(window_id)
      if( temp_ws_id .eq. PLT$EMPTY_WINDOW_SLOT ) return  !  Bad window id
c
      temp_ws_type = ws_struct(temp_ws_id)%type
CC      if( temp_ws_type .eq. GKS$K_VSII .or.
CC     1    temp_ws_type .eq. GKS$K_VSII_GPX ) then
CC         call pm_escape_push_workstation(temp_ws_id)
CC      endif
c
      return
      end
c
      subroutine plt$error_message(source,message)
      implicit none
c
      include 'sysdep.cmn'
      include 'io.cmn'
c
      character*(*) source, message
c
      integer isource_len, imessage_len, string_len
c
      isource_len  = string_len(source)
      imessage_len = string_len(message)
c     Special case for blank message or source string
      if( imessage_len .eq. 0 ) imessage_len = 1
      if( isource_len  .eq. 0 ) isource_len  = 1
c
c     If message is long, then break it onto two lines
      if( (isource_len + imessage_len + 10) .gt. 80 ) then
         write(luttyo,100) source(1:isource_len),
     1                     message(1:imessage_len)
100      format(' ','(',a,') Error: '/
     1          ' ',3x,a)
      else
         write(luttyo,200) source(1:isource_len),
     1                     message(1:imessage_len)
200      format(' ','(',a,') Error: ',a)
      endif
c
      return
      end
c
      subroutine set_pmark_type(index)
      implicit none
c
c     Reorders GKS polymarkers into the following set:
c
c     1 - circle          5 - filled circle          9 - Dot
c     2 - square          6 - filled square         10 - Plus
c     3 - triangle up     7 - filled triangle up    11 - Asterisk
c     4 - triangle down   8 - filled triangle down  12 - Cross
c
c    13 - bowtie         16 - filled bowtie
c    14 - hourglass      17 - filled hourglass
c    15 - diamond        18 - filled diamond
c
c     > 18 - circle
c
      integer index
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      if( index .eq. 1 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_CIRCLE)
      else if( index .eq. 2 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SQUARE)
      else if( index .eq. 3 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_TRIANGLE_UP)
      else if( index .eq. 4 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_TRIANGLE_DOWN)
      else if( index .eq. 5 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_CIRCLE)
      else if( index .eq. 6 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_SQUARE)
      else if( index .eq. 7 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_TRI_UP)
      else if( index .eq. 8 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_TRI_DOWN)
      else if( index .eq. 9 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_DOT)
      else if( index .eq. 10 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_PLUS)
      else if( index .eq. 11 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_ASTERISK)
      else if( index .eq. 12 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_DIAGONAL_CROSS)
      else if( index .eq. 13 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_BOWTIE)
      else if( index .eq. 14 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_HOURGLASS)
      else if( index .eq. 15 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_DIAMOND)
      else if( index .eq. 16 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_BOWTIE)
      else if( index .eq. 17 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_HGLASS)
      else if( index .eq. 18 ) then
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_SOLID_DIAMOND)
      else
         call GKS$SET_PMARK_TYPE(GKS$K_MARKERTYPE_CIRCLE)
      endif
c
      return
      end
c
      subroutine set_pline_type(index)
      implicit none
c
c     Reorders DEC GKS linetypes into the following set:
c
c     1 - solid           5 - Dash 2 dot          9  - Spaced dash
c     2 - dashed          6 - Dash 3 dot          10 - Spaced dot
c     3 - dotted          7 - Long dash           11 - Double dot
c     4 - dash-dot        8 - Long short dash     12 - Triple dot
c
c     > 12 - solid
c     < 0  - passed directly to GKS$SET_PLINE_LINETYPE
c
      integer index
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      if( index .eq. 1 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
      else if( index .eq. 2 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASHED)
      else if( index .eq. 3 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DOTTED)
      else if( index .eq. 4 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASHED_DOTTED)
      else if( index .eq. 5 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASH_2_DOT)
      else if( index .eq. 6 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DASH_3_DOT)
      else if( index .eq. 7 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_LONG_DASH)
      else if( index .eq. 8 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_LONG_SHORT_DASH)
      else if( index .eq. 9 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SPACED_DASH)
      else if( index .eq. 10 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SPACED_DOT)
      else if( index .eq. 11 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_DOUBLE_DOT)
      else if( index .eq. 12 ) then
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_TRIPLE_DOT)
      else if( index .lt. 0 ) then
         call GKS$SET_PLINE_LINETYPE(index)
      else
         call GKS$SET_PLINE_LINETYPE(GKS$K_LINETYPE_SOLID)
      endif
c
      return
      end
c
      subroutine read_postmini_logical_names
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'defaults.cmn'
c
      integer       rc, global_linetype, get_logical_name
      character*256 translated_name
c
c     Attempt to translate POSTMINI logical names.
c
c     Names defined so far:
c
c     POSTMINI_SOLID_LINES  -- If "1", then force all lines to be solid
c     POSTMINI_LINEWIDTH_SCALE -- If set, then use as a line width scaling
c                           factor instead of built-in device dependent
c                           scaling. Must be greater than 0.0.
c     POSTMINI_HIDDEN_LINE_METHOD -- If "1" then use fill area
c                                    If "2" then use horizon function
c
      use_solid_lines  = .FALSE.
      global_linewidth_scale = 1.0
      hidden_line_method = HIDDEN_LINES_WITH_HORIZON_FCN
c
      rc = get_logical_name('POSTMINI_SOLID_LINES',translated_name)
      if( rc .eq. 0 ) then  ! logical name found
c        convert to integer
         read(translated_name,*,err=100) global_linetype
         if( global_linetype .eq. 1 ) use_solid_lines = .TRUE.
      endif
100   continue
c
      rc = get_logical_name('POSTMINI_LINEWIDTH_SCALE',
     1                    translated_name)
      if( rc .eq. 0 ) then  ! logical name found
c        convert to real
         read(translated_name,*,err=200) global_linewidth_scale
      endif
200   continue
c     Make sure value is relatively safe
      if(global_linewidth_scale .le. 0.0 .or.
     1   global_linewidth_scale .ge. 5.0) global_linewidth_scale = 1.0
c
      rc = get_logical_name('POSTMINI_HIDDEN_LINE_METHOD',
     1                    translated_name)
      if( rc .eq. 0 ) then  ! logical name found
c        convert to real
         read(translated_name,*,err=300) default_hidden_method
      endif
300   continue
      if( default_hidden_method .ne. HIDDEN_LINES_WITH_HORIZON_FCN .and.
     1    default_hidden_method .ne. HIDDEN_LINES_WITH_FILL_AREA )
     2    default_hidden_method = 0
c
      return
      end
c
      subroutine set_color_contour_colormap
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'defaults.cmn'
c
      integer i
c
      if( ws_type .eq. GKS$K_VT125 .or.
     1    ws_type .eq. GKS$K_VT240 ) then
         call GKS$SET_COLOR_REP(ws_id, 3, 0.0, 0.0, 1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id, 2, 1.0, 0.0, 0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id, 1, 0.0, 1.0, 0.0)  ! Green
         max_cont_colors = 3
      else if ( ws_type .eq. GKS$K_VT340 ) then
         if( l_gray_scale ) then
            call GKS$SET_COLOR_REP(ws_id,11,1.0,1.0,1.0)
            call GKS$SET_COLOR_REP(ws_id,10,0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,9, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,8, 0.85,0.85,0.85)
            call GKS$SET_COLOR_REP(ws_id,7, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,6, 0.75,0.75,0.75)
            call GKS$SET_COLOR_REP(ws_id,5, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,4, 0.65,0.65,0.65)
            call GKS$SET_COLOR_REP(ws_id,3, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,2, 0.55,0.55,0.55)
         else if( l_inv_gray_scale ) then
            call GKS$SET_COLOR_REP(ws_id,2, 1.0,1.0,1.0)
            call GKS$SET_COLOR_REP(ws_id,3, 0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,4, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,5, 0.85,0.85,0.85)
            call GKS$SET_COLOR_REP(ws_id,6, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,7, 0.75,0.75,0.75)
            call GKS$SET_COLOR_REP(ws_id,8, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,9, 0.65,0.65,0.65)
            call GKS$SET_COLOR_REP(ws_id,10,0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,11,0.55,0.55,0.55)
         else
            call GKS$SET_COLOR_REP(ws_id,11,1.0,0.0,0.0)  ! Red
            call GKS$SET_COLOR_REP(ws_id,10,1.0,0.5,0.0)  ! Orange
            call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.8,0.0)  ! Gold
            call GKS$SET_COLOR_REP(ws_id,8, 1.0,1.0,0.0)  ! Yellow
            call GKS$SET_COLOR_REP(ws_id,7, 0.0,1.0,0.0)  ! Green
            call GKS$SET_COLOR_REP(ws_id,6, 0.0,0.8,0.0)  ! Dark Green
            call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
            call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.8,1.0)  ! Light blue
            call GKS$SET_COLOR_REP(ws_id,3, 0.0,0.0,1.0)  ! Blue
            call GKS$SET_COLOR_REP(ws_id,2, 0.8,0.0,0.8)  ! Purple
         endif
         max_cont_colors = 10
c     All color workstations (VWS or DECwindows/Motif)
      else if ( (ws_type .eq. GKS$K_VSII .or.
     1           ws_type .eq. GKS$K_DECWINDOWS .or.
     2           ws_type .eq. GKS$K_MOTIF) .and.
     3          color_or_mono .eq. GKS$K_COLOR) then
         call pm_set_contour_colornames
         if( l_gray_scale ) then
            call GKS$SET_COLOR_REP(ws_id,11,0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,10,0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,9, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,8, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,7, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,6, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,5, 0.55,0.55,0.55)
            call GKS$SET_COLOR_REP(ws_id,4, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,3, 0.45,0.45,0.45)
            call GKS$SET_COLOR_REP(ws_id,2, 0.40,0.40,0.40)
         else if( l_inv_gray_scale ) then
            call GKS$SET_COLOR_REP(ws_id,2, 0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,3, 0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,4, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,5, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,6, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,7, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,8, 0.55,0.55,0.55)
            call GKS$SET_COLOR_REP(ws_id,9, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,10,0.45,0.45,0.45)
            call GKS$SET_COLOR_REP(ws_id,11,0.40,0.40,0.40)
         else
            call GKS$SET_COLOR_REP(ws_id,11,1.0,0.0,0.0)  ! Red
            call GKS$SET_COLOR_REP(ws_id,10,1.0,0.5,0.0)  ! Orange
            call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.8,0.0)  ! Gold
            call GKS$SET_COLOR_REP(ws_id,8, 1.0,1.0,0.0)  ! Yellow
            call GKS$SET_COLOR_REP(ws_id,7, 0.0,1.0,0.0)  ! Green
            call GKS$SET_COLOR_REP(ws_id,6, 0.0,0.8,0.0)  ! green3
            call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
            call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.8,1.0)  ! Deep sky blue
            call GKS$SET_COLOR_REP(ws_id,3, 0.0,0.0,1.0)  ! Blue
            call GKS$SET_COLOR_REP(ws_id,2, 0.8,0.0,0.8)  ! Purple
         endif
         max_cont_colors = 10
      else if ( ws_type .eq. GKS$K_LJ250 ) then
c        Colors taylored for LJ250 printer -- jvf
         if(l_gray_scale .or.
     1       hardcopy_colormap .eq. COLORMAP_GRAY ) then
            call GKS$SET_COLOR_REP(ws_id,11,0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,10,0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,9, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,8, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,7, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,6, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,5, 0.55,0.55,0.55)
            call GKS$SET_COLOR_REP(ws_id,4, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,3, 0.45,0.45,0.45)
            call GKS$SET_COLOR_REP(ws_id,2, 0.40,0.40,0.40)
         else if( l_inv_gray_scale .or.
     1            hardcopy_colormap .eq. COLORMAP_INV_GRAY ) then
            call GKS$SET_COLOR_REP(ws_id,2, 0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,3, 0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,4, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,5, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,6, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,7, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,8, 0.55,0.55,0.55)
            call GKS$SET_COLOR_REP(ws_id,9, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,10,0.45,0.45,0.45)
            call GKS$SET_COLOR_REP(ws_id,11,0.40,0.40,0.40)
         else
            call GKS$SET_COLOR_REP(ws_id,11,1.0,0.0,0.0)  ! Red
            call GKS$SET_COLOR_REP(ws_id,10,1.0,0.5,0.0)  ! Orange
            call GKS$SET_COLOR_REP(ws_id,9,1.0,0.7,0.0)   ! Gold
            call GKS$SET_COLOR_REP(ws_id,8,1.0,1.0,0.0)   ! Yellow
            call GKS$SET_COLOR_REP(ws_id,7,0.5,1.0,0.0)   ! Light Green
            call GKS$SET_COLOR_REP(ws_id,6,0.0,1.0,0.0)   ! Green
            call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
            call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.7,1.0)  ! Light blue
            call GKS$SET_COLOR_REP(ws_id,3, 0.0,0.0,1.0)  ! Blue
            call GKS$SET_COLOR_REP(ws_id,2, 0.7,0.0,0.7)  ! Purple
         endif
         max_cont_colors = 10
      else if ( ws_type .eq. GKS$K_LJ250_180DPI ) then
c        Colors taylored for LJ250 printer -- jvf
c        Note, in high resolution mode, the LJ250 can't do gray scale
         call GKS$SET_COLOR_REP(ws_id,8, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,1.0,1.0)  ! White
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,1.0)  ! Magenta
         max_cont_colors = 7
      else if ( ws_type .eq. GKS$K_HP7550 ) then
c        Eight pens, minus 1 for axes, annotations, etc.
         max_cont_colors = 7
      else if ( ws_type .eq. GKS$K_COLOR_POSTSCRIPT .or.
     1          ws_type .eq. GKS$K_COLOR_EPSF ) then
c        Used same colors as for LJ250 printer. Best colors may
c        depend on type of color printer -- jvf
         if( l_gray_scale .or.
     1       hardcopy_colormap .eq. COLORMAP_GRAY ) then
            call GKS$SET_COLOR_REP(ws_id,11,0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,10,0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,9, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,8, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,7, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,6, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,5, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,4, 0.40,0.40,0.40)
            call GKS$SET_COLOR_REP(ws_id,3, 0.25,0.25,0.25)
            call GKS$SET_COLOR_REP(ws_id,2, 0.20,0.20,0.20)
         else if( l_inv_gray_scale .or.
     1       hardcopy_colormap .eq. COLORMAP_INV_GRAY ) then
            call GKS$SET_COLOR_REP(ws_id,2, 0.98,0.98,0.98)
            call GKS$SET_COLOR_REP(ws_id,3, 0.95,0.95,0.95)
            call GKS$SET_COLOR_REP(ws_id,4, 0.90,0.90,0.90)
            call GKS$SET_COLOR_REP(ws_id,5, 0.80,0.80,0.80)
            call GKS$SET_COLOR_REP(ws_id,6, 0.70,0.70,0.70)
            call GKS$SET_COLOR_REP(ws_id,7, 0.60,0.60,0.60)
            call GKS$SET_COLOR_REP(ws_id,8, 0.50,0.50,0.50)
            call GKS$SET_COLOR_REP(ws_id,9, 0.40,0.40,0.40)
            call GKS$SET_COLOR_REP(ws_id,10,0.25,0.25,0.25)
            call GKS$SET_COLOR_REP(ws_id,11,0.20,0.20,0.20)
         else
            call GKS$SET_COLOR_REP(ws_id,11,1.0,0.0,0.0)  ! Red
            call GKS$SET_COLOR_REP(ws_id,10,1.0,0.5,0.0)  ! Orange
            call GKS$SET_COLOR_REP(ws_id,9,1.0,0.7,0.0)   ! Gold
            call GKS$SET_COLOR_REP(ws_id,8,1.0,1.0,0.0)   ! Yellow
            call GKS$SET_COLOR_REP(ws_id,7,0.5,1.0,0.0)   ! Light Green
            call GKS$SET_COLOR_REP(ws_id,6,0.0,1.0,0.0)   ! Green
            call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
            call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.7,1.0)  ! Light blue
            call GKS$SET_COLOR_REP(ws_id,3, 0.0,0.0,1.0)  ! Blue
            call GKS$SET_COLOR_REP(ws_id,2, 0.7,0.0,0.7)  ! Purple
         endif
         max_cont_colors = 10
      else
         max_cont_colors = 1
      endif
c
c     User defined color values.
      do i = 0, MAX_RGB_VALUES
         if( l_rgb(i) ) then
            call GKS$SET_COLOR_REP(ws_id,i,rgb(i,1),rgb(i,2),rgb(i,3))
         endif
      enddo
c
      return
      end
c
      subroutine set_default_colormap
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
      include 'defaults.cmn'
c
      integer i
c
c     Note: red/green/blue values from /usr/lib/X11/rgb.txt
c
      if( ws_type .eq. GKS$K_VT125BW .or.
     1    ws_type .eq. GKS$K_VT240BW .or.
     2    ws_type .eq. GKS$K_VT125   .or.
     3    ws_type .eq. GKS$K_VT240 ) then
         call GKS$SET_COLOR_REP(ws_id, 3, 0.0, 0.0, 1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id, 2, 0.0, 1.0, 0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id, 1, 1.0, 0.0, 0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id, 0, 1.0, 1.0, 1.0)  ! White
      else if ( ws_type .eq. GKS$K_VT340 ) then
         call GKS$SET_COLOR_REP(ws_id,15,0.9297,0.5078,0.9297) ! Violet
         call GKS$SET_COLOR_REP(ws_id,14,0.74,0.74,0.74)       ! Gray
         call GKS$SET_COLOR_REP(ws_id,13,0.644,0.164,0.164)    ! Brown
         call GKS$SET_COLOR_REP(ws_id,12,0.625,0.125,0.9375)   ! Purple
         call GKS$SET_COLOR_REP(ws_id,11,1.0,0.645,0.0)  ! Orange
         call GKS$SET_COLOR_REP(ws_id,10,0.676,0.844,0.898)  ! Light Blue
         call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.840,0.0)  ! Gold
         call GKS$SET_COLOR_REP(ws_id,8, 0.563,0.930,0.563)  ! Light Green
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,0.0,1.0)  ! Magenta
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,1, 0.0,0.0,0.0)  ! Black
         call GKS$SET_COLOR_REP(ws_id,0, 1.0,1.0,1.0)  ! White
c     All color workstations (VWS or DECwindows/Motif)
      else if ( (ws_type .eq. GKS$K_VSII .or.
     1           ws_type .eq. GKS$K_DECWINDOWS .or.
     2           ws_type .eq. GKS$K_MOTIF) .and.
     3          color_or_mono .eq. GKS$K_COLOR) then
         call GKS$SET_COLOR_REP(ws_id,15,0.9297,0.5078,0.9297) ! Violet
         call GKS$SET_COLOR_REP(ws_id,14,0.74,0.74,0.74)       ! Gray
         call GKS$SET_COLOR_REP(ws_id,13,0.644,0.164,0.164)    ! Brown
         call GKS$SET_COLOR_REP(ws_id,12,0.625,0.125,0.9375)   ! Purple
         call GKS$SET_COLOR_REP(ws_id,11,1.0,0.6445,0.0)  ! Orange
         call GKS$SET_COLOR_REP(ws_id,10,0.676,0.844,0.898)  ! Light Blue
         call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.840,0.0)  ! Gold
         call GKS$SET_COLOR_REP(ws_id,8, 0.563,0.930,0.563)  ! Light Green
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,0.0,1.0)  ! Magenta
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,1, 0.0,0.0,0.0)  ! Black
         call GKS$SET_COLOR_REP(ws_id,0, 1.0,1.0,1.0)  ! White
      else if ( ws_type .eq. GKS$K_LJ250 ) then
         call GKS$SET_COLOR_REP(ws_id,15,0.9297,0.5078,0.9297) ! Violet
         call GKS$SET_COLOR_REP(ws_id,14,0.74,0.74,0.74)       ! Gray
         call GKS$SET_COLOR_REP(ws_id,13,0.644,0.164,0.164)    ! Brown
         call GKS$SET_COLOR_REP(ws_id,12,0.625,0.125,0.9375)   ! Purple
         call GKS$SET_COLOR_REP(ws_id,11,1.0,0.6445,0.0)  ! Orange
         call GKS$SET_COLOR_REP(ws_id,10,0.676,0.844,0.898)  ! Light blue
         call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.840,0.0)  ! Gold
         call GKS$SET_COLOR_REP(ws_id,8, 0.563,0.930,0.563)  ! Light Green
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,0.0,1.0)  ! Magenta
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,1, 0.0,0.0,0.0)  ! Black
      else if ( ws_type .eq. GKS$K_LJ250_180DPI ) then
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,0.0,1.0)  ! Magenta
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,1, 0.0,0.0,0.0)  ! Black
      else if ( ws_type .eq. GKS$K_COLOR_POSTSCRIPT .or.
     1          ws_type .eq. GKS$K_COLOR_EPSF ) then
         call GKS$SET_COLOR_REP(ws_id,15,0.9297,0.5078,0.9297) ! Violet
         call GKS$SET_COLOR_REP(ws_id,14,0.74,0.74,0.74)       ! Gray
         call GKS$SET_COLOR_REP(ws_id,13,0.644,0.164,0.164)    ! Brown
         call GKS$SET_COLOR_REP(ws_id,12,0.625,0.125,0.9375)   ! Purple
         call GKS$SET_COLOR_REP(ws_id,11,1.0,0.6445,0.0)  ! Orange
         call GKS$SET_COLOR_REP(ws_id,10,0.676,0.844,0.898)  ! Light blue
         call GKS$SET_COLOR_REP(ws_id,9, 1.0,0.840,0.0)  ! Gold
         call GKS$SET_COLOR_REP(ws_id,8, 0.563,0.930,0.563)  ! Light Green
         call GKS$SET_COLOR_REP(ws_id,7, 1.0,1.0,0.0)  ! Yellow
         call GKS$SET_COLOR_REP(ws_id,6, 1.0,0.0,1.0)  ! Magenta
         call GKS$SET_COLOR_REP(ws_id,5, 0.0,1.0,1.0)  ! Cyan
         call GKS$SET_COLOR_REP(ws_id,4, 0.0,0.0,1.0)  ! Blue
         call GKS$SET_COLOR_REP(ws_id,3, 0.0,1.0,0.0)  ! Green
         call GKS$SET_COLOR_REP(ws_id,2, 1.0,0.0,0.0)  ! Red
         call GKS$SET_COLOR_REP(ws_id,1, 0.0,0.0,0.0)  ! Black
*        Workaround for bug in Digital GKS (Unix) for color epsf driver
*        The default is white, anyway...
         if( ws_type .ne. GKS$K_COLOR_EPSF ) then
            call GKS$SET_COLOR_REP(ws_id,0, 1.0,1.0,1.0)  ! White
         endif
      endif
c
c     User defined color values.
      do i = 0, MAX_RGB_VALUES
         if( l_rgb(i) ) then
            call GKS$SET_COLOR_REP(ws_id,i,rgb(i,1),rgb(i,2),rgb(i,3))
         endif
      enddo
c
      call pm_set_xy_colornames
c
      return
      end
c
      subroutine get_plotfile_extension(device,ext)
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      character*(*) device, ext
c
      character*20  buffer
c
      buffer = device
      call upcase(buffer)
c
      if( buffer(1:1) .eq. 'P' .or. buffer(1:7) .eq. 'COLOR_P' .or.
     1    buffer(1:1) .eq. 'E' .or. buffer(1:7) .eq. 'COLOR_E' ) then
         ext = '.ps'
      else if( buffer(1:1) .eq. 'H' ) then
         ext = '.hpgl'
      else if( buffer(1:2) .eq. 'LJ' ) then
         ext = '.six'
      else if( buffer(1:2) .eq. 'LN' ) then
         ext = '.ln3'
      else if( buffer(1:1) .eq. 'D' ) then
         ext = '.ddif'
      else
         ext = '.plt'
      endif
c
      return
      end
c
      subroutine format_mathmode_sci(value, string, ilen)
      implicit none
c
      real value
      character*(*) string
      integer ilen
c
c     Locals
c
      real scaled
      integer iexp, iwidth, i
      integer string_len
      character*30 buffer
c
c     First, convert to mantissa, exponent
      call cvt_sci_not(value,scaled,iexp)
c
c     If exponent is zero, then do not print exponent
      if( iexp .eq. 0 ) then
         if( ABS(scaled) .lt. 0.01 ) then
            write(buffer,2014) scaled
2014        format(f9.4)
         else
            write(buffer,2010) scaled
2010        format(f9.3)
         endif
      else
         iwidth = 1
         if( iexp .lt. 0 )      iwidth = iwidth + 1  ! sign
         if( ABS(iexp) .gt. 9 ) iwidth = iwidth + 1  ! two digits in exponent
         if( ABS(iexp) .gt. 99) iwidth = iwidth + 1  ! three digits in exponent
c        
         if( ABS(scaled - 1.0) .lt. 0.001 ) then
            write(buffer,2011) iexp
2011        format('10^{',i<iwidth>,'}')
         else if( ABS(scaled + 1.0) .lt. 0.001 ) then
            write(buffer,2012) iexp
2012        format('-10^{',i<iwidth>,'}')
         else
            write(buffer,2013) scaled, iexp
2013        format(f6.2,' x 10^{',i<iwidth>,'}')
         endif
      endif
c
c     Remove any initial blanks
      ilen = string_len(buffer)
      i = 1
      do while ( buffer(i:i) .eq. ' ' .and. i .le. ilen )
         i = i + 1
      end do
      string = buffer(i:ilen)
      ilen = string_len(string)
c
      return
      end
c
      subroutine plt$get_error_message(id,message)
      implicit none
c
      include 'const.h'
      include 'sysdep.cmn'
      include 'plot.cmn'
c
      integer id
      character*(*) message
c
      if( id .eq. PLT$BAD_DEF_WSTYPE   ) then
         message =
     1'Invalid value for GKS workstation type, GKS conid or X display'
      else if( id .eq. PLT$WINDOW_INUSE   ) then
         message = '(internal) Window already in use'
      else if( id .eq. PLT$TOO_MANY_WINDOWS ) then
         message = 'Too many windows in use, please delete some'
      else if( id .eq. PLT$BAD_WINDOW_ID ) then
         message = '(internal) Invalid window id'
      else if( id .eq. PLT$GKS_OPEN_FAILED ) then
         message = 'Open of GKS workstation failed'
      else if( id .eq. PLT$OUT_OF_NOTE_STORAGE ) then
         message = 'Ran out of internal storage for new annotations'
      else if( id .eq. PLT$BAD_NOTE_TYPE ) then
         message = '(internal) Bad annotation type'
      else if( id .eq. PLT$INPUT_CANCELLED ) then
         message = 'Input cancelled by user'
      else if( id .eq. PLT$BAD_NOTE_ID ) then
         message = '(internal) Bad annotation id'
      else if( id .eq. PLT$NOTE_ALREADY_FREE ) then
         message = '(internal) Annotation already marked as free'
      else if( id .eq. PLT$INVALID_MINMAX ) then
         message = '(internal) Invalid window min/max'
      else
         message = 'Unknown message id'
      endif
c
      return
      end
c
      subroutine pm_get_ws_viewport(ws_type,
     1                     dev_size_x, dev_size_y,
     2                     window_scale_factor,
     3                     hc_xscale_offset, hc_yscale_offset,
     4                     hc_scale_factor, hc_aspect_ratio,
     5                     l_portrait,
     6                     ws_viewport_lx, ws_viewport_ly,
     7                     ws_viewport_ux, ws_viewport_uy)
      implicit none
c
      include 'gksdefs.cmn'
c
      integer ws_type
      real dev_size_x, dev_size_y, window_scale_factor,
     1     hc_xscale_offset, hc_yscale_offset, hc_scale_factor,
     2     hc_aspect_ratio, ws_viewport_lx, ws_viewport_ly,
     3     ws_viewport_ux, ws_viewport_uy
      logical l_portrait
c
      real device_x, device_y
c
c     ws_type is GKS workstation type with high order bits set to zero,
c     so we have the 'generic' device.
c
c     Determine size of hardcopy surface in device coordinates.
      if ( l_portrait ) then
c        Portrait mode
c        We use as much of the full device space as we can,
c        consistent with the aspect ratio...
         device_x = dev_size_x
         device_y = MIN(dev_size_y,
     1                  hc_aspect_ratio*dev_size_x)
      else
c        Landscape mode
         device_x = MIN(dev_size_x,dev_size_y/hc_aspect_ratio)
         device_y = dev_size_y
      endif
c
c     (N.B. GKS$K_VSII == old VMS UIS windowing system)
      if( (ws_type .eq. GKS$K_VSII) .or. 
     1    (ws_type .eq. GKS$K_DECWINDOWS) .or.
     2    (ws_type .eq. GKS$K_MOTIF) ) then
c        Use only a portion of the workstation screen
c        The default scale factor of 1 gives 36% of the screen.
c        Note: since dev_size_x != dev_size_y, the plot window isn't
c              quite square.
         ws_viewport_lx = (1.0 - window_scale_factor)*dev_size_x
         ws_viewport_ly = (1.0 - window_scale_factor)*dev_size_y
         ws_viewport_ux = dev_size_x
         ws_viewport_uy = dev_size_y
      else if( ws_type .eq. GKS$K_VT125BW  .or.
     1         ws_type .eq. GKS$K_VT125    .or.
     1         ws_type .eq. GKS$K_VT240BW  .or.
     1         ws_type .eq. GKS$K_VT240    .or.
     1         ws_type .eq. GKS$K_VT330    .or.
     1         ws_type .eq. GKS$K_VT340  ) then
         ws_viewport_lx = 0.0
         ws_viewport_ly = 0.0
         ws_viewport_ux = dev_size_x
         ws_viewport_uy = dev_size_y
      else if(ws_type .eq. GKS$K_LJ250 .or.
     1        ws_type .eq. GKS$K_LJ250_180DPI) then
c        Use slightly smaller portion of the workstation area to
c        avoid problems with LJ250 (thinks it's getting close to edge
c        of paper and inserts space to skip over fan fold).
         ws_viewport_lx = (hc_xscale_offset + 0.05)*dev_size_x
         ws_viewport_ly = hc_yscale_offset*dev_size_y
         ws_viewport_ux = ws_viewport_lx + hc_scale_factor*device_x
         ws_viewport_uy = ws_viewport_ly + hc_scale_factor*device_y
c        Safeguard against user pushing plot off device
         ws_viewport_ux = MIN(ws_viewport_ux,dev_size_x)
         ws_viewport_uy = MIN(ws_viewport_uy,dev_size_y)
      else
         ws_viewport_lx = hc_xscale_offset*dev_size_x
         ws_viewport_ly = hc_yscale_offset*dev_size_y
         ws_viewport_ux = ws_viewport_lx + hc_scale_factor*device_x
         ws_viewport_uy = ws_viewport_ly + hc_scale_factor*device_y
c        Safeguard against user pushing plot off device
         ws_viewport_ux = MIN(ws_viewport_ux,dev_size_x)
         ws_viewport_uy = MIN(ws_viewport_uy,dev_size_y)
      endif
c
      return
      end
c
      integer function pm_color_to_rgb(color,red,green,blue)
      implicit none
c
      character*(*) color
      real red, green, blue
c
c     This subroutine converts a color name to rgb value
c     Color -> rgb table from /usr/lib/X11/rgb.txt
c
c     locals
      character*80 string
c
      string = color
      call lowercase(string)
c
      pm_color_to_rgb = 0
      if( string .eq. 'white' ) then
         red = 1.0
         green = 1.0
         blue = 1.0
      else if ( string .eq. 'black' ) then
         red = 0.0
         green = 0.0
         blue = 0.0
      else if ( string .eq. 'red' ) then
         red = 1.0
         green = 0.0
         blue = 0.0
      else if ( string .eq. 'green' ) then
         red = 0.0
         green = 1.0
         blue = 0.0
      else if ( string .eq. 'blue' ) then
         red = 0.0
         green = 0.0
         blue = 1.0
      else if ( string .eq. 'cyan' ) then
         red = 0.0
         green = 1.0
         blue = 1.0
      else if ( string .eq. 'magenta' ) then
         red = 1.0
         green = 0.0
         blue = 1.0
      else if ( string .eq. 'yellow' ) then
         red = 1.0
         green = 1.0
         blue = 0.0
      else if ( string .eq. 'gray' ) then
         red = 0.74
         green = 0.74
         blue = 0.74
      else if ( string .eq. 'brown' ) then
         red = 0.644
         green = 0.164
         blue = 0.164
      else if ( string .eq. 'violet' ) then
         red = 0.9297
         green = 0.5078
         blue = 0.9297
      else if ( string .eq. 'orange' ) then
         red = 1.0
         green = 0.6445
         blue = 0.0
      else if ( string .eq. 'purple' ) then
         red = 0.625
         green = 0.125
         blue = 0.9375
      else if ( string .eq. 'gold' ) then
         red = 1.0
         green = 0.840
         blue = 0.0
      else if ( string .eq. 'lightblue' ) then
         red = 0.676
         green = 0.844
         blue = 0.898
      else if ( string .eq. 'lightgreen' ) then
         red = 0.563
         green = 0.930
         blue = 0.563
      else
c        Could not decode color
         red   = 0.0
         green = 0.0
         blue  = 0.0
         pm_color_to_rgb = -1
      endif
c
      return
      end
c
      integer function pm_color_to_index(color)
      implicit none
c
      character*(*) color
c
c     This subroutine converts a color name to a color index
c
      include 'const.h'
      include 'defaults.cmn'
c
      integer i, icolor
      character*32 string
c
      string = color
      call lowercase(string)
      icolor = -1
      do i=0,MAX_RGB_VALUES
         if( string .eq. color_names(i) ) then
            icolor = i
            goto 100
         endif
      end do
100   continue
      if( icolor .eq. -1 ) then
c        Try for 'invisible', 'off' or 'none'
         if( string .eq. 'invisible' .or. string .eq. 'off' .or.
     1       string .eq. 'none' ) then
            icolor = 0
         else
c           Try for integer. On error condition, branch to exit
            read(string,*,end=1000,err=1000) icolor
            icolor = MAX(0,MIN(icolor,MAX_RGB_VALUES))
         endif
      endif
c
1000  continue
      pm_color_to_index = icolor
      return
      end
c
      subroutine pm_reset_colornames
      implicit none
c
      include 'const.h'
      include 'defaults.cmn'
c
      integer i
c
c     Delete any user defined colors
c
      do i=0,MAX_RGB_VALUES
         l_rgb(i) = .FALSE.
      end do
c
      call pm_set_xy_colornames
c
      return
      end
c
      subroutine pm_set_contour_colornames
      implicit none
c
      include 'sysdep.cmn'
      include 'defaults.cmn'
c
c     Note: color names from /usr/lib/X11/rgb.txt
c
      if( l_gray_scale ) then
         if( .NOT. l_rgb(11) ) color_names(11) = 'gray98'
         if( .NOT. l_rgb(10) ) color_names(10) = 'gray95'
         if( .NOT. l_rgb(9) ) color_names(9) = 'gray90'
         if( .NOT. l_rgb(8) ) color_names(8) = 'gray80'
         if( .NOT. l_rgb(7) ) color_names(7) = 'gray70'
         if( .NOT. l_rgb(6) ) color_names(6) = 'gray60'
         if( .NOT. l_rgb(5) ) color_names(5) = 'gray55'
         if( .NOT. l_rgb(4) ) color_names(4) = 'gray50'
         if( .NOT. l_rgb(3) ) color_names(3) = 'gray45'
         if( .NOT. l_rgb(2) ) color_names(2) = 'gray40'
      else if( l_inv_gray_scale ) then
         if( .NOT. l_rgb(2) ) color_names(2) = 'gray98'
         if( .NOT. l_rgb(3) ) color_names(3) = 'gray95'
         if( .NOT. l_rgb(4) ) color_names(4) = 'gray90'
         if( .NOT. l_rgb(5) ) color_names(5) = 'gray80'
         if( .NOT. l_rgb(6) ) color_names(6) = 'gray70'
         if( .NOT. l_rgb(7) ) color_names(7) = 'gray60'
         if( .NOT. l_rgb(8) ) color_names(8) = 'gray55'
         if( .NOT. l_rgb(9) ) color_names(9) = 'gray50'
         if( .NOT. l_rgb(10) ) color_names(10) = 'gray45'
         if( .NOT. l_rgb(11) ) color_names(11) = 'gray40'
      else
         if( .NOT. l_rgb(11) ) color_names(11) = 'red'
         if( .NOT. l_rgb(10) ) color_names(10) = 'orange'
         if( .NOT. l_rgb(9) ) color_names(9) = 'gold'
         if( .NOT. l_rgb(8) ) color_names(8) = 'yellow'
         if( .NOT. l_rgb(7) ) color_names(7) = 'green'
         if( .NOT. l_rgb(6) ) color_names(6) = 'green3'
         if( .NOT. l_rgb(5) ) color_names(5) = 'cyan'
         if( .NOT. l_rgb(4) ) color_names(4) = 'deepskyblue'
         if( .NOT. l_rgb(3) ) color_names(3) = 'blue'
         if( .NOT. l_rgb(2) ) color_names(2) = 'purple'
      endif
c
      return
      end
c
      subroutine pm_set_xy_colornames
      implicit none
c
      include 'const.h'
      include 'defaults.cmn'
c
      if( .NOT. l_rgb(0) ) color_names(0) = 'white'
      if( .NOT. l_rgb(1) ) color_names(1) = 'black'
      if( .NOT. l_rgb(2) ) color_names(2) = 'red'
      if( .NOT. l_rgb(3) ) color_names(3) = 'green'
      if( .NOT. l_rgb(4) ) color_names(4) = 'blue'
      if( .NOT. l_rgb(5) ) color_names(5) = 'cyan'
      if( .NOT. l_rgb(6) ) color_names(6) = 'magenta'
      if( .NOT. l_rgb(7) ) color_names(7) = 'yellow'
      if( .NOT. l_rgb(8) ) color_names(8) = 'lightgreen'
      if( .NOT. l_rgb(9) ) color_names(9) = 'gold'
      if( .NOT. l_rgb(10) ) color_names(10) = 'lightblue'
      if( .NOT. l_rgb(11) ) color_names(11) = 'orange'
      if( .NOT. l_rgb(12) ) color_names(12) = 'purple'
      if( .NOT. l_rgb(13) ) color_names(13) = 'brown'
      if( .NOT. l_rgb(14) ) color_names(14) = 'gray'
      if( .NOT. l_rgb(15) ) color_names(15) = 'violet'
c
      return
      end
c
      integer function pm_symbol_to_index(symbol)
      implicit none
c
      character*(*) symbol
c
c     This subroutine converts a symbol name to a symbol index
c
      include 'const.h'
      include 'defaults.cmn'
c
      integer i, isymbol
      character*32 string
c
      string = symbol
      call lowercase(string)
      isymbol = -1
      do i=0,MAX_SYMBOL_VALUES
         if( string .eq. symbol_names(i) ) then
            isymbol = i
            goto 100
         endif
      end do
100   continue
      if( isymbol .eq. -1 ) then
c        Try a few alternatives to "none"
         if( string .eq. 'off' .or. string .eq. 'omit' ) then
            isymbol = 0
         endif
      endif
      if( isymbol .eq. -1 ) then
c        Try for integer. On error condition, branch to exit
         read(string,*,end=1000,err=1000) isymbol
         isymbol = MAX(0,MIN(isymbol,MAX_SYMBOL_VALUES))
      endif
c
1000  continue
      pm_symbol_to_index = isymbol
      return
      end
c
      integer function pm_linetype_to_index(linetype)
      implicit none
c
      character*(*) linetype
c
c     This subroutine converts a linetype name to a linetype index
c
      include 'const.h'
      include 'defaults.cmn'
c
      integer i, ilinetype
      character*32 string
c
      string = linetype
      call lowercase(string)
      ilinetype = -1
      do i=0,MAX_LINETYPE_VALUES
         if( string .eq. line_names(i) ) then
            ilinetype = i
            goto 100
         endif
      end do
100   continue
      if( ilinetype .eq. -1 ) then
c        Try a few alternatives to "none"
         if( string .eq. 'off' .or. string .eq. 'omit' ) then
            ilinetype = 0
         endif
      endif
      if( ilinetype .eq. -1 ) then
c        Try for integer. On error condition, branch to exit
         read(string,*,end=1000,err=1000) ilinetype
         ilinetype = MAX(0,MIN(ilinetype,MAX_LINETYPE_VALUES))
      endif
c
1000  continue
      pm_linetype_to_index = ilinetype
      return
      end
c
      integer function find_left_index(vec, value, npts)
      implicit none
c
c     Returns index "i" into vector vec such that vec(i) <= value < vec(i+1)
c
      integer npts
      real vec(npts), value
c
      integer i
c
      find_left_index = npts
      do 100 i=1,npts
         if( vec(i) .gt. value ) then
            find_left_index = i-1
            goto 200
         endif
100   continue
c     Special case for value less than left boundary
200   if( find_left_index .eq. 0 ) find_left_index = 1
c
      return
      end
c
      integer function find_right_index(vec, value, npts)
      implicit none
c
c     Returns index "i" into vector vec such that vec(i-1) < value <= vec(i)
c
      integer npts
      real vec(npts), value
c
      integer i
c
      find_right_index = 1
      do 100 i=npts,1,-1
         if( vec(i) .lt. value ) then
            find_right_index = i+1
            goto 200
         endif
100   continue
200   if( find_right_index .eq. (npts+1) ) find_right_index = npts
c
      return
      end
c
      subroutine recompute_minmax(data, npts, dmin, dmax,
     1           dmin_scaled, dmax_scaled, majtic, ticfreq, iuser_scale,
     2           iaxis_scale, do_abs, do_log, do_uscale, work)
      implicit none
c
      include 'sysdep.cmn'
c
      integer npts, ticfreq, iuser_scale, iaxis_scale
      real data(npts), work(npts)
      real dmin, dmax, dmin_scaled, dmax_scaled, majtic
      logical do_abs, do_log, do_uscale
c
c     locals
      integer i
      real user_scale, axis_scale, log_small
c
      log_small = ALOG10(PM_MIN_FLOAT)
      if( do_log ) then
         dmin = ALOG10(PM_MAX_FLOAT)
         dmax = log_small
      else if( do_abs ) then
         dmin = PM_MAX_FLOAT
         dmax = 0.0
      else
         dmin =  PM_MAX_FLOAT
         dmax = -PM_MAX_FLOAT
      endif
      if( do_uscale ) then
         user_scale = 10.0**iuser_scale
      else
         user_scale = 1.0
      endif
      do i=1,npts
         if( do_abs .or. do_log ) then
            if( do_uscale ) then
               work(i) = ABS(data(i)/user_scale)
            else
               work(i) = ABS(data(i))
            endif
            if( do_log ) then
c              check for log(0.0), fudge
               if( work(i) .eq. 0.0 ) then
                  work(i) = log_small
               else
                  work(i) = ALOG10(work(i))
               endif
            endif
         else
            if( do_uscale ) then
               work(i) = data(i)/user_scale
            else
               work(i) = data(i)
            endif
         endif
      end do
      do i=1,npts
         if( dmin .gt. work(i) .and. work(i) .ne. log_small)
     1      dmin = work(i)
         if( dmax .lt. work(i) ) dmax = work(i)
      end do
      call get_default_limits(dmin, dmax, dmin_scaled,
     1     dmax_scaled, majtic, ticfreq, iaxis_scale, do_log)
      if( do_log ) then
         axis_scale = 1.0
         dmin = 10.0**dmin
         dmax = 10.0**dmax
         dmin_scaled = 10.0**dmin_scaled
         dmax_scaled = 10.0**dmax_scaled
      else
         axis_scale  = 10.0**iaxis_scale
         if( do_uscale ) then
            majtic      = majtic*axis_scale
CC            dmin = dmin*axis_scale
CC            dmax = dmax*axis_scale
            dmin_scaled = dmin_scaled*axis_scale
            dmax_scaled = dmax_scaled*axis_scale
         endif
         dmin = dmin*user_scale
         dmax = dmax*user_scale
      endif
c
      return
      end
c
      subroutine pm_get_papersize(buffer,size_mask,rc)
      implicit none
c
      include 'gksdefs.cmn'
c
      character*(*) buffer
      integer size_mask, rc
c
      rc = 0
      call upcase(buffer)
c
      if( buffer .eq. 'A' ) then
         size_mask = GKS$M_PAPERSIZE_A
      else if( buffer .eq. 'LEGAL' ) then
         size_mask = GKS$M_PAPERSIZE_LEGAL
      else if( buffer .eq. 'B' ) then
         size_mask = GKS$M_PAPERSIZE_B
      else if( buffer .eq. 'C' ) then
         size_mask = GKS$M_PAPERSIZE_C
      else if( buffer .eq. 'D' ) then
         size_mask = GKS$M_PAPERSIZE_D
      else if( buffer .eq. 'E' ) then
         size_mask = GKS$M_PAPERSIZE_E
      else if( buffer .eq. 'COMP' ) then
         size_mask = GKS$M_PAPERSIZE_COMP
      else if( buffer .eq. 'A0' ) then
         size_mask = GKS$M_PAPERSIZE_A0
      else if( buffer .eq. 'A1' ) then
         size_mask = GKS$M_PAPERSIZE_A1
      else if( buffer .eq. 'A2' ) then
         size_mask = GKS$M_PAPERSIZE_A2
      else if( buffer .eq. 'A3' ) then
         size_mask = GKS$M_PAPERSIZE_A3
      else if( buffer .eq. 'A4' ) then
         size_mask = GKS$M_PAPERSIZE_A4
      else if( buffer .eq. 'A5' ) then
         size_mask = GKS$M_PAPERSIZE_A5
      else if( buffer .eq. 'B4' ) then
         size_mask = GKS$M_PAPERSIZE_B4
      else if( buffer .eq. 'B5' ) then
         size_mask = GKS$M_PAPERSIZE_B5
      else
         size_mask = 0
         rc = 1
      endif
c
      return
      end

