*=======================================================================
*     
*  Title:        SWING
*                
*  Version:      1-001
*                
*  Abstract:     SWING is a VMS utility for displaying and manipulating
*                VMS directory trees.
*                
*  Environment:  VMS
*                
*  Author:       Eric Andresen of General Research Corporation
*                
*  Date:         24-SEP-1986 
*                
*-----------------------------------------------------------------------

      program swing

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

      integer    ikey, old_level, old_line, isave, code, code_type
      logical    crt, finished
      character  key, choice*(PD_MAX_CHOICE_LEN)

      if ( .not. crt() ) 
     .   call print_message( 'You must use a DEC CRT terminal', 1 )

      call load_nodes
      call define_smg_layout
      call load_display
      call draw_screen

      do while ( .not. finished ) 

         call smg$read_keystroke( keyboard, ikey )

         call print_message( ' ', 0 )

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

         if ( ikey .eq. smg$k_trm_do .or.
     .        ikey .eq. smg$k_trm_ctrlp ) then
            call pd_get_choice( board_id, keyboard, width, 
     .                          pull_choices, choice, code )
            code_type = code / 10
            else
            code_type = 0
            code = 0
            end if

         if ( ikey .eq. smg$k_trm_ctrlz .or. 
     .        ikey .eq. smg$k_trm_lowercase_x .or.
     .        ikey .eq. smg$k_trm_uppercase_x .or.
     .        ikey .eq. smg$k_trm_lowercase_e .or.
     .        ikey .eq. smg$k_trm_uppercase_e .or.
     .        ikey .eq. smg$k_trm_enter .or.
     .        code .eq. 91 ) 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 if ( code_type .eq. 1 .or. 
     .                ikey .eq. smg$k_trm_lowercase_c .or.
     .                ikey .eq. smg$k_trm_uppercase_c ) then
            call create_directory( code )

            else if ( code_type .eq. 2 .or. 
     .                ikey .eq. smg$k_trm_lowercase_r .or.
     .                ikey .eq. smg$k_trm_uppercase_r ) then
            call rename_directory( 20 ) 

            else if ( code_type .eq. 3 .or. 
     .                ikey .eq. smg$k_trm_lowercase_m .or.
     .                ikey .eq. smg$k_trm_uppercase_m ) then
            call rename_directory( 30 ) 

            else if ( code_type .eq. 4 .or. 
     .                ikey .eq. smg$k_trm_lowercase_d .or.
     .                ikey .eq. smg$k_trm_uppercase_d ) then
            call delete_directory( code )

            else if ( code_type .eq. 5 .or. 
     .                ikey .eq. smg$k_trm_lowercase_p .or.
     .                ikey .eq. smg$k_trm_uppercase_p ) then
            call hardcopy( code )

            else if ( code_type .eq. 6 .or. 
     .                ikey .eq. smg$k_trm_lowercase_s .or.
     .                ikey .eq. smg$k_trm_uppercase_s ) then
            call record_structure( .true. )

            else if ( code_type .eq. 7 .or. 
     .                ikey .eq. smg$k_trm_lowercase_o .or.
     .                ikey .eq. smg$k_trm_uppercase_o ) then
            call change_options( 71 )

            else if ( code_type .eq. 8 .or. 
     .                ikey .eq. smg$k_trm_pf2 .or.
     .                ikey .eq. smg$k_trm_help .or.
     .                ikey .eq. smg$k_trm_lowercase_h .or.
     .                ikey .eq. smg$k_trm_uppercase_h ) then
            call help( code )
            end if

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

      end do

      call exit_swing
      end

      subroutine help

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

      external   LIB$PUT_OUTPUT, LIB$GET_INPUT

      integer    isave, flags, input, output, stat
      integer    lbr$output_help

      call smg$save_physical_screen( board_id, isave )

      flags = hlp$m_prompt

      output = %loc( lib$put_output )
      input =  %loc( lib$get_input )

      stat = lbr$output_help( %val(output),
     .                        width,
     .                        'swing',
     .                        'swing',
     .                        flags,
     .                        %val(input) )

      call smg$restore_physical_screen( board_id, isave )

      if ( .not. stat ) then
         call print_message( 
     .        'There is no SWING.HLB help file in SYS$HELP', 0 )
         end if

      return
      end

      subroutine change_options( code )

      include    'swing.cmn'
      
      integer code

      if ( code .eq. 71 ) then
         use_window1 = .not. use_window1
         end if

      if ( .not. use_window1 ) then
         call smg$erase_display( window1 )
         else
         call update_window1
         end if

      return
      end

      subroutine rename_directory( code ) 

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

      character  new_dir*42, key, string*39, message*255, file*255
      integer    ikey, len_string, lib$rename_file, code, parent
      integer    sys$getmsg, istat, len_message, ipos, from_level
      integer    old_line, old_level, from_num, from_line
      logical    dir_to_file, finished, check_directory_move

      if ( code .eq. 20 ) then

         call print_message( ' ', 0 )
         call smg$set_cursor_abs( window3, 1, 1 )
         call smg$read_string( keyboard, string, 
     .                         'Enter new name to give directory: ',
     .                         39,,,,len_string,, window3 )

         new_dir = ' '
         jj = 0

         do ii = 1, len_string
            if (string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']'.and. 
     .         string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' .and.
     .         string(ii:ii) .ne. ';' ) then
               jj = jj + 1
               new_dir(jj:jj) = string(ii:ii)
               end if
         end do

         call str$upcase( new_dir, new_dir )

         if ( jj .ne. 0 ) then
            if ( dir_to_file( node(node_num).spec,
     .                        node(node_num).length, 
     .                        file, ipos ) ) then
               istat = lib$rename_file( file, 
     .                                  new_dir(1:jj)//'.DIR;1',,,
     .                                  1 )

               if ( istat .eq. ss$_normal ) then
                  call file_to_dir( file(1:ipos)//new_dir(1:jj)//'.DIR', 
     .                              node(node_num).spec,
     .                              node(node_num).length,
     .                              node(node_num).name )
 
                  parent = 0
                  call move_node( node_num, parent )
   
                  call adjust_node_pointers
        
                  call load_display

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

                  call update_screen( cur_line, cur_level )

                  call print_message( 'Subdirectory renamed', 0 )

                  do_save = .true.

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

         else if ( code .eq. 30 ) then

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

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

         call print_message( 'Travel to new parent directory and hit '// 
     .                       'RETURN - Hit 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

            if ( .not. check_directory_move( from_num, node_num ) ) then
               call update_screen( cur_line, cur_level )
               call print_message( 'Rename would cause too great a '//
     .            'directory depth', 0 )
               return
               end if               

            if ( dir_to_file( node(from_num).spec,
     .                        node(from_num).length, 
     .                        file, ipos ) ) then

               istat = lib$rename_file( file, 
     .                 node(node_num).spec(1:node(node_num).length)//
     .                 '*.dir;1',,, 1 )

               if ( istat ) then
                  call move_node( from_num, node_num )
   
                  call adjust_node_pointers
        
                  call load_display

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

                  call update_screen( cur_line, cur_level )

                  call print_message( 'Subdirectory has been moved', 0 )

                  do_save = .true.

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

      return
      end

      logical function check_directory_move( from_num, cur_num )

      include 'swing.cmn'

      integer from_num, cur_num, from_levels, ptr(0:7)

      from_levels = 1

      ptr(0) = from_num

      ptr(1) = node(ptr(0)).child
      do while( ptr(1) .ne. 0 )
        if ( from_levels .lt. 2 ) from_levels = 2
        ptr(2) = node(ptr(1)).child
        do while( ptr(2) .ne. 0 ) 
          if ( from_levels .lt. 3 ) from_levels = 3
          ptr(3) = node(ptr(2)).child
          do while( ptr(3) .ne. 0 ) 
            if ( from_levels .lt. 4 ) from_levels = 4
            ptr(4) = node(ptr(3)).child
            do while( ptr(4) .ne. 0 ) 
              if ( from_levels .lt. 5 ) from_levels = 5
              ptr(5) = node(ptr(4)).child
              do while( ptr(5) .ne. 0 ) 
                if ( from_levels .lt. 6 ) from_levels = 6
                ptr(6) = node(ptr(5)).child
                do while( ptr(6) .ne. 0 ) 
                  if ( from_levels .lt. 7 ) from_levels = 7
                  ptr(7) = node(ptr(6)).child
                  do while( ptr(7) .ne. 0 ) 
                    if ( from_levels .lt. 8 ) from_levels = 8
                    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

      if ( node(cur_num).level + from_levels .gt. 7 ) then
         check_directory_move = .false.
         else
         check_directory_move = .true.
         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 change_spec( parent, ptr )

      include    'swing.cmn'

      character  spec*255
      integer    len, parent, ptr, jj

      jj = node(ptr).length - 1
      ii = jj
      do while ( ii .gt. 1 .and.
     .           node(ptr).spec(ii:ii) .ne. '[' .and. 
     .           node(ptr).spec(ii:ii) .ne. '.' ) 
         ii = ii - 1
      end do
      ii = ii + 1

      spec = node(parent).spec(1:node(parent).length)//
     .       node(ptr).spec(ii:jj)//'.DIR;1'

      call file_to_dir( spec,
     .                  node(ptr).spec,
     .                  node(ptr).length,
     .                  node(ptr).name )

      return
      end

      subroutine create_directory( code )

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

      character  new_dir*42, term*5, string*39, message*255
      integer    iterm, len_string, lib$create_dir
      integer    sys$getmsg, istat, len_message, code

      call print_message( ' ', 0 )
      call smg$set_cursor_abs( window3, 1, 1 )
      call smg$read_string( keyboard, string, 
     .                      'New subdirectory name: ',
     .                      39,,,,len_string,, window3 )

      new_dir = ' '
      jj = 0

      do ii = 1, len_string
         if ( string(ii:ii) .ne. '[' .and. string(ii:ii) .ne. ']' .and. 
     .        string(ii:ii) .ne. '.' .and. string(ii:ii) .gt. ' ' ) then
            jj = jj + 1
            new_dir(jj:jj) = string(ii:ii)
            end if
      end do

      call str$upcase( new_dir, new_dir )

      if ( jj .ne. 0 ) then
         istat = lib$create_dir( '[.'//new_dir(1:jj)//']' )

         if ( istat .eq. ss$_created ) then

            do_save = .true.

            call add_node( new_dir(1:jj), node_num )

            call adjust_node_pointers
      
            call load_display

            call update_screen( cur_line, cur_level )

            call print_message( 'Created new subdirectory', 0 )

            else if ( .not. istat ) then
            call sys$getmsg( %val(istat), len_message, message, 
     .                       %val(1), )
            call print_message( message(1:len_message), 0 )

            else
            call smg$erase_display( window3 )
            end if

         else
         call smg$erase_display( window3 )
         end if

      return
      end

      subroutine add_node( new_dir, parent )

      include    'swing.cmn'

      character new_dir*42, spec*255
      integer   parent, len, new_node, free_node, ii
      logical   greater

      call str$trim( new_dir, new_dir, len )

      spec = node(parent).spec(1:node(parent).length)//
     .       new_dir(1:len)//'.DIR;1'

      new_node = free_node()

      call file_to_dir( spec, 
     .                  node(new_node).spec,
     .                  node(new_node).length,
     .                  node(new_node).name )

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

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

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

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

      return
      end

      integer function free_node

      include 'swing.cmn'

      integer ii

      if ( num_nodes .lt. MAX_NODES ) then
         num_nodes = num_nodes + 1
         node(num_nodes).length = 0
         node(num_nodes).child = 0
         node(num_nodes).sister = 0
         free_node = num_nodes

         else
         ii = 1
         do while ( ii .le. MAX_NODES ) 
            if ( node(ii).length .eq. 0 ) then
               node(ii).length = 0
               node(ii).child = 0
               node(ii).sister = 0
               free_node = ii
               return
               end if
            ii = ii + 1
         end do
         if ( num_nodes .gt. MAX_NODES .or. num_lines .gt. MAX_LINES ) 
     .      call print_message( 'Directory structure is too large', 1 )
         end if

      return
      end

      subroutine delete_directory( code )

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

      character  spec(0:MAX_LEVELS)*255, search(0:MAX_LEVELS)*255
      character  term*5, string*3, message*255, name*50
      integer    iterm, len_string, code
      integer    sys$getmsg, istat, len_message, len(0:MAX_LEVELS)
      integer    icont(MAX_LEVELS), lib$find_file, ii
      logical    found_node

      call print_message( ' ', 0 )
      call smg$set_cursor_abs( window3, 1, 1 )
      call smg$read_string( keyboard, string, 
     .                      'Enter YES to to delete this direc'//
     .                      'tory and all directories below it: ',
     .                      3,,,,len_string,, window3 )

      call str$upcase( string, string )

      if ( string .eq. 'YES' ) then

         do_save = .true.

         call print_message('Deleting current directory structure...',0)

         delete_problem = .false.
         search(0)=node(node_num).spec(1:node(node_num).length)//'*.dir'

         icont(0) = 0
         do while ( lib$find_file( search(0), spec(0), icont(0) ) )      
          call file_to_dir( spec(0), search(1), len(1), name )
          search(1) = search(1)(1:len(1))//'*.dir'
          icont(1) = 0
          do while ( lib$find_file( search(1), spec(1), icont(1) ) )      
           call file_to_dir( spec(1), search(2), len(2), name )
           search(2) = search(2)(1:len(2))//'*.dir'
           icont(2) = 0
           do while ( lib$find_file( search(2), spec(2), icont(2) ) )      
            call file_to_dir( spec(2), search(3), len(3), name )
            search(3) = search(3)(1:len(3))//'*.dir'
            icont(3) = 0
            do while ( lib$find_file( search(3), spec(3), icont(3) ) )      
             call file_to_dir( spec(3), search(4), len(4), name )
             search(4) = search(4)(1:len(4))//'*.dir'
             icont(4) = 0
             do while ( lib$find_file( search(4), spec(4), icont(4) ) )      
              call file_to_dir( spec(4), search(5), len(5), name )
              search(5) = search(5)(1:len(5))//'*.dir'
              icont(5) = 0
              do while ( lib$find_file( search(5), spec(5), icont(5) ) )      
               call file_to_dir( spec(5), search(6), len(6), name )
               search(6) = search(6)(1:len(6))//'*.dir'
               icont(6) = 0
               do while ( lib$find_file( search(6), spec(6), icont(6) ))      
                call file_to_dir( spec(6), search(7), len(7), name )
                call delete_files( search(7)(1:len(7)) )
               end do
               call lib$find_file_end( icont(6) )
               call delete_files( search(6)(1:len(6)) )
              end do
              call lib$find_file_end( icont(5) )
              call delete_files( search(5)(1:len(5)) )
             end do
             call lib$find_file_end( icont(4) )
             call delete_files( search(4)(1:len(4)) )
            end do
            call lib$find_file_end( icont(3) )
            call delete_files( search(3)(1:len(3)) )
           end do
           call lib$find_file_end( icont(2) )
           call delete_files( search(2)(1:len(2)) )
          end do
          call lib$find_file_end( icont(1) )
          call delete_files( search(1)(1:len(1)) )
         end do
         call lib$find_file_end( icont(0) )
         call delete_files( search(0)(1:node(node_num).length) )

         if ( 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
               node_num = node_pointer(ii,jj)
               else
               node_num = 1
               end if
            else
            node_num = 1
            end if

         call adjust_node_pointers
         call load_display

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

         call update_screen( cur_line, cur_level )

         if ( delete_problem ) then
            call print_message( 'Attempted to delete subdirectory - '//
     .           'but some files could not be deleted', 0 )
            else
            call print_message( 'Deleted subdirectory structure', 0 )
            end if
         else

         call print_message( 'No directories deleted', 0 )
         end if

      return
      end

      subroutine delete_files( dir_spec )

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

      integer    icontext, lib$delete_file, modify_file_prot, ptr
      character  dir_spec*(*), spec*255
      logical    find_node, found_node

      ii = len( dir_spec )
      do while ( dir_spec(ii:ii) .eq. ' ' .and. ii .gt. 0 ) 
         ii = ii - 1
      end do

      if ( find_node( dir_spec(1:ii), ptr ) ) then
         found_node = .true.
         call smg$change_rendition( window2, node(ptr).line, 
     .                              node(ptr).level*17+1,
     .                              1, 12,
     .                              smg$m_blink + node(ptr).rend ) 
         else
         found_node = .false.
         end if

      icontext = 0
      do while( lib$find_file( dir_spec(:ii)//'*.*;*', spec, icontext ))
         if ( .not. lib$delete_file( spec ) ) then
            call str$trim( spec, spec, len_spec )
            if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
               istat = lib$delete_file( spec )
               if ( .not. istat ) delete_problem = .true.
               else 
               call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
     .                         dir_spec(:ii)//'*.*;*', 'NL:', 'NL:' )
               istat = lib$delete_file( spec )
               if ( .not. istat ) delete_problem = .true.
               end if
            end if
      end do
      call lib$find_file_end( icontext )

      call dir_to_file( dir_spec, ii,
     .                  spec, ipos )
      if ( .not. lib$delete_file( spec ) ) then
         call str$trim( spec, spec, len_spec )
         if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
            istat = lib$delete_file( spec )
            if ( .not. istat ) delete_problem = .true.
            else 
            call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
     .                      dir_spec(:ii)//'*.*;*', 'NL:', 'NL:' )
            istat = lib$delete_file( dir_spec(1:ii) )
            if ( .not. istat ) delete_problem = .true.
            end if
         end if

      if ( .not. delete_problem ) then
         if ( found_node ) call delete_node( ptr )
         else
         if ( found_node ) 
     .      call smg$change_rendition( window2, node(ptr).line, 
     .                                 node(ptr).level*17+1,
     .                                 1, 12,
     .                                 node(ptr).rend ) 
         end if

      return
      end

      logical function find_node( dir_spec, ptr )

      include    'swing.cmn'

      character  dir_spec*(*)
      integer    ii, jj, ptr
      logical    found_node

      ii = len( dir_spec )
      do while ( dir_spec(ii:ii) .eq. ' ' .and. ii .gt. 0 ) 
         ii = ii - 1
      end do

      jj = 1
      found_node = .false.
      do while ( .not. found_node )
         if ( node(jj).spec(1:node(jj).length) .eq. dir_spec(1:ii) )then
            found_node = .true.
            ptr = jj
            end if
         jj = jj + 1
      end do

      find_node = found_node

      return
      end

      subroutine delete_node( ptr )

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

      logical    found_node
      integer    ptr, ii

      found_node = .false.
      ii = 1

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

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

      if ( found_node ) then
         node(ptr).name = ' '
         call smg$put_chars( window2, node(ptr).name, 
     .                                node(ptr).line, 
     .                                node(ptr).level * 17 + 1,,
     .                                node(ptr).rend )
         node(ptr).level = 0
         node(ptr).length = 0
         node(ptr).sister = 0
         node(ptr).child = 0
         end if

      return
      end

      logical function file_to_dir( file, dir, len_dir, name )

      character dir*(*), file*(*), name*(*)
      integer   len_dir, kk, ii, len_node

      kk = 1
      do while ( file(kk:kk) .ne. '[' )
         kk = kk + 1
      end do
      dir = file(kk:)

      ii = 1
      do while ( dir(ii:ii) .ne. ']' )
         ii = ii + 1
      end do

      jj = ii
      do while ( dir(jj:jj) .ne. '.' )
         jj = jj + 1
      end do

      dir(ii:ii) = '.'
      dir(jj:) = ']'

      len_dir = jj
      
      len_node = jj - ii - 1
      if ( len_node .le. 9 ) then
         name = '['//dir(ii:jj)
         else
         name = '['//dir(ii:ii+9)//'*'
         end if

      return
      end

      logical function dir_to_file( dir, len_dir, file, ipos )

      character dir*(*), file*(*)
      integer   len_dir, ii, ipos

      ii = len_dir
      do while ( dir(ii:ii) .ne. '.' .and. ii .gt. 0 )
         ii = ii - 1         
      end do

      if ( ii .ne. 0 ) then
         dir_to_file = .true.
         file = dir
         file(ii:ii) = ']'
         file(len_dir:) = '.dir;1'
         ipos = ii

         else
         call print_message( 'Operation not allowed on main directory',
     .                       0 )
         dir_to_file = .false.
         end if

      return
      end

      subroutine update_screen( old_line, old_level )

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

      integer    old_line, old_level, sys$setddir

      node_num = node_pointer( cur_level, cur_line )

      call smg$begin_pasteboard_update( board_id )

      call smg$change_rendition( window2, old_line, old_level*17+1,
     .                           1, 12, old_rend )
      call smg$change_rendition( window2, cur_line, cur_level*17+1,
     .                           1, 12,
     .                           smg$m_bold + node(node_num).rend ) 

      call update_window1

      call smg$end_pasteboard_update( board_id )

      if ( cur_line .gt. bottom_line ) then
         do ii = bottom_line+1, cur_line
            call smg$move_virtual_display( window2, board_id,23-ii,1)
         end do
         top_line = cur_line - 19
         bottom_line = cur_line

         else if ( cur_line .lt. top_line ) then
         do ii = top_line-1, cur_line, -1
            call smg$move_virtual_display( window2, board_id, 4-ii,1)
         end do
         top_line = cur_line
         bottom_line = cur_line + 19
         end if

      istat = sys$setddir( node(node_num).spec, %val(0), %val(0) )

      return
      end

      subroutine hardcopy( code )

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

      integer    column, num, ii, jj, level, ikey, start, end, len
      integer    code
      character  hard_node*12, dashes*12, out_line(MAX_LINES)*132
      character  one_line*200

      data dashes / '------------' /

      open( unit=1, 
     .      name='swing.lis',
     .      carriagecontrol='list',
     .      status='new',
     .      err=99 )

      call print_message( 'Creating hardcopy listing in SWING.LIS', 0 )

      last_level = 1
      line = 0
      do ii = 0, MAX_LEVELS
         last_line(ii) = 1
      end do         
      do ii = 1, num_lines
         out_line(ii) = ' '
      end do         

      do jj = 1, num_lines
         do level = 0, MAX_LEVELS
            if ( node_pointer(level,jj) .ne. 0 ) then
               num = node_pointer(level,jj)

               column = level * 17 + 1
               line = node(num).line

               call str$trim( hard_node, node(num).name, len )
               if ( level .lt. 7 ) then
                  if ( node_pointer(level+1,jj) .ne. 0 )
     .               hard_node = hard_node(1:len)//dashes(len+1:12)
                  end if

               out_line(line)(column:column+11) = hard_node
               if ( level .gt. 0 ) then
                  out_line(line)(column-3:column-1) = '---'

                  if ( level .le. last_level ) then
                     out_line(line)(column-3:column-3) = '+'
                     if ( out_line(line-1)(column-3:column-3) .eq. '+' )
     .                  out_line(line-1)(column-3:column-3) = '|'

                     else if ( level .eq. last_level + 1 ) then
                     out_line(line)(column-5:column-2) = '----'
                     end if

                  if ( level .lt. last_level ) then
                     if ( out_line(last_line(level))(column-3:column-3) 
     .                    .eq. '+' ) then
                        ll = last_line(level)
                        else
                        ll = last_line(level) + 1
                        end if
                     do kk = ll, line-1
                        out_line(kk)(column-3:column-3) = '|'
                     end do
                     end if
                  end if

               last_level = level
               last_line(level) = line
               end if
         end do
      end do

      do ii = 1, num_lines
         call str$trim( out_line(ii), out_line(ii), len )
         write( 1, 100 ) out_line(ii)(1:len)
100      format( a )
      end do

      call print_message( 'Finished creating SWING.LIS', 
     .                    0 )

      close( unit=1 )

      return

99    call print_message( 'Unable to open file for hardcopy', 0 )
      return
      end

      subroutine load_nodes

      include    'swing.cmn'

      integer*2  len_root
      integer*4  icontext(MAX_LEVELS), lib$find_file
      character  input*255, spec*255, search(0:MAX_LEVELS)*255

      do ii = 1, MAX_LINES
         do jj = 0, MAX_LEVELS
            node_pointer(jj,ii) = 0
         end do
      end do

      call get_location( disk, len_disk, root, len_root )      

      found = .false.
      lowest_level = 0
      last_level = 1
      line = 0
      num_nodes = 0
      node_num = 0

      ii = 1
      do while ( root(ii:ii) .ne. '.' .and. root(ii:ii) .ne. ']' )
         ii = ii + 1
      end do

      main = root(:ii-1)//']'
      len_main = ii
      spec = main

      if ( main .eq. '[000000]' ) 
     .   call print_message( 'Master file directory not allowed', 1 )

      ii = 0
      if ( .not. update .and. lib$find_file( main(1:len_main)//
     .     'swing.sav', input, ii ) ) then

         open( unit=1, 
     .         readonly,
     .         name=main(1:len_main)//'swing.sav', 
     .         status='old',
     .         carriagecontrol='list',
     .         access='sequential',
     .         form='unformatted',
     .         recl=73,
     .         organization='sequential',
     .         recordtype='variable',
     .         err=99 )

         read( 1, err=99 ) num_lines, num_nodes, lowest_level

         do ii = 1, num_lines
            read( 1, err=99 ) (node_pointer(jj,ii), jj=0,MAX_LEVELS)
         end do

         do ii = 1, num_nodes
            read( 1, err=99 ) node(ii)
         end do

         close( unit=1 )

         swing_file_exists = .true.

         else
99       call print_message( 'Searching directory structure...', 0 )

         call append_node( 0, spec, search(1) )

         icontext(1) = 0
         do while ( lib$find_file( search(1), spec, icontext(1) ) )      
          call append_node( 1, spec, search(2) )
          icontext(2) = 0
          do while ( lib$find_file( search(2), spec, icontext(2) ) )      
           call append_node( 2, spec, search(3) )
           icontext(3) = 0
           do while ( lib$find_file( search(3), spec, icontext(3) ) )      
            call append_node( 3, spec, search(4) )
            icontext(4) = 0
            do while ( lib$find_file( search(4), spec, icontext(4) ) )      
             call append_node( 4, spec, search(5) )
             icontext(5) = 0
             do while ( lib$find_file( search(5), spec, icontext(5) ) )      
              call append_node( 5, spec, search(6) )
              icontext(6) = 0
              do while ( lib$find_file( search(6), spec, icontext(6) ) )      
               call append_node( 6, spec, search(7) )
               icontext(7) = 0
               do while ( lib$find_file( search(7), spec, icontext(7) ))      
                call append_node( 7, spec, search(0) )
               end do
               call lib$find_file_end( icontext(7) )
              end do
              call lib$find_file_end( icontext(6) )
             end do
             call lib$find_file_end( icontext(5) )
            end do
            call lib$find_file_end( icontext(4) )
           end do
           call lib$find_file_end( icontext(3) )
          end do
          call lib$find_file_end( icontext(2) )
         end do
         call lib$find_file_end( icontext(1) )
         end if

      return
      end

      subroutine append_node( level, spec, search )

      include    'swing.cmn'

      integer    level, len_node, free_node
      character  spec*255, search*255

      node_num = free_node()

      if ( level .gt. lowest_level ) lowest_level = level
      if ( level .le. last_level ) then
         line = line + 1
         num_lines = line

         node(last_node(level)).sister = node_num
         else
         node(node_num-1).child = node_num
         end if

      if ( level .ne. 0 ) then
         call file_to_dir( spec, 
     .                     node(node_num).spec,
     .                     node(node_num).length,
     .                     node(node_num).name )

         else
         call str$trim( spec, spec, len_node )
         node(node_num).spec = spec
         node(node_num).length = len_node
         if ( len_node .le. 10 ) then
            node(node_num).name = spec
            else
            node(node_num).name = spec(:11)//'*'
            end if
         end if

      node(node_num).line = line
      node(node_num).level = level
      node(node_num).rend = smg$m_reverse

      node_pointer(level,line) = node_num

      search = node(node_num).spec(1:node(node_num).length)//'*.dir;1'

      last_level = level
      last_node(level) = node_num

      return
      end

      subroutine load_display

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

      integer    jj, level

      using_screen = .true.

      if ( .not. found ) then
         cur_level = 0
         cur_line = 1
         end if

      last_level = 0
      line = 0
      do ii = 0, MAX_LEVELS
         last_line(ii) = 1
      end do         

      if ( lowest_level .gt. 4 .and. width .ne. 132 ) then
         width = 132
         call pd_undraw_bar( board_id )
         call smg$erase_display( window1 )
         call smg$erase_display( window2 )
         call smg$erase_display( window3 )
         istat = smg$change_pbd_characteristics( board_id,132,,24 )
         call smg$set_display_scroll_region( window3, 1, 2 )
         call pd_load_bar( width, pull_choices)
         call pd_draw_bar( board_id )

         else if ( lowest_level .le. 4 .and. width .ne. 80 ) then
         width = 80
         call pd_undraw_bar( board_id )
         call smg$erase_display( window1 )
         call smg$erase_display( window2 )
         call smg$erase_display( window3 )
         istat = smg$change_pbd_characteristics( board_id,80,,24 )
         call smg$set_display_scroll_region( window3, 1, 2 )
         call pd_load_bar( width, pull_choices)
         call pd_draw_bar( board_id )
         end if

      call smg$begin_pasteboard_update( board_id )

      call smg$erase_display( window2 )

      do jj = 1, num_lines
         do level = 0, MAX_LEVELS
            if ( node_pointer(level,jj) .ne. 0 )
     .         call add_node_to_display( node_pointer(level,jj) )
         end do
      end do

c     PUT UNDERLINES ON THE LEAF NODES

      do jj = 2, num_nodes
         do ii = 2, MAX_LEVELS
            if ( node_pointer(ii,jj) .ne. 0 .and.
     .           node_pointer(ii-1,jj) .ne. 0 .and.
     .           node_pointer(ii,jj-1) .ne. 0 ) then
               kk = node_pointer( ii, jj-1 )
               node(kk).rend = smg$m_underline + smg$m_reverse
               istat = smg$change_rendition( window2, node(kk).line,
     .                                       node(kk).level*17+1, 
     .                                       1, 12, node(kk).rend )
               end if
         end do
      end do

      call smg$end_pasteboard_update( board_id )

      if ( .not. found )
     .   call print_message( 'The current directory was not found in'//
     .                       ' your save file', 0 )

      return
      end

      subroutine add_node_to_display( num )

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

      integer    column, num

      node(num).rend = smg$m_reverse

      level =  node(num).level
      column = level * 17 + 1
      line =   node(num).line

      call smg$put_chars( window2, node(num).name, line, column,,
     .                    node(num).rend )
      call smg$draw_line( window2, line, column-3, line, column-1 )  

      if ( level .eq. last_level ) then
         call smg$draw_line( window2, line-1, column-3, line, column-3 )
         else if ( level .eq. last_level + 1 ) then
         call smg$draw_line( window2, line, column-5, line, column-2 )
         else if ( level .lt. last_level ) then
         call smg$draw_line( window2, last_line(level), column-3, 
     .                       line, column-3 )
         end if

      if ( .not. found .and. root .eq. node(num).spec ) then
         found = .true.
         cur_line = line
         cur_level = level
         end if

      last_level = level
      last_line(level) = line

      return
      end

      subroutine adjust_node_pointers

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

      integer ll, jj, ptr(0:7)

      do ll = 1, MAX_LINES
         do jj = 0, MAX_LEVELS
            node_pointer(jj,ll) = 0
         end do
      end do

      do jj = 0, MAX_LEVELS
         ptr(jj) = 0
      end do

      ll = 1     !LINE
      ptr(0) = 1

      node_pointer(0,ll) = 1
      ptr(1) = node(ptr(0)).child
      do while( ptr(1) .ne. 0 )
        node_pointer(1,ll) = ptr(1)
        node(ptr(1)).line = ll
        node(ptr(1)).level = 1
        ptr(2) = node(ptr(1)).child
        do while( ptr(2) .ne. 0 ) 
          node_pointer(2,ll) = ptr(2)
          node(ptr(2)).line = ll
          node(ptr(2)).level = 2
          ptr(3) = node(ptr(2)).child
          do while( ptr(3) .ne. 0 ) 
            node_pointer(3,ll) = ptr(3)
            node(ptr(3)).line = ll
            node(ptr(3)).level = 3
            ptr(4) = node(ptr(3)).child
            do while( ptr(4) .ne. 0 ) 
              node_pointer(4,ll) = ptr(4)
              node(ptr(4)).line = ll
              node(ptr(4)).level = 4
              ptr(5) = node(ptr(4)).child
              do while( ptr(5) .ne. 0 ) 
                node_pointer(5,ll) = ptr(5)
                node(ptr(5)).line = ll
                node(ptr(5)).level = 5
                ptr(6) = node(ptr(5)).child
                do while( ptr(6) .ne. 0 ) 
                  node_pointer(6,ll) = ptr(6)
                  node(ptr(6)).line = ll
                  node(ptr(6)).level = 6
                  ptr(7) = node(ptr(6)).child
                  do while( ptr(7) .ne. 0 ) 
                    node_pointer(7,ll) = ptr(7)
                    node(ptr(7)).line = ll
                    node(ptr(7)).level = 7
                    ptr(7) = node(ptr(7)).sister
                    if ( ptr(7) .ne. 0 ) ll = ll + 1
                  end do
                  ptr(6) = node(ptr(6)).sister
                  if ( ptr(6) .ne. 0 ) ll = ll + 1
                end do
                ptr(5) = node(ptr(5)).sister
                if ( ptr(5) .ne. 0 ) ll = ll + 1
              end do
              ptr(4) = node(ptr(4)).sister
              if ( ptr(4) .ne. 0 ) ll = ll + 1
            end do
            ptr(3) = node(ptr(3)).sister
            if ( ptr(3) .ne. 0 ) ll = ll + 1
          end do
          ptr(2) = node(ptr(2)).sister
          if ( ptr(2) .ne. 0 ) ll = ll + 1
        end do
        ptr(1) = node(ptr(1)).sister
        if ( ptr(1) .ne. 0 ) ll = ll + 1
      end do

      lowest_level = 0
      do ii = 1, num_nodes
         if ( node(ii).level .gt. lowest_level ) 
     .      lowest_level = node(ii).level
      end do

      if ( lowest_level .gt. 7 ) then
         call print_message( 'Directory nesting is to deep', 1 )
         end if

      num_lines = ll

      return
      end

      subroutine record_structure( search )

      include    'swing.cmn'
     
      character  spec*255
      logical    search
      integer    icontext

      if ( search .and. swing_file_exists ) then
         do ii = 1, num_nodes
            node(ii).length = 0
            node(ii).child = 0
            node(ii).sister = 0
         end do

         call load_nodes
   
         call load_display
   
         call update_screen( cur_line, cur_level )
         end if
 
      do_save = .false.

      call print_message( 'Saving directory structure', 0 )

      icontext = 0
      do while( lib$find_file( main(1:len_main)//'swing.sav;*',
     .                         spec, icontext ))
         if ( .not. lib$delete_file( spec ) ) then
            call str$trim( spec, spec, len_spec )
            if ( modify_file_prot( spec(1:len_spec), 0, 0 ) ) then
               istat = lib$delete_file( spec )
               else 
               call lib$spawn( 'SET PROT=(S:D,O:D,G:D,W:D) '//
     .                         main(1:len_main)//'swing.sav', 
     .                         'NL:', 'NL:' )
               istat = lib$delete_file( spec )
               end if
            end if
      end do
      call lib$find_file_end( icontext )

      open( unit=2, 
     .      name=main(1:len_main)//'swing.sav', 
     .      status='new',
     .      carriagecontrol='list',
     .      access='sequential',
     .      form='unformatted',
     .      recl=73,
     .      organization='sequential',
     .      recordtype='variable',
     .      iostat=istat,
     .      err=99 )

      write( 2 ) num_lines, num_nodes, lowest_level

      do ii = 1, num_lines
         write( 2 ) (node_pointer(jj,ii), jj=0, MAX_LEVELS)
      end do

      do ii = 1, num_nodes
         write( 2 ) node(ii)
      end do

      close( unit=2 )

      call print_message( 'Finished saving directory structure', 0 )

      return

99    call print_message( 'Unable to record directory structure', 0 )
      return
      end

      subroutine draw_screen

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

      integer    ii, jj, kk, smg$change_pbd_characteristics
      integer    smg$change_rendition

      call smg$begin_pasteboard_update( board_id )

      call smg$paste_virtual_display( window2, board_id, 3, 1 )
      call smg$paste_virtual_display( window1, board_id, 2, 1 )
      call smg$paste_virtual_display( window3, board_id, 23, 1 )

      call smg$set_display_scroll_region( window3, 1, 2 )

      call pd_draw_bar( board_id )

      top_line = 1
      bottom_line = 20

      node_num = node_pointer( cur_level, cur_line )

      call smg$change_rendition( window2, cur_line, cur_level*17+1,
     .                           1, 12, 
     .                           smg$m_bold + node(node_num).rend )

      if ( cur_line .gt. bottom_line ) then
         top_line = cur_line - 19
         bottom_line = cur_line
         call smg$move_virtual_display( window2, board_id, 
     .                                  23 - cur_line, 1 )
         else if ( cur_line .lt. top_line ) then
         top_line = cur_line
         bottom_line = cur_line + 19
         call smg$move_virtual_display( window2, board_id, 
     .                                     cur_line, 1 )
         end if

      call update_window1

      call smg$end_pasteboard_update( board_id )

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

      update = .true.

      return
      end

      subroutine update_window1

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

      integer    start

      if ( use_window1 ) then

      start = ( width - (len_disk + node(node_num).length) ) / 2
      if ( start .le. 0 ) start = 1

      call smg$erase_line( window1, 1, 1 )

      call smg$put_chars( window1, 
     .                    disk(1:len_disk)//
     .                    node(node_num).spec(1:node(node_num).length),
     .                    1, start,, smg$m_underline )

      end if

      return
      end

      subroutine get_location( disk, len_disk, root, len_root )
      
      integer*2  len_root
      integer*4  sys$setddir, len_disk
      character  root*255, disk*31

      call lib$sys_trnlog( 'SYS$DISK', len_disk, disk )
      istat = sys$setddir( 0, len_root, root )

      root = root(1:len_root)

      return
      end

      logical function crt

      include    '($dvidef)'
      include    '($ttdef)'
      include    '($tt2def)'

      include    'swing.cmn'

      integer*2  b2(14)
      integer*4  b4(7), buf, len_buf, sys$trnlog, sys$getdvi, dev_type
      logical*4  for$bjtest, istat

      equivalence ( b4(1), b2(1) )

      b2(1) = 4
      b2(2) = dvi$_devdepend2
      b4(2) = %loc( buf )
      b4(3) = %loc( len_buf )

      b2(7) = 4
      b2(8) = dvi$_devtype
      b4(5) = %loc( dev_type )
      b4(6) = %loc( len_dev_type )

      b4(7) = 0

      istat = sys$getdviw( ,, 'SYS$COMMAND', b4,,,, )

      crt      = ( for$bjtest( buf, tt2$v_deccrt ) .or. 
     .                            dev_type .eq. tt$_vt52 )
      avo      = for$bjtest( buf, tt2$v_avo )

      return
      end      

      subroutine define_smg_layout

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

      integer smg$create_virtual_display
      record /pd_choice_type/ sub_choices(9)

      call define_paste_board

c     CREATE THE WINDOWS

      istat = smg$create_virtual_display(  1, 132, window1 )

      istat = smg$create_virtual_display(  MAX_LINES, 132, window2 )

      istat = smg$create_virtual_display(  2, 132, window3 )

      pull_choices.number = 9
      pull_choices.choice(1) = 'Create'
      pull_choices.code(1) = 10
      pull_choices.ptr(1) = 0
      pull_choices.choice(2) = 'Rename'
      pull_choices.code(2) = 20
      pull_choices.ptr(2) = 0
      pull_choices.choice(3) = 'Move'
      pull_choices.code(3) = 30
      pull_choices.ptr(3) = 0
      pull_choices.choice(4) = 'Delete'
      pull_choices.code(4) = 40
      pull_choices.ptr(4) = 0
      pull_choices.choice(5) = 'Print'
      pull_choices.code(5) = 50
      pull_choices.ptr(5) = 0
      pull_choices.choice(6) = 'Save'
      pull_choices.code(6) = 60
      pull_choices.ptr(6) = 0
      pull_choices.choice(7) = 'Options'
      pull_choices.code(7) = 70
      pull_choices.ptr(7) = %loc( sub_choices(7) )
      pull_choices.choice(8) = 'Help'
      pull_choices.code(8) = 80
      pull_choices.ptr(8) = 0
      pull_choices.choice(9) = 'Exit'
      pull_choices.code(9) = 90
      pull_choices.ptr(9) = %loc( sub_choices(9) )

      sub_choices(1).number = 0
      sub_choices(2).number = 0
      sub_choices(3).number = 0
      sub_choices(4).number = 0

      sub_choices(5).number = 0

      sub_choices(6).number = 0

      sub_choices(7).number = 1
      sub_choices(7).choice(1) = 'display directory'
      sub_choices(7).code(1) = 71

      sub_choices(8).number = 0

      sub_choices(9).number = 2
      sub_choices(9).choice(1) = 'ok exit'
      sub_choices(9).code(1) = 91
      sub_choices(9).choice(2) = 'cancel'
      sub_choices(9).code(2) = 92

      call pd_load_bar( width, pull_choices)
     
      use_window1 = .false.

      return
      end

      subroutine set_notab( terminal, save_buffer )

C     ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL 
C     CHARACTERISTICS

      include    '($iodef)'
      include    '($ttdef)'
      include    '($tt2def)'

c                LAYOUT OF char_buffer
c
c     --------------------------------------------
c     |    buffer size     |   type   |   class  |  <- longword
c     |page len  |   terminal characteristics    |  <- longword (TTDEF)
c     |    extended terminal characteristics     |  <- longword (TT2DEF)
c     --------------------------------------------
c     31                                         0

      integer*2  iosb(4)
      integer*4  status, sys$trnlog, sys$assign, sys$qiow, chan
      integer*4  char_buffer(3), save_buffer(3)
      character  terminal*(*)

      status = sys$assign( terminal, chan,, )

      stat = sys$qiow ( %val(1), 
     .                  %val(chan), 
     .                  %val(io$_sensemode),
     .                  iosb,,, 
     .                  %Ref(save_buffer),
     .                  %val(12),,,, )

      char_buffer(1) = save_buffer(1)
      char_buffer(2) = jibclr( save_buffer(2), tt$v_mechtab )
      char_buffer(3) = save_buffer(3)

      status = sys$qiow ( %val(1), 
     .                  %val(chan), 
     .                  %val(io$_setmode),
     .                  iosb,,, 
     .                  %Ref(char_buffer),
     .                  %val(12),,,, )

      return
      end

      subroutine define_paste_board

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

C     DEC FORGOT THIS PARAMETER IN $SMGDEF
      parameter  SMG$S_PASTEBOARD_INFO_BLOCK = '20'x

      integer    smg$create_pasteboard
      integer    smg$create_virtual_keyboard
      integer    smg$set_keypad_mode
      integer    smg$get_pasteboard_attributes

      record     /smgdef/ table

      call set_notab( 'SYS$COMMAND', set_term_buf )

      istat = smg$create_pasteboard( board_id )

      istat = smg$get_pasteboard_attributes(board_id, %ref(table),
     .                                %ref(SMG$S_PASTEBOARD_INFO_BLOCK))

      width = table.smg$w_width

      istat = smg$create_virtual_keyboard( keyboard )
      istat = smg$set_keypad_mode( keyboard, 1 )

      call sm_allow_repaint

      return
      end      

      subroutine exit_swing

      include    'swing.cmn'

      character  string*3
      integer    len_string

      if ( do_save .and. swing_file_exists ) then
         call record_structure( .false. )
         end if

      call smg$delete_pasteboard( board_id, 1 )

      call smg$change_pbd_characteristics( board_id, 80,, 24 )

      call reset_terminal( 'SYS$COMMAND', set_term_buf )

      stop ' '
      end

      subroutine reset_terminal( terminal, char_buffer )

C     ROUTINE USES THE IO$_SETMODE FUNCTION TO SET TERMINAL 
C     CHARACTERISTICS

      include    '($iodef)'

c                LAYOUT OF char_buffer
c
c     --------------------------------------------
c     |    buffer size     |   type   |   class  |  <- longword
c     |page len  |   terminal characteristics    |  <- longword (TTDEF)
c     |    extended terminal characteristics     |  <- longword (TT2DEF)
c     --------------------------------------------
c     31                                         0

      integer*2  iosb(4)
      integer*4  status, sys$trnlog, sys$assign, sys$qiow, chan
      integer*4  reset, char_buffer(3)
      character  terminal*(*)

      status = sys$assign( terminal, chan,, )

      status = sys$qiow ( %val(1), 
     .                  %val(chan), 
     .                  %val(io$_setmode),
     .                  iosb,,, 
     .                  %ref(char_buffer),
     .                  %val(12),,,, )

      return
      end

      subroutine print_message( message, abort )

      include    'swing.cmn'

      logical    abort, erased
      character  message*(*)

      if ( using_screen ) then

         if ( message .eq. ' ' ) then
            if ( .not. erased ) then
               erased = .true.
               call smg$erase_display( window3 )
               call smg$erase_line( window3, 2, 1 )
               end if

            else
            erased = .false.
            call smg$erase_display( window3 )
            call smg$put_chars( window3, message, 2, 1, 1 )
            end if

         if ( abort ) call exit_swing
                  
         else
         print *, 'SWING: ', message
         if ( abort ) stop ' '
         end if

      return
      end

      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 sm_repaint_screen

      include 'swing.cmn'

      call smg$repaint_screen( board_id )

      return
      end

      subroutine sm_allow_repaint

      include 'swing.cmn'

      integer  address
      external sm_repaint_screen

      address =  %loc( sm_repaint_screen )
      call smg$set_out_of_band_asts( board_id, '800000'x, 
     .                               %val(address) )

      return
      end
