From:	CSBVAX::MRGATE!@KL.SRI.Com:scgvaxd!ENGVAX.SCG.HAC.COM!PORTIA@seismo.CSS.GOV@SMTP 14-AUG-1987 22:55
To:	EVERHART
Subj:	new SWING source, part 4 of 5 (4.for)

Received: from seismo.CSS.GOV by KL.SRI.COM with TCP; Fri 14 Aug 87 15:48:32-PDT
Received: from scgvaxd.UUCP by seismo.CSS.GOV (5.54/1.14) with UUCP 
	id AA10089; Fri, 14 Aug 87 18:46:49 EDT
Received: by scgvaxd.SCG.HAC.COM (5.51/smail2.2/04-02-87)
	id AA11179; Fri, 14 Aug 87 08:58:27 PDT
Message-Id: <8708141558.AA11179@scgvaxd.SCG.HAC.COM>
Date: Thu, 13 Aug 87 23:03 PDT
From: Portia 616-2635 <PORTIA@engvax.scg.hac.com>
Subject: new SWING source, part 4 of 5 (4.for)
To: info-vax%kl.sri.COM@scgvaxd.scg.hac.com
X-Vms-To: INFO-VAX-SUBMIT

$ show default
$ check_sum = 1377003600
$ write sys$output "Creating 4.FOR"
$ create 4.FOR
$ DECK/DOLLARS="$*$*EOD*$*$"
      INTEGER*4 FUNCTION MODIFY_FILE_PROT ( FILE, PROT, CODE )

C     Modifies  the protection  on a specified  file.  The file's access
C     control list, if it  has one, is not modified.  The status of  the
C     operation is returned as a function value.

C     This routine will fail if the protection on the file (prior to the
C     modification) is such that we do not have read and write access to
C     it.  It will also fail if the file has already been opened without
C     write-shareability.

C     Greg Janee, 19-MAR-1986

C-----------------------------------------------------------------------

C     Arguments:
C
C     FILE      type:      character string
C               access:    read only
C               mechanism: by descriptor, fixed-length descriptor
C
C     The filename of  the file whose  protection is to be modified.  If
C     the string is larger than 255 bytes, only the first 255  bytes are
C     used.
C
C     PROT      type:      unsigned word
C               access:    read only
C               mechanism: by reference
C
C     The bit mask  that is to replace  or modify the  file's protection
C     bits.  The mask  should be  specified in  the format  described by
C     section 12.13 of the VAX Record Management Services Reference Man-
C     ual.
C
C     CODE      type:      signed longword integer
C               access:    read only
C               mechanism: by reference
C
C     The type of modification to be performed on  the file's protection
C     bits.  A  value of 0 indicates the  bits are to be replaced by the
C     PROT argument;  values  1, 2, and 3 indicate  the bits  are  to be
C     ANDed, inclusive-ORed, or  exclusive-ORed with the  PROT argument,
C     respectively.  The  protection  bits  are left  unchanged  for all
C     other values of this argument.

C=======================================================================

      IMPLICIT  NONE

      INCLUDE   '($FABDEF)'
      INCLUDE   '($XABDEF)'
      INCLUDE   '($XABPRODEF)'

C     We have to define our own structure to access a XABPRO because DEC
C     is too stupid to define theirs correctly.

      STRUCTURE /XABPRO/
         UNION
            MAP
               RECORD /XABDEF/     A
            END MAP
            MAP
               RECORD /XABPRODEF1/ B
            END MAP
         END UNION
      END STRUCTURE

      CHARACTER FILE*(*)
      INTEGER*2 PROT
      INTEGER*4 CODE

      RECORD    /FABDEF/ FAB
      RECORD    /XABPRO/ XAB

      INTRINSIC JMIN0
      INTRINSIC LEN
      EXTERNAL  LIB$INSV
      EXTERNAL  LIB$MOVC5
      EXTERNAL  SYS$CLOSE
      INTEGER*4 SYS$CLOSE
      EXTERNAL  SYS$OPEN
      INTEGER*4 SYS$OPEN

C-----------------------------------------------------------------------

C     First initialize and  link a FAB and XAB.  Note that  if we do not
C     open the  file with some sort  of write access the protection will
C     not be changed.

      CALL LIB$MOVC5 ( 0, 0, 0, FAB$C_BLN, FAB )

      FAB.FAB$B_BID = FAB$C_BID
      FAB.FAB$B_BLN = FAB$C_BLN
      FAB.FAB$B_FAC = FAB$M_PUT
      FAB.FAB$L_FNA = %LOC( FILE )
      CALL LIB$INSV ( JMIN0( LEN(FILE), 255 ), 0, 8, FAB.FAB$B_FNS )

