Source Code 1992 March

home *** CD-ROM | disk | FTP | other *** search

/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 3 / 3990 < prev next >

Wrap

Internet Message Format | 1991-09-09 | 14.7 KB

Path: wupost!zaphod.mps.ohio-state.edu!qt.cs.utexas.edu!cs.utexas.edu!uunet!europa.asd.contel.com!darwin.sura.net!noc.sura.net!haven.umd.edu!mimsy!nrlvx1.nrl.navy.mil!koffley From: koffley@nrlvx1.nrl.navy.mil Newsgroups: alt.sources Subject: VMS UAF PROFILE part 16 of 18 Message-ID: <1991Sep5.074757.560@nrlvx1.nrl.navy.mil> Date: 5 Sep 91 11:47:57 GMT Organization: NRL SPACE SYSTEMS DIVISION Lines: 494 -+-+-+-+-+-+-+-+ START OF PART 16 -+-+-+-+-+-+-+-+ X if ((terminator.eq.smg$k_trm_ctrlz) .or. X`091 (terminator .eq. SMG$K_TRM_CR)) then X`09 option = 4 X`09 return X`09endif X`09if (.not. status) call LIB$SIGNAL(%val(status)) X`09length = left_justify (string) X`09if (length .eq. 0) goto 1 X X`09if (string(1:1) .eq. '1') then X`09 option = 1 X`09elseif (string(1:1) .eq. '2') then X`09 option = 2 X`09elseif (string(1:1) .eq. '3') then X`09 option = 3 X`09elseif (string(1:1) .eq. 'X') then X`09 option = 4 Xc`09elseif (string(1:1) .eq. 'X') then Xc`09 option = 5 X`09else X`09 goto 1 X`09endif X X X X`09return X`09end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine OPEN_AND_READ (target_name, qheader, found) X X`09include '($FORIOSDEF)' X`09include '($SSDEF)' X`09include '($LIBDEF)' X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09common / num_elements / ordinal X X`09common / SMG_data / paste_ID, kybd_ID, num_rows, num_cols, display_ID, X`091 mm_id X X`09integer*4 qheader (2), status, base_addr, LIB$GET_VM, ordinal, X`091 target_Length, paste_ID, kybd_ID, num_rows,`20 X`092 num_cols, display_ID, mm_id X X`09logical found X X`09record / link_list / a X X X`09character*20 servers (184) X`09common / server_info / servers, bitmap_base_addr X X`09character*20 target_name X`09character*150 txt, blank X X`09integer*4 length, len_trim, ioerror, io_OK, rms_sts, rms_stv, X`091 option / 5 /, two / 2 /, bitmap_base_addr, X`092 bit_num X X`09external len_trim X X X Xc Xc ---`09See if queue is empty. If not, then empty it. Xc X`09if ((qheader(1) .ne. 0) .and. (qheader(2) .ne. 0)) then X`09 status = SS$_NORMAL X`09 do while (status .ne. LIB$_QUEWASEMP) X`09 call REMQH (qheader, status) X`09 enddo Xd`09 write (66,'(1x,2(z8,3x))') qheader(1), qheader(2) X`09endif X X`09qheader (1) = 0 X`09qheader (2) = 0 X X X X`09found = .false. X`09ordinal = 0 X X X1`09format (a150) X X X X`09call repeat (blank, ' ') X`09target_length = len_trim (target_name) X X`09open (unit = 11, file = 'sys$manager:userlog.txt', status = 'old', X`091 readonly) X X`09call STR$UPCASE (target_name, target_name) X X`09do i = 1,10000000 X`09 txt = blank X`09 read (11,1,iostat=ioerror,end=1000,err=1100) txt X`09 length = len_trim (txt) X`09 username = txt (1:20) X`09 server = txt (21:40) X`09 length = left_justify (server) X`09 time_stamp = txt (41:64) X`09 mode = txt (65:78) X`09 master_PID = txt (79:87) X`09 pid = txt (88:96) X`09 login_time = txt (97:120) X`09 uic = txt (121:140) X`09 terminal = txt (140:149) X`09 if (len_trim(server) .eq. 0) server = 'Unavailable' X`09 if (len_trim(time_stamp) .eq. 0) time_stamp = 'Unavailable' X`09 if (len_trim(mode) .eq. 0) mode = 'Unavail' X`09 if (len_trim(master_pid) .eq. 0) master_PID= 'Unavail' X`09 if (len_trim(pid) .eq. 0) pid = 'Unavail' X`09 if (len_trim(login_time) .eq. 0) login_time = 'Unavailable' X`09 if (len_trim(uic) .eq. 0) UIC = 'Unavailable' X`09 if (len_trim(terminal) .eq. 0) terminal = 'Unavail' X`09 `20 Xd`09 if (index(username,target_name(1:target_length)) .ne. 0) then Xd`09 write (66,*) username, server, time_stamp, mode, master_pid, pid, Xd`091 login_time, uic, terminal Xd`09 endif X X`09 if (index(username,target_name(1:target_length)) .ne. 0) then X`09 found = .true. X`09 ordinal = ordinal + 1 X`09 call INSQH (qheader, username, server, time_stamp, mode, X`091 master_pid, pid, login_time, uic, terminal) X`09 call INSERT_INTO_HASHTABLE (server, length) X`09 endif X X`09enddo X X`09goto 1000 X X1100`09if (ioerror .ne. io_OK) then X`09 call ERRSNS (,rms_sts,rms_stv,) X`09 call LIB$SIGNAL (%val(rms_sts),%val(rms_stv)) X`09else X`09 write (6,*) 'unknown I/O error reading USERLOG.TXT' X`09 call LIB$WAIT (3.0) X`09 call AST X`09endif X X1000`09close (unit=11) X X Xd`09bit_num = 0 X Xd`09do while (bit_num .ge. 0) Xd`09 write (6,2) X2`09format (1x,'Enter bit to test (1-184) ===> ',$) Xd`09 read (5,*) bit_num Xd`09 if (bit_num .gt. 0) then Xd`09 call test_bit (%val(bitmap_base_addr), bit_num, status) Xd`09 if (status .eq. ss$_wasset) write (6,*) 'bit was already set.' Xd`09 if (status .eq. ss$_wasclr) write (6,*) 'bit was clear.' Xd`09 endif Xd`09enddo X X`09bit_num = 0 X`09status = 0 X`09num_Bytes = 24 `09 X`09num_Longwords = nint(8. * float(num_bytes) / 32.) X X`09call find_set_bits (%val(bitmap_base_addr), bit_num, num_Longwords,`20 X`091 status) X Xd`09istat = LIB$FREE_VM (num_bytes, bitmap_base_addr) Xd`09if (.not. istat) then Xd`09 call LIB$SIGNAL (%val(istat)) Xd`09endif X X X X X`09return X`09end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X`09subroutine READ_USERNAME (target_name) X X X`09common / SMG_data / paste_ID, kybd_ID, num_rows, num_cols, display_ID, X`091 mm_id X X`09include '($SYSSRVNAM)' X`09include '($SMGDEF)' X`09include '($IODEF)' X`09include '($TRMDEF)' X X X`09real*4 val X X`09integer*4 i, status, mm_kybd_ID, mm_id, mod, term, X`091 option, left_justify, length, len_trim, scroll_ID, entry_ VID X X`09character*20 target_name X`09integer*2 terminator X`09character*1 term_string X X`09external len_trim, left_justify X X X`09mod = TRM$M_TM_CVTLOW .or. TRM$M_TM_PURGE X X1`09call SMG$ERASE_CHARS (display_ID, 23, 2, 16) X`09call SMG$SET_CURSOR_ABS (display_ID, 2, 16) X`09call repeat (target_name, ' ') X`09call SMG$READ_STRING (kybd_ID, target_name, , 20, mod , , ,`20 X`091 num_char_read ,`20 X`092 terminator, display_ID, , , , term_string) X`09length = left_justify (target_name) X`09if (length .eq. 0) goto 1 X X X X X`09return X`09end X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X`09subroutine DISPLAY_PORTS_ONLY (qheader) X X X X X`09implicit none X X`09include '($SSDEF)' X`09include '($SMGDEF)' X`09include '($TRMDEF)' X`09include '($SYSSRVNAM)' X`09include '($LIBDEF)' X`09include 'dua2:`5Bkoffley.com`5Duserlog_struc.inc' X X`09common / num_elements / num_q_elements X X`09common / SMG_data / paste_ID, kybd_ID, num_rows, num_cols, display_ID, X`091 mm_id X X`09integer*2 terminator X X`09integer*4 qheader (2), status, paste_ID, kybd_ID, num_rows,`20 X`091 num_cols, display_ID, mm_id, rows, cols, mask, X`092 modifiers, zero / 0 /, max_chars, scroll_ID, X`093 SMG$READ_STRING, num_q_elements, current_line, X`094 num_scroll_lines, address, i, num X X`09logical found X X`09record / link_list / qentry X X X`09character*80 out_str X`09character*5 in_string X X`09integer*4 length, len_trim, two / 2 /, one / 1 /, irow X X`09external len_trim, SMG$READ_STRING X X X X X X X X`09if ((qheader(1) .eq. 0) .and. (qheader(2) .eq. 0)) then X`09 write (6,*) 'Queue was empty' X`09 return X`09endif X Xd`09write (66,*) 'num q elements = ',num_q_elements X`09max_chars = 6 X`09num_scroll_Lines = 5 Xc Xc ---`09Set up the scrolling region Xc X`09rows = num_q_elements + num_scroll_lines - 1 X`09cols = 80 X`09call SMG$CREATE_VIRTUAL_DISPLAY (rows, cols, scroll_ID, SMG$M_BORDER) X`09call SMG$LABEL_BORDER (scroll_ID, ' Ports Used ') X`09call SMG$CREATE_VIEWPORT (scroll_ID, 1, 1, num_scroll_lines, 78) X`09mask = 0 X`09mask = SMG$M_SCROLL_SMOOTH + SMG$M_CURSOR_OFF X`09call SMG$SET_CURSOR_MODE (paste_ID, mask) X`09call SMG$HOME_CURSOR (scroll_ID, SMG$C_UPPER_LEFT) X`09modifiers = 0 X`09modifiers = TRM$M_TM_ESCAPE .or. TRM$M_TM_NOECHO .or.`09 X`091 TRM$M_TM_PURGE X X`09irow = 1 X X`09call GET_Q_ELEMENT (%val(qheader(1)), qentry) X X X`09call REPEAT (out_str, ' ') X`09out_str = qentry.username(1:12)//' '//qentry.login_time//' '// X`091 qentry.server//' '//qentry.terminal X`09call SMG$PUT_CHARS (scroll_ID, out_str, irow, 3, zero, ,,0) X`09irow = irow + 1 Xc Xc ---`09See if queue contained only a single element Xc X`09if ((qheader(1) .eq. qheader(2)) .or. X`091 (qentry.forward_link .eq. qentry.back_link)) then Xd`09 write (66,*) 'END OF QUEUE' X`09 irow = irow - 1 X`09 goto 700 X`09endif X X X`09do while (qentry.back_link .ne. qheader(2)) X`09 if (qentry.back_link .eq. qheader(2)) then X`09 address = qentry.back_link X`09 call GET_Q_ELEMENT (%val(address), qentry) X`09 call REPEAT (out_str, ' ') X`09 out_str = qentry.username(1:12)//' '//qentry.login_time//' '// X`091 qentry.server//' '//qentry.terminal X X`09 call SMG$PUT_CHARS (scroll_ID, out_str, irow, 3, zero, ,,0) X`09 goto 700 Xd`09 write (66,*) 'END OF QUEUE' X`09 else X`09 address = qentry.back_link X`09 call GET_Q_ELEMENT (%val(address), qentry) X`09 call REPEAT (out_str, ' ') X`09 out_str = qentry.username(1:12)//' '//qentry.login_time//' '// X`091 qentry.server//' '//qentry.terminal X X`09 call SMG$PUT_CHARS (scroll_ID, out_str, irow, 3, zero, ,,0) X`09 irow = irow + 1 X`09 endif X`09enddo X X`09if (qentry.back_link .eq. qheader(2)) then X`09 address = qentry.back_link X`09 call GET_Q_ELEMENT (%val(address), qentry) X`09 call REPEAT (out_str, ' ') X`09 out_str = qentry.username(1:12)//' '//qentry.login_time//' '// X`091 qentry.server//' '//qentry.terminal X`09 call SMG$PUT_CHARS (scroll_ID, out_str, irow, 3, zero, ,,0) Xd`09 write (66,*) 'END OF QUEUE' X`09endif X X X X X700`09continue X`09call SMG$PASTE_VIRTUAL_DISPLAY (scroll_ID, paste_ID, 13, 2) X`09status = SMG$READ_STRING (kybd_ID, in_string, , max_chars, modifiers,,,, X`091 terminator) X X`09irow = num_scroll_lines X`09current_Line = 1 X X`09do while ((status) .and. (terminator .ne. SMG$K_TRM_CR) .and. X`091 (terminator .ne. SMG$K_TRM_ENTER) .and. X`092 (terminator .ne. SMG$K_TRM_CTRLZ)) X`09 if (.not. status) call LIB$SIGNAL (%val(status)) X X`09 if ((terminator .eq. SMG$K_TRM_KP8) .or. X`091 (terminator .eq. SMG$K_TRM_UP) .or. X`092 (terminator .eq. SMG$K_TRM_NEXT_SCREEN)) then X`09 num = current_line + num_scroll_lines X`09 if (num .gt. num_q_elements) then X`09 num = num_q_elements - current_line X`09 current_line = num_q_elements X`09 else X`09 current_line = num X`09 num = num_scroll_lines X`09 endif X X`09 do i = 1, num X`09 call SMG$SCROLL_VIEWPORT (scroll_ID, SMG$M_UP, 1) X`09 enddo X`09 elseif ((terminator .eq. SMG$K_TRM_KP2) .or. X`091 (terminator .eq. SMG$K_TRM_DOWN) .or. X`092 (terminator .eq. SMG$K_TRM_PREV_SCREEN)) then X`09 num = current_line - num_scroll_lines X`09 if (num .lt. 1) then X`09 num = current_line - 1 X`09 current_line = 1 X`09 else X`09 current_line = num X`09 num = num_scroll_lines X`09 endif X X`09 do i = 1, num X`09 call SMG$SCROLL_VIEWPORT (scroll_ID, SMG$M_DOWN, 1) X`09 enddo X X elseif (terminator.eq.smg$k_trm_ctrlw) then X call smg$repaint_screen ( paste_ID ) X X elseif ((terminator.eq.smg$k_trm_ctrlz) .or. X`091 (terminator .eq. SMG$K_TRM_CR)) then X`09 goto 1000 X X`09 endif X X`09 status = SMG$READ_STRING (kybd_ID, in_string,, max_chars, X`091 modifiers,,,, terminator) X`09enddo X X1000`09mask = 0 X X X`09mask = SMG$M_SCROLL_JUMP + SMG$M_CURSOR_ON X`09call SMG$DELETE_VIRTUAL_DISPLAY (scroll_ID) X`09call SMG$SET_CURSOR_MODE (paste_ID, mask) X`09call SMG$UNPASTE_VIRTUAL_DISPLAY (scroll_id, paste_id) X X X X X`09return X`09end X X X Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Vcccc X X X X`09subroutine INSERT_INTO_HASHTABLE (server, length) X X`09include '($LIBDEF)' X`09include '($SSDEF)' X X X`09character*20 servers (184) X`09common / server_info / servers, bitmap_base_addr X X X`09integer*4 left_justify, length, hash_num, bitmap_base_addr, X`091 bit_num, status X`09character*(*) server X X`09real*4 x, rands X`09integer*4 randi, lower / 1 /, upper / 181 / , X`091 start_seed / 1055744 / X X`09call GET_HASH_NUM (%ref(kilo), %ref(Length), %loc(server)) Xd`09write (66,*) 'server ',server(1:length) ,' hashes to ',kilo X`09bit_num = 0 X`09icount = 0 X X1`09 bit_num = kilo X`09 if (bit_num .gt. 0) then X`09 call set_bit (%val(bitmap_base_addr), bit_num, status) X`09 if (status .eq. ss$_wasset) then X`09 if (servers(bit_num)(1:length) .eq. server(1:length)) then Xd`09 write (66,*) 'Duplicate detected: ',server(1:length),' --- ' V,servers(bit_num)(1:length) X`09 else Xd`09 write (66,*) 'COLLISION : ',server(1:length),' --- ',servers V(bit_num)(1:length) X`09 icount = icount + 1 +-+-+-+-+-+-+-+- END OF PART 16 +-+-+-+-+-+-+-+- -- \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/ < Joe Koffley KOFFLEY@NRLVAX.NRL.NAVY.MIL > < Naval Research Laboratory KOFFLEY@CCF.NRL.NAVY.MIL > < Space Systems Division AT&T : 202-767-0894 > \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/