C     RMS will balk if the  file has been opened by  someone else.  With
C     the following SHR options we'll at least get through the case when
C     the file has been opened write-shared.

      FAB.FAB$B_SHR = FAB$M_SHRPUT .OR. FAB$M_SHRGET .OR.
     .                FAB$M_SHRDEL .OR. FAB$M_SHRUPD .OR. FAB$M_UPI

      FAB.FAB$L_XAB = %LOC( XAB )

      CALL LIB$MOVC5 ( 0, 0, 0, XAB$C_PROLEN, XAB )

      XAB.A.XAB$B_BLN = XAB$C_PROLEN
      XAB.A.XAB$B_COD = XAB$C_PRO

C-----------------------------------------------------------------------

C     There is  no RMS service to  change file protections.  To do so we
C     open the file with write access and then close  it with a new pro-
C     tection mask.

      MODIFY_FILE_PROT = SYS$OPEN( FAB )
      IF ( .NOT.MODIFY_FILE_PROT ) RETURN

      IF     ( CODE .EQ. 0 ) THEN
         XAB.B.XAB$W_PRO =                       PROT
      ELSEIF ( CODE .EQ. 1 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .AND. PROT
      ELSEIF ( CODE .EQ. 2 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .OR.  PROT
      ELSEIF ( CODE .EQ. 3 ) THEN
         XAB.B.XAB$W_PRO = XAB.B.XAB$W_PRO .XOR. PROT
      END IF

      MODIFY_FILE_PROT = SYS$CLOSE( FAB )
      RETURN

C=======================================================================

      END
      subroutine move_file

c     Craig Young               3-AUG-87

c     This subroutine controls the moving of the current file to another
c     directory.  The new host directory is determined in the same manner
c     as in the subroutine Rename_Directory.

      include    'swing.cmn'
      include    '($smgdef)'

      character  file*255, message*255
      integer    istat, lib$rename_file
      integer    from_num, from_line, from_level, old_line, old_level
      integer    old_file, old_top, old_bottom
      integer    ikey, len_message, ii, jj
      logical    finished

c     Check if current file is a directory.  If so, abort move.

      istat = index( fnode(file_num).spec(1:), '.DIR;1' )

      if ( istat .eq. 0 ) then
         old_file = file_num
         old_top =  top_file_line
         old_bottom = bottom_file_line

         from_num = node_num
         from_line = cur_line
         from_level = cur_level
         node(from_num).rend = smg$m_reverse + smg$m_blink

         call smg$unpaste_virtual_display( file_window, board_id )
         call smg$change_rendition( window2, from_line, from_level*17+1,
     .                              1, 12, node(from_num).rend )

         call print_message( 'Travel to new host directory and press '// 
     .                       'RETURN - Press any other key to abort',0)
         call smg$set_cursor_abs( window2, from_line, from_level*17+1 )

         finished = .false.

         do while ( .not. finished )

            call smg$read_keystroke( keyboard, ikey )

            old_line = cur_line
            old_level = cur_level
            old_rend = node(node_num).rend 

            if ( ikey .eq. smg$k_trm_cr .or. 
     .           ikey .eq. smg$k_trm_enter ) then
               finished = .true.

               else if ( ikey .eq. smg$k_trm_up ) then
               ii = cur_level
               jj = cur_line - 1
               do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 ) 
                  jj = jj - 1
               end do
               if ( jj .ge. 1 ) cur_line = jj
               call update_screen( old_line, old_level )
 
               else if ( ikey .eq. smg$k_trm_down ) then
               ii = cur_level
               jj = cur_line + 1
               do while( node_pointer(ii,jj) .eq. 0 .and.
     .                   jj .le. num_lines ) 
                  jj = jj + 1
               end do
               if ( jj .le. num_lines ) cur_line = jj
               call update_screen( old_line, old_level )

               else if ( ikey .eq. smg$k_trm_right ) then
               ii = cur_level + 1
               jj = cur_line 
               do while( node_pointer(ii,jj) .eq. 0 .and.
     .                   ii .le. MAX_LEVELS ) 
                  ii = ii + 1
               end do
               if ( ii .le. MAX_LEVELS ) cur_level = ii
               call update_screen( old_line, old_level )

               else if ( ikey .eq. smg$k_trm_left .and. 
     .                   cur_level .ge. 1 ) then
               ii = cur_level - 1
               jj = cur_line
               do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 ) 
                  jj = jj - 1
               end do
               if ( jj .ge. 1 ) then
                  cur_level = ii
                  cur_line = jj
                  end if
               call update_screen( old_line, old_level )
  
               else
               finished = .true.
               end if

            call smg$set_cursor_abs( window2, cur_line, cur_level*17+1 )

         end do

         node(from_num).rend = smg$m_reverse

         call smg$change_rendition( window2, from_line, from_level*17+1,
     .                              1, 12, node(from_num).rend )

         if ( ikey .eq. smg$k_trm_cr .or. 
     .        ikey .eq. smg$k_trm_enter ) then

            istat = lib$rename_file( fnode(old_file).spec,
     .                               '[]'//fnode(old_file).name )

            if ( istat ) then
               call print_message( 'File has been moved', 0 )

               else
               call sys$getmsg( %val(istat), len_message, message, 
     .                          %val(1), )
               call print_message( message(1:len_message), 0 )
               end if
         else
            call smg$erase_display( window3 )
            end if

         call load_display

         cur_line = node(from_num).line
         cur_level = node(from_num).level

         call update_screen( cur_line, cur_level )

         call load_files

         if ( old_file .le. num_files ) then
            file_num = old_file
         else
            file_num = 1
            end if
         top_file_line = old_top
         bottom_file_line = old_bottom

         call smg$paste_virtual_display( file_window, board_id, 10, 40)
         call update_file_window

      else
         call print_message('Cannot move a directory with the filer.',0)
         end if

      return
      end
      subroutine move_node( num, parent )
   
      include    'swing.cmn'

      logical    found_node, greater
      integer    num, ii, jj, parent, ptr(0:7)

      found_node = .false.
      ii = 1

      do while ( .not. found_node .and. ii .le. num_nodes ) 
         if ( node(ii).sister .eq. num ) then
            found_node = .true.
            node(ii).sister = node(num).sister

            else if ( node(ii).child .eq. num ) then
            found_node = .true.
            node(ii).child = node(num).sister
            end if
         ii = ii + 1
      end do

      if ( .not. found_node ) return

      node(num).sister = 0

      if ( parent .eq. 0 ) then
         ii = cur_level - 1
         jj = cur_line
         do while( node_pointer(ii,jj) .eq. 0 .and. jj .ge. 1 ) 
            jj = jj - 1
         end do
         if ( jj .ge. 1 ) then
            parent = node_pointer(ii,jj)
            else
            parent = 1
            end if
         end if

      if ( node(parent).child .eq. 0 ) then
         node(parent).child = num

         else
         ii = node(parent).child
         if ( node(num).name .lt. node(ii).name ) then
            node(num).sister = node(parent).child
            node(parent).child = num

            else
            greater = .true.
            do while ( greater )
               if ( node(ii).sister .eq. 0 ) then
                  node(ii).sister = num
                  greater = .false.

                  else 
                  jj = ii
                  ii = node(ii).sister
                  if ( node(num).name .lt. node(ii).name ) then
                     node(jj).sister = num
                     node(num).sister = ii
                     greater = .false.
                     end if
                  end if                  
            end do
            end if            
         end if
     
      ptr(0) = num

      call change_spec( parent, ptr(0) )
      ptr(1) = node(ptr(0)).child
      do while( ptr(1) .ne. 0 )
        call change_spec( ptr(0), ptr(1) )
        ptr(2) = node(ptr(1)).child
        do while( ptr(2) .ne. 0 ) 
          call change_spec( ptr(1), ptr(2) )
          ptr(3) = node(ptr(2)).child
          do while( ptr(3) .ne. 0 ) 
            call change_spec( ptr(2), ptr(3) )
            ptr(4) = node(ptr(3)).child
            do while( ptr(4) .ne. 0 ) 
              call change_spec( ptr(3), ptr(4) )
              ptr(5) = node(ptr(4)).child
              do while( ptr(5) .ne. 0 ) 
                call change_spec( ptr(4), ptr(5) )
                ptr(6) = node(ptr(5)).child
                do while( ptr(6) .ne. 0 ) 
                  call change_spec( ptr(5), ptr(6) )
                  ptr(7) = node(ptr(6)).child
                  do while( ptr(7) .ne. 0 ) 
                    call change_spec( ptr(6), ptr(7) )
                    ptr(7) = node(ptr(7)).sister
                  end do
                  ptr(6) = node(ptr(6)).sister
                end do
                ptr(5) = node(ptr(5)).sister
              end do
              ptr(4) = node(ptr(4)).sister
            end do
            ptr(3) = node(ptr(3)).sister
          end do
          ptr(2) = node(ptr(2)).sister
        end do
        ptr(1) = node(ptr(1)).sister
      end do

      return
      end
      subroutine pd_bar_choice( keyboard, num_choice, pd_choices )

      implicit none
      include '($smgdef)'
      include 'pulldown.cmn'

      integer pos, new_pos, key, num_choice, keyboard, ii
      logical exit, down
      record /pd_choice_type/ pd_choices

      exit = .false.
      down = .false.
      key = 0
      new_pos = num_choice
      pos = num_choice

C     SET THE RENDITION OF THE FIRST CHOICE
      ii = 1 + (pd_cell_size*(new_pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                           pd_cell_size, smg$m_bold )

      do while ( key .ne. smg$k_trm_enter .and.
     .           key .ne. smg$k_trm_cr .and. 
     .           .not. down .and. .not. exit ) 

         call smg$set_cursor_abs( pd_bar_id, 1, 1 )

         call smg$read_keystroke( keyboard, key )

         if ( key .eq. smg$k_trm_left ) then
            if ( pos .gt. 1 ) new_pos = pos - 1
            else if ( key .eq. smg$k_trm_right ) then
            if ( pos .lt. pd_num_choices ) new_pos = pos + 1
            else if ( key .eq. smg$k_trm_down ) then
            if ( pd_choices.ptr(pos) .ne. 0 ) down = .true.
            else if ( key .eq. smg$k_trm_ctrlz ) then
            exit = .true.
            end if

         if ( new_pos .ne. pos ) then
            ii = 1 + (pd_cell_size*(pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                                 pd_cell_size, 0, 0 )
            ii = 1 + (pd_cell_size*(new_pos-1))
            call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                                 pd_cell_size, smg$m_bold )
            end if

         pos = new_pos

      end do

      ii = 1 + (pd_cell_size*(pos-1))
      call smg$change_rendition( pd_bar_id, 1, ii, 1, 
     .                           pd_cell_size, 0, 0 )

      if ( exit ) then
         num_choice = 0
         else
         num_choice = pos
         end if

      return
      end
      subroutine pd_draw_bar( board_id )

*     PD_DRAW_BAR( BOARD_ID )
*
*     BOARD_ID          INTEGER*4
*
      implicit none
      include 'pulldown.cmn'

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )
      call smg$paste_virtual_display( pd_bar_id, board_id, 1, 1 )

      return
      end 
*=======================================================================
*     
*  Title:        PULLDOWN PACKAGE
*                
*  Version:      1-001
*                
*  Abstract:     This is a package of routines to implement a pulldown
*                menu system on a VT100 type terminal with SMG routines.
*                It is used by SWING
*                
*  Environment:  VMS
*                
*  Author:       Eric Andresen of General Research Corporation
*                
*  Date:         24-SEP-1986 
*                
*-----------------------------------------------------------------------

      subroutine pd_get_choice( board_id, keyboard, width, 
     .                          pd_choices, choice, code )

      implicit none
*     PD_GET_CHOICE( BOARD_ID, KEYBOARD, WIDTH, PD_CHOICES, CHOICE, CODE )
*     
*     BOARD_ID       INTEGER*4
*     KEYBOARD       INTEGER*4
*     WIDTH          INTEGER*4
*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
*     CHOICE         CHARACTER*(PD_MAX_CHOICE_LEN)
*     CODE           INTEGER*4
*
      include 'pulldown.cmn'

      integer   num_choice, save_choice, code, keyboard, width
      integer   board_id
      logical   do_bar
      character choice*(PD_MAX_CHOICE_LEN)
      record /pd_choice_type/ pd_choices

      do_bar = .true.
      num_choice = 1

C     LOOP UNTIL A VALID EXIT OCCURS
      do while ( do_bar )

C        GET A CHOICE FROM THE BAR
         call pd_bar_choice( keyboard, num_choice, pd_choices )

         save_choice = 0
         do_bar = .false.

C        AS LONG AS THE USER IS CHOOSING LISTS FROM THE BAR
         do while ( save_choice .ne. num_choice .and.
     .              pd_choices.ptr(num_choice) .ne. 0 )
            save_choice = num_choice
            call pd_list_choice( board_id, keyboard, width, num_choice,
     .                           %val(pd_choices.ptr(num_choice)),
     .                           choice, code, do_bar )
         end do

C        IF A CHOICE HAS BEEN MADE 
         if ( .not. do_bar ) then
            
C           IF ITS ONLY A CHOICE FROM THE BAR BECAUSE THERE WAS NO
C           ASSOCIATED LIST
            if ( save_choice .eq. 0 .and. num_choice .ne. 0 ) then
               choice = pd_choices.choice(num_choice)
               code = pd_choices.code(num_choice)

C              IF NO CHOICE WAS MADE
               else if ( save_choice .eq.0 .and. num_choice .eq.0 ) then
               choice = ' '
               code = -1
               end if

C              OTHERWISE A CHOICE WAS MADE FROM THE CALL TO
C              pd_list_choice

            end if

      end do

      return
      end
      subroutine pd_list_choice( board_id, keyboard, width, num_choice, 
     .                           pd_choices, choice, code, do_bar)

      implicit none
      include '($smgdef)'
      include 'pulldown.cmn'

      record /pd_choice_type/ pd_choices

      integer smg$create_virtual_display
      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES), code, istat
      integer start_pos, pd_list_id, atts(PD_MAX_CHOICES), num_choice
      integer pos, new_pos, key, width, keyboard, board_id
      logical exit, do_bar
      character choice*(PD_MAX_CHOICE_LEN)

      do_bar = .false.

C     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
      ii = 1
      max_cell = 0
      do while ( ii .le. pd_choices.number )
         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
     .                  lens(ii) )
         max_cell = max( max_cell, lens(ii) )         
         ii = ii + 1         
      end do
      ii = ii - 1
      
C     CREATE THE VIRTUAL DISPLAY FOR THE LIST
      istat = smg$create_virtual_display( ii, max_cell, pd_list_id,
     .                                    smg$m_border, smg$m_reverse )

C     PUT THE CHOICES IN THE LIST
      do jj = 1, ii
         if ( pd_choices.ptr(jj) .eq. 0 ) then
            call smg$put_chars( pd_list_id, 
     .                          pd_choices.choice(jj)(1:max_cell),
     .                          jj, 1 )
            atts(jj) = 0
            else
            call smg$put_chars( pd_list_id, 
     .                          pd_choices.choice(jj)(1:max_cell),
     .                          jj, 1,, smg$m_underline )
            atts(jj) = smg$m_underline
            end if
      end do      

      start_pos = 1 + (pd_cell_size*(num_choice-1))
      if ( start_pos + max_cell .gt. width ) then
         start_pos = width - max_cell + 1
         end if

      call smg$begin_pasteboard_update( board_id )
      call smg$paste_virtual_display( pd_list_id, board_id, 2, 
     .                                start_pos )
      call smg$repaste_virtual_display( pd_bar_id, board_id, 1, 1 )
      call smg$end_pasteboard_update( board_id )

C     GET A CHOICE FROM THE LIST
      exit = .false.
      key = 0
      pos = 1
      new_pos = 1

C     SET THE RENDITION OF THE FIRST CHOICE
      call smg$change_rendition( pd_list_id, 1, 1, 1, 
     .                           max_cell, smg$m_bold + atts(1) )

      do while ( key .ne. smg$k_trm_enter .and.
     .           key .ne. smg$k_trm_cr .and. .not. exit ) 

         call smg$set_cursor_abs( pd_list_id, pos, 1 )

         call smg$read_keystroke( keyboard, key )

         if ( key .eq. smg$k_trm_up ) then
            if ( pos .gt. 1 ) then
               new_pos = pos - 1
               else
               do_bar = .true.
               exit = .true.
               end if
            else if ( key .eq. smg$k_trm_down ) then
            if ( pos .lt. ii ) new_pos = pos + 1
            else if ( key .eq. smg$k_trm_left ) then
            if ( num_choice .gt. 1 ) num_choice = num_choice - 1
            do_bar = .true.
            exit = .true.
            else if ( key .eq. smg$k_trm_right ) then
            if ( num_choice .lt. pd_num_choices ) 
     .         num_choice = num_choice + 1
            do_bar = .true.
            exit = .true.
            else if ( key .eq. smg$k_trm_ctrlz ) then
            exit = .true.
            end if

         if ( new_pos .ne. pos ) then
            call smg$change_rendition( pd_list_id, pos, 1, 1, 
     .                                 max_cell, atts(pos))
            call smg$change_rendition( pd_list_id, new_pos, 1, 1,
     .                                 max_cell, 
     .                                 smg$m_bold+atts(new_pos) )
            end if

         pos = new_pos

      end do

      call smg$unpaste_virtual_display( pd_list_id, board_id )

      if ( exit ) then
         choice = ' '
         code = -1
         else
         choice = pd_choices.choice(pos)
         code = pd_choices.code(pos)
         end if

      return
      end
      subroutine pd_load_bar( width, pd_choices )

*     PD_LOAD_BAR( WIDTH, PD_CHOICES )
*     
*     WIDTH          INTEGER*4
*     PD_CHOICES     RECORD /PD_CHOICE_TYPE/  (PULLDOWN.CMN)
*
      implicit none
      include '($smgdef)'
      include 'pulldown.cmn'

      integer smg$create_virtual_display, smg$change_virtual_display
      integer max_cell, ii, jj, kk, lens(PD_MAX_CHOICES)
      integer start_pos, off_set, width, istat
      record /pd_choice_type/ pd_choices

C     FIND OUT HOW MANY CHOICES THERE ARE AND THE MAXIMUM LENGTH
      ii = 1
      max_cell = 0
      do while ( ii .le. pd_choices.number )
         call str$trim( pd_choices.choice(ii), pd_choices.choice(ii), 
     .                  lens(ii) )
         max_cell = max( max_cell, lens(ii) )         
         ii = ii + 1         
      end do
      ii = ii - 1
      
C     CREATE THE VIRTUAL DISPLAY FOR THE BAR
      if ( pd_bar_id .eq. 0 ) then
         istat = smg$create_virtual_display( 1, width, pd_bar_id,,
     .                                       smg$m_reverse )
         else
         call smg$erase_display( pd_bar_id )
         istat = smg$change_virtual_display( pd_bar_id, 1, width, 
     .                                       pd_bar_id,, smg$m_reverse )
         end if

C     FIGURE OUT THE LENGTH OF EACH CELL

C     IF THERE IS ROOM ENOUGH FOR ALL OF THE CHOICES AS IS
      if ( (ii*max_cell) .le. width ) then
         pd_cell_size = min( 16, width / ii )

C        MAKE IT 16 OR LESS
         else
         pd_cell_size = min( 16, width / max_cell )
         end if

C     PUT THE CHOICES IN THE MENU
      do jj = 1, ii
         start_pos = 1 + (pd_cell_size*(jj-1))
         off_set = max( 1, pd_cell_size-lens(jj)) / 2
         call smg$put_chars( pd_bar_id, 
     .                       pd_choices.choice(jj)(1:lens(jj)),,
     .                       start_pos + off_set )
      end do      

      pd_num_choices = ii

      return
      end
      subroutine pd_undraw_bar( board_id )

*     PD_UNDRAW_BAR( BOARD_ID )
*
*     BOARD_ID          INTEGER*4
*
      implicit none
      include 'pulldown.cmn'

      integer board_id

      call smg$unpaste_virtual_display( pd_bar_id, board_id )

      return
      end 
      subroutine print_file

c     Craig Young               3-AUG-87

c     This subroutine sends the current file to the printer as specified
c     by Swing$Print or defaults to $Print.  The terminal is not attached
c     to the spawned process so use of swing can continue.

      include    'swing.cmn'
      include    '($ssdef)'
      include    '($clidef)'

      character  string*255, logical_name*50, file*50
      integer    istat, len_string, len_file
      integer*4  translate_logical

c     Check if current file is a directory.  If so, abort print.

      istat = index( fnode(file_num).spec(1:), '.DIR;1' )

      if ( istat .eq. 0 ) then
         call print_message( ' ', 0 )
         call smg$set_cursor_abs( window3, 2, 1 )
         call str$trim( file, fnode(file_num).spec, len_file )

         logical_name = 'SWING$PRINT'           !Check for user's printer
         istat = translate_logical( logical_name, string )
         if ( istat .eq. ss$_normal ) then
            call str$trim( string, string, len_string )
            call lib$spawn( string(1:len_string)
     .                      //'/noidentify/nonotify '
     .                      //file(1:len_file),,,cli$m_nowait)
         else
            call lib$spawn( '$print/noidentify/nonotify '
     .                      //file(1:len_file),,,cli$m_nowait)
            end if

         call print_message( 'Sent file to printer.', 0 )

      else
         call print_message( 'Cannot print a directory.', 0 )
         end if

      return
      end
$*$*EOD*$*$
$ checksum 4.FOR
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ exit
