% VAX-11 Librarian V04-00RXť`*K XXX1(]ADDER< CDD_EXAMPLECLEARCOMPRESS CYBERLOADCYCGDECTOHEXI DEFINITIONSR,DEMMFSuRDIRECTud DISPLAY_BITSybDTRCOM_EXAMPLEERROR}EXECUTION_MODEEXPANDYFINGERFOR$ERROR_MESSAGE FYCALENDAR GBL_RECEIVER GBL_SENDER:GETPID0 GET_CHANNELGET_DISK_QUOTAGET_NEW_PASSWORDGET_PRIVHELPOUT@HELPOUT2HEXTODEChIDLEIDLE_2<ID_LISTbGET_DISK_QUOTAGET_NEW_PASSWORDGET_PRIVHELPOUT@HELPOUT2HEXTODEChIDLEIDLE_2<ID_LISTINTERNAL_INT_2_STRINTERNAL_STR_2_INTF IS_FILE_OPENKWOTA$LOGDEFMASTER#MBX_DEL(0MENU4MMFSmMMFS_IN"MMFS_READ_QUEUED MMFS_TIMER NODE_STUFFNODFWNUMBERSf OPENCLOSEDEF PASSADMIN  PASSDELMBX PASSLOGOUTjPASSSTOPPASSWORDPRIVSF GET_CHANNEL NODE_STUFF READ_NUMBER WPL_DAKSIMLEE_EXAMPLEbNODFWNUMBERSf OPENCLOSEDEF PASSADMIN  PASSDELMBX PASSLOGOUTjPASSSTOPPASSWORDPRIVS PRIV_CLOSE PRIV_USEROPENBQIO_DISKQIO_DISK_ACCESSQIO_DISK_CALLER QIO_DISK_READ QIO_TTREAD_NOECHO$QIO_TTREAD_PROMPTp QUOTA_LIST READ_NOECHO READ_NUMBER READ_PROMPT fREWIND SEEFILE  SEE_NODES$ SETPRCNAMSLAVE SLEEPERSMGBOX<rSMGBUFp READ_PROMPT fREWIND SEEFILE  SEE_NODES$ SETPRCNAMSLAVE SLEEPERSMGBOX<rSMGBUFC SMG_REQUESTGvSMG_TERMTABLE_EXAMPLEOSYSLOGSYSTATf TERM_CHARShTIMDEFlTIMEOUTn TIME_DELTAq TIME_EXAMPLEw UFO_CREATExUFO_OPENxUSEROPENzWAKERzWHATz WPL_DAKSIM @EƏ* * A d d e r* IMPLICIT NONE& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INTEGER*4 LIB$GET_INPUT INTEGER*4 OTS$CVT_T_F REAL*4 ADDITION REAL*4 BALANCE /0.0/ INTEGER*2 I INTEGER*2 IA CHARACTER*25 OUT_BAL CHARACTER*25 OUT_LIN INTEGER*4 STATUS INTEGER*2 STR_LEN CHARACTER*25 INP_ADD INTEGER*2 Y /1/ CALL BEGIN CALL CRTCL10 CALL PLACE(1,Y)- STATUS = LIB$GET_INPUT( INP_ADD,' ',STR_LEN) IF (.NOT. STATUS) CALL EXIT5 STATUS = OTS$CVT_T_F(INP_ADD(1:STR_LEN),ADDITION,,,) BALANCE = BALANCE + ADDITION' WRITE (UNIT=OUT_BAL,FMT='(F)') BALANCE I = INDEX(OUT_BAL,'.') OUT_LIN = OUT_BAL(1:I+2) CALL PLACE(1,Y) CALL SWRT(25,OUT_LIN) Y = Y + 1 IF (Y .GE. 23) THEN CALL CRTCL Y = 1 END IF GOTO 10 32767 ENDww`Er:( DICTIONARY 'CDD$TOP.USER.MMFS_REC/LIST' RECORD /MMFS/ MMFS' DICTIONARY 'CDD$TOP.USER.X25_REC/LIST' RECORD /MBX/ MBX! MBX.USER_IN = '1234567890123456'! MBX.USER_"OUT= 'THIS IS JUST A T' MMFS.HDR.DATA_LEN = 1 MMFS.HDR.VC_CHAN = 2 MMFS.DATA(0) = 65 MMFS.DATA(1) = 66 MMFS.DATA(2) = 67 ENDww"Ə* * C L E A R* CALL BEGIN ! Crt Setup! CALL CRTCL ! Clear CRT Screen 32767 ENDww@1Ə!! C O M P R E S S . F O R! INTEGER STATUS, 2 IOSTAT, 2 IO_OK, 2 STATUS_OK PARAMETER (IO_OK = 0) PARAMETER (STATUS_OK = 1) INCLUDE '($FORDEF)' EXTERNAL DCX$_AGAIN INTEGER CONTEXT INTEGER MAP, 2 MAP_LEN CHARACTER*256 NORM_NAME INTEGER*2 NORM_LEN INTEGER NORM_LUN CHARACTER*256 COMP_NAME INTEGER*2 COMP_LEN INTEGER COMP_LUN LOGICAL EOF CHARACTER*32767 RECORD, 2 RECORD2 INTEGER RECORD_LEN, 2 RECORD2_LEN INTEGER GET_MAP, 2 WRITE_MAP INTEGER DCX$ANALYZE_INIT, 2 DCX$ANALYZE_DONE, 2 DCX$COMPRESS_INIT, 2 DCX$COMPRESS_DATA, 2 DCX$COMPRESS_DONE, 2 LIB$GET_INPUT, 2 LIB$GET_LUN, 2 LIB$FREE_VM# STATUS = LIB$GET_INPUT (NORM_NAME, 2 'File to compress: ', 2 NORM_LEN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) STATUS = LIB$GET_LUN (NORM_LUN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) OPEN (UNIT = NORM_LUN, 2 FILE = NORM_NAME(1:NORM_LEN), 2 CARRIAGECONTROL = 'NONE', 2 STATUS = 'OLD')!! Analyze Data!$ STATUS = DCX$ANALYZE_INIT (CONTEXT)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) STATUS = GET_MAP (NORM_LUN, 2 CONTEXT, 2 MAP, 2 MAP_LEN)( DO WHILE (STATUS .EQ. %LOC(DCX$_AGAIN))#! Go back to beginning of the file REWIND (UNIT = NORM_LUN) STATUS = GET_MAP (NORM_LUN, 2 CONTEXT, 2 MAP, 2 MAP_LEN) END DO1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))$ STATUS = DCX$ANALYZE_DONE (CONTEXT)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))!! Compress Data! REWIND (UNIT = NORM_LUN) STATUS = LIB$GET_LUN (COMP_LUN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))# STATUS = LIB$GET_INPUT (COMP_NAME,% 2 'File for compressed records: ', 2 COMP_LEN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) OPEN (UNIT = COMP_LUN, 2 FILE = COMP_NAME(1:COMP_LEN), 2 STATUS = 'NEW', 2 FORM = 'UNFORMATTED')* STATUS = DCX$COMPRESS_INIT (CONTEXT, MAP)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) CALL WRITE_MAP (COMP_LUN, 2 %VAL(MAP), 2 MAP_LEN) EOF = .FALSE. READ (UNIT = NORM_LUN, 2 FMT = '(Q,A)',4 2 IOSTAT = IOSTAT) RECORD_LEN, RECORD(1:RECORD_LEN) IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STATUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF DO WHILE (.NOT. EOF)% STATUS = DCX$COMPRESS_DATA (CONTEXT, 2 RECORD(1:RECORD_LEN), 2 RECORD2, 2 RECORD2_LEN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))$ WRITE (UNIT = COMP_LUN) RECORD2_LEN0 WRITE (UNIT = COMP_LUN) RECORD2 (1:RECORD2_LEN) READ (UNIT = NORM_LUN, 2 FMT = '(Q,A)',5 2 IOSTAT = IOSTAT) RECORD_LEN, RECORD (1:RECORD_LEN) IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STATUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF END DO CLOSE (NORM_LUN) CLOSE (COMP_LUN)$ STATUS = LIB$FREE_VM (MAP_LEN, MAP)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))% STATUS = DCX$COMPRESS_DONE (CONTEXT)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) END3 INTEGER FUNCTION GET_MAP (LUN,CONTEXT,MAP,MAP_LEN) INTEGER CONTEXT INTEGER LUN INTEGER MAP, MAP_LEN) INTEGER STATUS, IOSTAT, IO_OK, STATUS_OK PARAMETER (IO_OK = 0) PARAMETER (STATUS_OK = 1) INCLUDE '($FORDEF)' LOGICAL EOF CHARACTER*32767 RECORD INTEGER RECORD_LEN INTEGER DCX$ANALYZE_DATA, 2 DCX$MAKE_MAP EOF = .FALSE. READ (UNIT = LUN, 2 FMT = '(Q,A)',& 2 IOSTAT = IOSTAT) RECORD_LEN, RECORD IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STATUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF DO WHILE (.NOT. EOF): STATUS = DCX$ANALYZE_DATA (CONTEXT, RECORD(1:RECORD_LEN))1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) READ (UNIT = LUN, 2 FMT = '(Q,A)',& 2 IOSTAT = IOSTAT) RECORD_LEN, RECORD IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STATUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF END DO, STATUS = DCX$MAKE_MAP (CONTEXT,MAP,MAP_LEN) GET_MAP = STATUS END' SUBROUTINE WRITE_MAP (LUN,MAP,MAP_LEN) INTEGER LUN, MAP_LEN BYTE MAP (MAP_LEN) WRITE (UNIT = LUN) MAP_LEN WRITE (UNIT = LUN) MAP ENDww@2Ə PROGRAM CYBERLOAD INCLUDE '($FORDEF)' INTEGER*4 STATUS INTEGER*4 LIB$GET_INPUT INTEGER*4 LIB$GET_LUN INTEGER*2 FIL_LEN INTEGER INLUN INTEGER OUTLUN CHARACTER*80 INREC CHARACTER*256 INFIL CHARACTER*256 OUTFIL4 STATUS = LIB$GET_INPUT(INFIL,'Tape Drive ',FIL_LEN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = LIB$GET_LUN(INLUN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) OPEN (UNIT=INLUN, 2 FILE = INFIL(1:FIL_LEN), 2 ACCESS='SEQUENTIAL', 2 READONLY, 2 RECL=80, 2 STATUS='OLD', 2 FORM='FORMATTED')7 STATUS = LIB$GET_INPUT(OUTFIL,'Output File ', FIL_LEN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = LIB$GET_LUN(OUTLUN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))* OPEN (UNIT=OUTLUN,FILE=OUTFIL(1:FIL_LEN), 2 ORGANIZATION='SEQUENTIAL', 2 STATUS='NEW', 2 FORM='UNFORMATTED', 2 RECL=80, 2 CARRIAGECONTROL='LIST', 2 RECORDTYPE='VARIABLE') DO WHILE (.TRUE.) READ (INLUN,100,END=900) INREC100 FORMAT(A80) WRITE (OUTLUN) INREC INREC(1:80) = ' ' END DO900 CLOSE (OUTLUN) CLOSE (INLUN) ENDww+o PROGRAM CYCC?C This programs modifies or creates users in the password file.@C It also set the priviledge bits for the products for that userC IMPLICIT INTEGER (A-Z). INCLUDE 'SYS$LIBRARY:LESTABLE (SMGBUF)/LIST'CC R e c o r d L a y o u t sC) STRUCTURE /PW/ ! Password File Layout UNION ! MAP !$ CHARACTER*31 USERNAME ! Username$ CHARACTER*31 PASSWORD ! Password' INTEGER*4 PRIVILEGE(2) ! Privileges$ BYTE LOGGED_ON ! Logged On Flag1 CHARACTER*20 LOGGED_NODES ! Node Logged In On2 CHARACTER*20 EXCLUDE_NODES ! Nodes Not Allowed4 CHARACTER*20 TEMP_NODES ! Temporary Access Nodes: INTEGER*4 EXPIRATION_DATE(2) ! Password Expiration Date8 INTEGER*2 PASSWORD_LIFE ! # of Days For the Password END MAP ! MAP !' CHARACTER*62 USERPASS ! Key to File# CHARACTER*8 PRIVS ! Privileges END MAP !C MAPC INTEGER*2 WORD(4) C END MAP MAP !# CHARACTER*31 FILLER ! Username) CHARACTER*4 EMP_NO ! Employee Number END MAP ! MAP !, CHARACTER*256 RECORD ! The Whole Record END MAP ! END UNION ! END STRUCTURE !% RECORD /PW/ PW ! Record Name is PW& CHARACTER*4 YES ! General Text Area. CHARACTER*256 RECORD_SAVE ! Record Hold Area2 CHARACTER*45 ERR_MESSAGE ! FORTRAN Error Message% CHARACTER*40 TEXT ! Text Work Area) CHARACTER*23 DELTA ! Delta Time String1 CHARACTER*23 PASS_EXPIRES ! Password Expiration CHARACTER*5 PASSOUT, CHARACTER*1 TRANSL_FR ! Translate From Str* CHARACTER*1 TRANSL_TO ! Translate To Str CHARACTER*1 ICODE * INTEGER*4 CURRENT_TIME(2) ! Integer Time/ INTEGER*4 DISPLACEMENT(2) ! Time Displacement+ INTEGER*4 INPUT_LEN ! Input String Length% INTEGER*4 ZERO(2) /0,0/ ! Two Zeros INTEGER*4 NO+ INTEGER*4 MASTER ! Master Channel Number" INTEGER*4 STATUS ! Error Status0 INTEGER*4 EXPIRES_TODAY ! Password Expire Flag INTEGER*4 IER ! Error Status4 INTEGER*4 FOR$ERROR_MESSAGE ! Fortran Error Routine( INTEGER*4 LIB$ADDX ! Routine For Dates/ INTEGER*4 LIB$GET_INPUT ! Screen Read Routin !e( INTEGER*4 LIB$SUBX ! Routine For Dates4 INTEGER*4 OTS$CVT_L_TB ! Convert Integer to Binary2 INTEGER*4 OTS$CVT_L_TU ! Convert Integer to Text4 INTEGER*4 OTS$CVT_TB_L ! Convert Binary to Integer2 INTEGER*4 OTS$CVT_TI_L ! Convert Text to Integer- INTEGER*4 READ_PROMPT ! Screen Read Routine1 INTEGER*4 STR$TRANSLATE ! Translate Str Routine/ INTEGER*4 STR$UPCASE ! Translate To Uppercase/ INTEGER*4 SYS$BINTIM ! Binary Time Conversion0 INTEGER*4 SYS$GETTIM ! Get Current Binary Time" STRUCTURE /WORK/ UNION MAP CHARACTER*100 BINARY_STRING END MAP MAP CHARACTER*36 FILLER CHARACTER*1 PRIV_BITS(64) END MAP END UNION END STRUCTURE RECORD /WORK/ WORK/ DATA BLANK/ '20040'O/ ! Changed for the VAX CALL BEGINC&C O p e n P a s s w o r d F i l eC8 STATUS = LIB$GET_LUN(MASTER) ! Get Logical Unit Number. IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))% OPEN ( UNIT = MASTER, ! Unit Number$ 2 NAME = 'PASS:PW.IDX',! File Name0 2 ORGAN#IZATION = 'INDEXED', ! File Organization/ 2 RECORDTYPE = 'FIXED', ! Fixed Length Records+ 2 RECL = 64, ! Record size is really 256% 2 ACCESS = 'KEYED', ! Access by Key) 2 STATUS = 'OLD', ! File already exists) 2 KEY = (1:62), ! Key Size and Location! 2 IOSTAT = IER, ! Error Status 2 ERR = 8890, ! Error Routine 2 SHARED ) ! Share the File 9998 CONTINUE CALL CRTCL> PRINT *,'Enter User Code To Access (4 Characters - Clock #) ' PW.PASSWORD(1:31) = ' ' READ( 11 ,'(A)') $PW.PASSWORD* IF (PW.PASSWORD(1:1) .EQ. ' ') GOTO 32767- STATUS = STR$UPCASE(PW.PASSWORD,PW.PASSWORD) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF10 PRINT *, ' '( PRINT *,'Enter Product Name To Access ' PW.USERNAME(1:31) = ' ' READ( 11,'(A)') PW.USERNAME) IF (PW.USERNAME(1:1) .EQ. ' ') GOTO 9998- STATUS = STR$UPCASE(PW.USERNAME,PW.USERNAME) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IFC READ ( UNIT = MASTE%R, 2 KEY = PW.USERPASS, 2 KEYID = 0, 2 IOSTAT = IER, 2 ERR = 8081) PW.RECORD 11 TTOP = 0 7050 CALL CRTCL CALL PLACE(1,3) CALL SWRT( 11,'USER CODE ')" CALL SWRT ( 4, PW.PASSWORD(1:31))" CALL SWRT( 16,' PRODUCT CODE ')" CALL SWRT (10, PW.USERNAME(1:31)) CALL PLACE(1 , 7) PRINT *,' ACTION CODES' PRINT *,' '" PRINT *,'0 - Ignore This Entry '" PRINT *,'1 - Remove This Entry ' PRINT *,'2 - Reset Date Code ' PRINT *,'3 - Modify This Entry' PRINT *,'4 - Rese&t Password' PRINT *,'5 - Add a New Entry'7 STATUS = LIB$GET_INPUT(ICODE,'Enter Code ',INPUT_LEN) IF (.NOT. STATUS) GOTO 32767 RECORD_SAVE = PW.RECORD IF( ICODE .EQ. ' ') GO TO 9998& IF( ICODE .EQ. '0') GO TO 9998& IF( ICODE .EQ. '1') GO TO 7020& IF( ICODE .EQ. '2') GO TO 7030& IF( ICODE .EQ. '3') GO TO 7040& IF( ICODE .EQ. '4') GO TO 3018 IF( ICODE .EQ. '5') GO TO 2015 GO TO 7050CC D e l e t e R e c o r dC<7020 STATUS = LIB$'GET_INPUT(YES,'Really Delete? ',INPUT_LEN) IF (.NOT. STATUS) GOTO 9998 STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF! IF (YES(1:1) .NE. 'Y') GOTO 9998 DELETE( UNIT = MASTER, 2 IOSTAT = IER, 2 ERR = 8082) GO TO 9998C7030 CALL CRTCL CALL PLACE(1,15) EXPIRES_TODAY = 0 STATUS = LIB$GET_INPUT( DELTA, 2 'Password Lifetime? ', 2 INPUT_LEN ) IF (.NOT. STATUS) GOTO 9998 IF (INPUT_LEN .EQ. 0) GOTO 9998(! STATUS = STR$UPCASE(DELTA,DELTA)" IF (DELTA(1:5) .EQ. 'TODAY') THEN EXPIRES_TODAY = 1 DELTA(1:1) = '0' INPUT_LEN = 1 END IF4 READ ( UNIT = DELTA(1:INPUT_LEN), ! Convert String% 2 FMT = '(BN,I4)', ! To An Integer( 2 ERR = 7030 ) NO ! If Err, Re-PromptA DELTA = DELTA(1:INPUT_LEN) // ' 00:00:00.00' ! Delta Time String> STATUS = SYS$BINTIM(DELTA,DISPLACEMENT) ! Integer Delta Time> IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Print Error6 STATUS = SYS$GETTIM(CUR)RENT_TIME) ! Get Current Time IF (EXPIRES_TODAY) THEN DISPLACEMENT(1) = 0 DISPLACEMENT(2) = 0 END IF STATUS = LIB$SUBX( ZERO, 2 DISPLACEMENT, 2 DISPLACEMENT )! STATUS = LIB$ADDX( DISPLACEMENT, 2 CURRENT_TIME, 2 PW.EXPIRATION_DATE )0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))$ STATUS = SYS$ASCTIM(, PASS_EXPIRES, 2 PW.EXPIRATION_DATE, )0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,' ' PRINT *,PASS_EXPIRES+ IF (PW.RECORD .EQ. REC*ORD_SAVE) GOTO 9998 REWRITE(UNIT = MASTER, 2 ERR = 8083, 2 IOSTAT = IER ) PW.RECORD UNLOCK( UNIT = MASTER, 2 IOSTAT = IER, 2 ERR = 8083)A STATUS = READ_PROMPT('RETURN when ready " ',18, ! Prompt, Length 2 YES, I, ! Answer, Length 2 15 ) ! Timeout 15 Seconds GO TO 9998 7040 CALL CRTCL CALL PLACE(1,1)$ CALL SWRT( 11,'USER CODE ')( CALL SWRT ( 4, PW.PASSWORD(1:4))) CALL SWRT( 16,' PRODUCT CODE ')) CALL SWRT +(10, PW.USERNAME(1:31)) CALL PLACE(1,3) CALL SWRT(14,'Exclude Nodes ') CALL SWRT(20,PW.EXCLUDE_NODES) CALL PLACE(1,4) CALL SWRT(13,'Logged In On ') CALL SWRT(20,PW.LOGGED_NODES)= STATUS = OTS$CVT_L_TU( PW.LOGGED_ON, ! Convert to Character 2 YES,, 2 %VAL(1) ) TEXT(1:40) = ' '' TEXT = ' Logged In' // YES // ' Times' CALL SWRT(20,TEXT) CALL PLACE( 1,5)# CALL SWRT(18,'Password Lifetime '); STATUS = OTS$CVT_L_TU( PW.PASSWORD_LIFE, ! Convert Integer 2 YES,, ! t,o Character 2 %VAL(4) ) !( CALL SWRT(4,YES) ! Password Lifetime' IF (PW.PASSWORD_LIFE .EQ. 0) GOTO 70453 STATUS = SYS$ASCTIM(, PASS_EXPIRES, ! Convert the+ 2 PW.EXPIRATION_DATE,) ! Expiration DateD IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Display Any Error CALL PLACE(30,5)" CALL SWRT(17,'Password Expires ') CALL SWRT(11,PASS_EXPIRES)7045 CALL PLACE(14, 7)8 CALL SWRT(32,'1 2 3 4 5 6 7 8 9 10 11 ')' CALL SWRT( 14,'12 13 14 15 16') -CALL PLACE ( 13,10)9 CALL SWRT(33,'17 18 19 20 21 22 23 24 25 26 27 ')' CALL SWRT( 14,'28 29 30 31 32') CALL PLACE (13,13)9 CALL SWRT(33,'33 34 35 36 37 38 39 40 41 42 43 ')' CALL SWRT( 14,'44 45 46 47 48') CALL PLACE( 13,16)9 CALL SWRT(33,'49 50 51 52 53 54 55 56 57 58 59 ')' CALL SWRT( 14,'60 61 62 63 64')(350 STATUS = OTS$CVT_L_TB( PW.PRIVILEGE,' 2 %DESCR(WORK.BINARY_STRING(1:100)), 2 %VAL(64), 2 %VAL(8) ) TRANS.L_FR = '0' TRANSL_TO = ' ' ! Space STATUS = STR$TRANSLATE( !/ 2 WORK.BINARY_STRING(1:100), ! Convert string0 2 WORK.BINARY_STRING(1:100), ! changing zeroes) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status TRANSL_FR = '1' TRANSL_TO = 'Y' STATUS = STR$TRANSLATE( !/ 2 WORK.BINARY_STRING(1:100), ! Convert string. 2 WORK.BINARY_STRING(1:100), ! changing ones% 2 TRANSL_TO, TRANSL_FR ) ! to Ys.? IF (.NOT. STATU/S) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status DO 356 J = 1, 4 JOFSET = (J-1) * 16 DO 355 I = 1, 16C CALL PLACE(10+I*3,5+J*3) CALL PLACE(11+I*3,5+J*3)C CALL CRTWR(1,'[ ')& CALL SWRT(1,WORK.PRIV_BITS(JOFSET+I))C CALL CRTWR(1,'] ') 355 CONTINUE 356 CONTINUE380 CALL PLACE( 1,19)/ CALL SWRT(30,'Enter Priviledge Bit To Toggle') CALL PLACE ( 1,20)/ CALL SWRT(30,'Exit With a Return Only ') CALL PLACE ( 1,21). CALL SWRT(29,'Or "NODE" to Modify Node Info') CALL PLAC0E ( 1,22)< CALL SWRT(43,'Or "A" For All Bits Or "N" For No Bits ') PASSOUT(1:3) = ' ' CALL PLACE (40,22)1 STATUS = READ_PROMPT( '? ',2, ! Prompt, Length" 2 PASSOUT, I, ! Answer, Length 2 0 ) ! No Timeout% STATUS = STR$UPCASE(PASSOUT,PASSOUT)(381 IF( PASSOUT(1:1) .EQ. ' ') GO TO 335% IF( PASSOUT(1:1) .NE. 'A') GO TO 360 PW.PRIVILEGE(1) = -1 PW.PRIVILEGE(2) = -1 GO TO 350(360 IF( PASSOUT(1:1) .NE. 'N') GO TO 361' IF( PASSOUT(1:4) .EQ. 'NODE') GOTO 400 PW.PRIV1ILEGE(1) = 0 PW.PRIVILEGE(2) = 0 GO TO 350#361 STATUS = OTS$CVT_TI_L( PASSOUT, 2 NO, 2 %VAL(4), 2 %VAL(1) )) IF( NO .LT. 1 .OR. NO .GT. 64) GO TO 380! IF (WORK.PRIV_BITS(NO) .EQ. 'Y') 2 THEN WORK.PRIV_BITS(NO) = ' ' ELSE WORK.PRIV_BITS(NO) = 'Y' END IF J = IFIX(FLOAT((NO+15)/16)) I = NO - ((J*16)-16) CALL PLACE( 11+I*3, 5+J*3)" CALL SWRT ( 1,WORK.PRIV_BITS(NO)) GO TO 380 335 CONTINUE CALL PLACE (1,24)? STATUS = READ_PROMPT( 'Is This Correct? ',127, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF( IF( YES(1:1) .NE. 'Y') GOTO 9998 TRANSL_FR = ' ' ! Space TRANSL_TO = '0' ! Zero STATUS = STR$TRANSLATE( !0 2 WORK.BINARY_STRING(37:100), ! Convert string1 2 WORK.BINARY_STRING(37:100), ! changing blanks) 2 TRANSL_TO, TRANSL_FR ) ! to zeroes.? IF (.NOT. STATUS) CALL 3LIB$SIGNAL(%VAL(STATUS)) ! Check Status TRANSL_FR = 'Y' ! Y TRANSL_TO = '1' ! One STATUS = STR$TRANSLATE( !0 2 WORK.BINARY_STRING(37:100), ! Convert string- 2 WORK.BINARY_STRING(37:100), ! changing Ys' 2 TRANSL_TO, TRANSL_FR ) ! to Ones.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status3 STATUS = OTS$CVT_TB_L( WORK.BINARY_STRING(37:100), 2 PW.PRIVILEGE(1), 2 %VAL(8), )+ IF (PW.RECORD .EQ. RECORD_SAVE) GOTO 9998 REWRITE(UNIT = MASTER,4 2 ERR = 8083, 2 IOSTAT = IER ) PW.RECORD UNLOCK( UNIT = MASTER, 2 IOSTAT = IER, 2 ERR = 8083) GOTO 9998C"C N o d e I n f o r m a t i o nC400 CALL CRTCL CALL PLACE(1,1)$ CALL SWRT( 11,'USER CODE ')( CALL SWRT ( 4, PW.PASSWORD(1:4))) CALL SWRT( 16,' PRODUCT CODE ')) CALL SWRT (10, PW.USERNAME(1:31)) CALL PLACE(1,3) CALL SWRT(14,'Exclude Nodes ') CALL SWRT(20,PW.EXCLUDE_NODES) CALL PLACE(1,4) CALL SWRT(13,'Logge5d In On ') CALL SWRT(20,PW.LOGGED_NODES)= STATUS = OTS$CVT_L_TU( PW.LOGGED_ON, ! Convert to Character 2 YES,, 2 %VAL(1) ) TEXT(1:40) = ' '' TEXT = ' Logged In' // YES // ' Times' CALL SWRT(20,TEXT) CALL PLACE( 1,5)# CALL SWRT(18,'Password Lifetime '); STATUS = OTS$CVT_L_TU( PW.PASSWORD_LIFE, ! Convert Integer 2 YES,, ! to Character 2 %VAL(4) ) !( CALL SWRT(4,YES) ! Password Lifetime& IF (PW.PASSWORD_LIFE .EQ. 0) GOTO 4103 STATUS = SYS$ASCTIM(, PASS_EXPIRE6S, ! Convert the+ 2 PW.EXPIRATION_DATE,) ! Expiration DateD IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Display Any Error CALL PLACE(30,5)" CALL SWRT(17,'Password Expires ') CALL SWRT(11,PASS_EXPIRES)!410 TEXT(1:20) = PW.EXCLUDE_NODES CALL PLACE ( 1,15)> STATUS = LIB$GET_INPUT( PW.EXCLUDE_NODES, ! Nodes To Disallow! 2 'Disallow Nodes? ', ! Prompt# 2 INPUT_LEN) ! Length of Answer IF (.NOT. STATUS) GOTO 7040% IF (INPUT_LEN .EQ. 0) ! If RETURN 2 THEN ! th7en...6 PW.EXCLUDE_NODES(1:20) = TEXT(1:20) ! No Change Made INPUT_LEN = 20 END IF3 STATUS = STR$UPCASE(PW.EXCLUDE_NODES(1:INPUT_LEN),# 2 PW.EXCLUDE_NODES(1:INPUT_LEN) ) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 7040 END IF TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space; STATUS = STR$TRANSLATE( PW.EXCLUDE_NODES, ! Convert string' 2 PW.EXCLUDE_NODES, ! changing Nulls) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$8SIGNAL(%VAL(STATUS)) ! Check Status TEXT(1:20) = PW.LOGGED_NODES CALL PLACE ( 1,17)> STATUS = LIB$GET_INPUT( PW.LOGGED_NODES, ! Nodes Currently On 2 'Logged Nodes? ', ! Prompt# 2 INPUT_LEN) ! Length of Answer IF (.NOT. STATUS) GOTO 7040% IF (INPUT_LEN .EQ. 0) ! If RETURN 2 THEN ! then...5 PW.LOGGED_NODES(1:20) = TEXT(1:20) ! No Change Made INPUT_LEN = 20 END IF2 STATUS = STR$UPCASE(PW.LOGGED_NODES(1:INPUT_LEN)," 2 PW.LOGGED_NODES(1:INPUT_LEN) ) IF (.NOT. S9TATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 7040 END IF TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space: STATUS = STR$TRANSLATE( PW.LOGGED_NODES, ! Convert string& 2 PW.LOGGED_NODES, ! changing Nulls) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status CALL PLACE ( 1, 19) TEXT(1:20) = PW.TEMP_NODES> STATUS = LIB$GET_INPUT( PW.TEMP_NODES, ! Temp Nodes To Allow% 2 'Temp Nodes To Allow? ',! Prompt# 2 I:NPUT_LEN) ! Length of Answer IF (.NOT. STATUS) GOTO 7040% IF (INPUT_LEN .EQ. 0) ! If RETURN 2 THEN ! then...3 PW.TEMP_NODES(1:20) = TEXT(1:20) ! No Change Made INPUT_LEN = 20 ! Set Length END IF0 STATUS = STR$UPCASE(PW.TEMP_NODES(1:INPUT_LEN), 2 PW.TEMP_NODES(1:INPUT_LEN) ) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 7040 END IF TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space9 STATUS = STR$TRANSLATE( PW.TEMP_NODES, ! Convert s;tring% 2 PW.TEMP_NODES, ! changing Nulls) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status CALL PLACE ( 1, 21)1 STATUS = LIB$GET_INPUT( TEXT, ! Time Logged In% 2 'Times Logged On Now? ',! Prompt# 2 INPUT_LEN) ! Length of Answer IF (.NOT. STATUS) GOTO 7040% IF (INPUT_LEN .EQ. 0) ! If RETURN 2 THEN ! then... GOTO 480 ! No Change END IF! READ ( UNIT = TEXT(1:INPUT_LEN),! 2 FMT = '(BN,I1)' ) PW.LOGG<ED_ON480 CALL PLACE(40,15) EXPIRES_TODAY = 0 STATUS = LIB$GET_INPUT( DELTA, 2 'Password Lifetime? ', 2 INPUT_LEN ) IF (.NOT. STATUS) GOTO 7040 IF (INPUT_LEN .EQ. 0) GOTO 7040! STATUS = STR$UPCASE(DELTA,DELTA)" IF (DELTA(1:5) .EQ. 'TODAY') THEN EXPIRES_TODAY = 1 DELTA(1:1) = '0' INPUT_LEN = 1 END IF4 READ ( UNIT = DELTA(1:INPUT_LEN), ! Convert String% 2 FMT = '(BN,I4)', ! To An Integer' 2 ERR = 480 ) NO ! If Err, Re-PromptA DELTA = DELTA(1:INPUT=_LEN) // ' 00:00:00.00' ! Delta Time String> STATUS = SYS$BINTIM(DELTA,DISPLACEMENT) ! Integer Delta Time> IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Print Error6 STATUS = SYS$GETTIM(CURRENT_TIME) ! Get Current Time IF (EXPIRES_TODAY) THEN DISPLACEMENT(1) = 0 DISPLACEMENT(2) = 0 END IF STATUS = LIB$SUBX( ZERO, 2 DISPLACEMENT, 2 DISPLACEMENT )! STATUS = LIB$ADDX( DISPLACEMENT, 2 CURRENT_TIME, 2 PW.EXPIRATION_DATE )0 IF (.NOT. STATUS) CALL LIB$SIGN>AL(%VAL(STATUS)) GOTO 7040C,C R e c o r d D o e s N o t E x i s tC 2020 CONTINUE< PRINT *,'User Code Does Not Exist - Do You Wish To Create 'C2011 STATUS = READ_PROMPT( 'Enter "Y" or "N" ',17, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF PRINT *,' ') IF( YES(1:1) .EQ. 'Y') GO TO 2018) IF( YES(1:1) .EQ. 'N') GO TO 9?998 GO TO 2011CC A d d N e w R e c o r dC 2015 CONTINUE CALL CRTCL> PRINT *,'Enter User Code To Access (4 Characters - Clock #) ' PW.PASSWORD(1:31) = ' ' READ( 11 ,'(A)') PW.PASSWORD) IF (PW.PASSWORD(1:1) .EQ. ' ') GOTO 9998- STATUS = STR$UPCASE(PW.PASSWORD,PW.PASSWORD) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF PRINT *, ' '( PRINT *,'Enter Product Name To Access ' PW.USERNAME(1:31) = ' ' READ( 11,'(A)') PW.USERNAME@) IF (PW.USERNAME(1:1) .EQ. ' ') GOTO 9998- STATUS = STR$UPCASE(PW.USERNAME,PW.USERNAME) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF' READ ( UNIT = MASTER, ! Check to see( 2 KEY = PW.USERPASS, ! if this record" 2 KEYID = 0, ! already exists.* 2 ERR = 2018) PW.RECORD ! If so, then..., PRINT *,'Record Already Exists' ! say so.A STATUS = READ_PROMPT('RETURN when ready " ',18, ! Prompt, Length 2 YES, I, ! Answer, Length 2 15 ) ! TiAmeout 15 Seconds GOTO 2015 2018 CONTINUE2021 PW.PRIVILEGE(1) = 0 PW.PRIVILEGE(2) = 0 PW.LOGGED_ON = 0 PW.PASSWORD_LIFE = 0 PW.EXPIRATION_DATE(1) = 0 PW.EXPIRATION_DATE(2) = 00 PW.EXCLUDE_NODES(1:20) = ' '- PW.TEMP_NODES(1:20) = ' '/ PW.LOGGED_NODES(1:20) = ' ', WRITE ( UNIT = MASTER, ! Write the Record! 2 IOSTAT = IER, ! to the File 2 ERR = 8084 ) PW.RECORD !* READ ( UNIT = MASTER, ! Read the Record& 2 KEYB = PW.USERPASS, ! back in, for 2 KEYID = 0, ! privilege bit 2 IOSTAT = IER, ! update 2 ERR = 8081) PW.RECORD !- RECORD_SAVE = PW.RECORD ! Save the Record" GOTO 7040 ! Go to Priv UpdateCC R e s e t P a s s w o r dC3018 CALL CRTCL CALL PLACE ( 1,3) CALL SWRT( 11,'USER CODE ')" CALL SWRT ( 4, PW.PASSWORD(1:31))" CALL SWRT( 16,' PRODUCT CODE ')" CALL SWRT (10, PW.USERNAME(1:31)) CALL PLACE(1 , 4)( TEXT = 'Password ' // PW.PASSWORD(5:31) CALL SWRT(4C0,TEXT) CALL PLACE ( 1,7)4 STATUS = LIB$GET_INPUT( TEXT, ! Nodes To Disallow 2 'Password? ', ! Prompt# 2 INPUT_LEN) ! Length of Answer IF (.NOT. STATUS) GOTO 7050% IF (INPUT_LEN .EQ. 0) ! If RETURN 2 THEN ! then... GOTO 7050 ! No Change END IF' STATUS = STR$UPCASE(TEXT(1:INPUT_LEN), 2 TEXT(1:INPUT_LEN) ) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 7050 END IF TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space1 STATUS D= STR$TRANSLATE( TEXT, ! Convert string 2 TEXT, ! changing Nulls) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status DELETE( UNIT = MASTER, 2 IOSTAT = IER, 2 ERR = 8085)) PW.PASSWORD = RECORD_SAVE(32:35) // TEXT, WRITE ( UNIT = MASTER, ! Write the Record! 2 IOSTAT = IER, ! to the File 2 ERR = 8084 ) PW.RECORD !* READ ( UNIT = MASTER, ! Read the Record& 2 KEY = PW.USERPASS, ! back in, for 2 KEYID = 0, E ! privilege bit 2 IOSTAT = IER, ! update 2 ERR = 8081) PW.RECORD !- RECORD_SAVE = PW.RECORD ! Save the Record GO TO 7050CC E r r o r M e s s a g e sC 8081 PRINT *,PW.USERPASS PRINT *,'Error Code =',IER PRINT *,'Unit =',MASTER, STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE GOTO 20202 8082 PRINT *,'Error Deleting Record ',PW.USERPASS PRINT *,'Error Code =',IER PRINT *,'Unit =',MASTER, STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE)F PRINT *,ERR_MESSAGE CALL EXIT2 8083 PRINT *,'Error Updating Record ',PW.USERPASS PRINT *,'Error Code =',IER PRINT *,'Unit =',MASTER, STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE CALL EXIT1 8084 PRINT *,'Error Writing Record ',PW.USERPASS PRINT *,'Error Code =',IER, STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGEA STATUS = READ_PROMPT('RETURN when ready " ',18, ! Prompt, Length 2 YES, I, ! Answer, Length 2 15 ) ! Timeout 15 SeconGds GOTO 999878085 PRINT *,'Error Changing the Password ',PW.USERPASS PRINT *,'Check Record', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE, WRITE ( UNIT = MASTER, ! Write the Record! 2 IOSTAT = IER, ! to the File 2 ERR = 8084 ) RECORD_SAVE !* READ ( UNIT = MASTER, ! Read the Record+ 2 KEY = RECORD_SAVE(1:62), ! back in, for 2 KEYID = 0, ! privilege bit 2 IOSTAT = IER, ! update 2 ERR = 8081) PW.RECORD !- RECORD_SAVE = PW.RECORD ! Save theH RecordA STATUS = READ_PROMPT('RETURN when ready " ',18, ! Prompt, Length 2 YES, I, ! Answer, Length 2 15 ) ! Timeout 15 Seconds GOTO 999818890 PRINT *,'Error Opening Master Password File', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE CALL EXIT28891 PRINT *,'INDEX PASSWORD FILE DOES NOT EXIST' CALL EXITCC C l o s e F i l eC32767 CLOSE (MASTER) ENDww ]Ə** D E C T O H E X* CHARACTER*64 HEX_STIR CHARACTER*32 DEC_STR INTEGER*4 DEC_VAL INTEGER*4 ISTAT INTEGER*4 INPUT_LEN INTEGER*4 OTS$CVT_L_TZ INTEGER*4 OTS$CVT_TU_L INTEGER*4 LIB$GET_INPUT: ISTAT = LIB$GET_INPUT(DEC_STR,'Decimal Value ',INPUT_LEN) IF (.NOT. ISTAT) GOTO 32767! IF (INPUT_LEN .EQ. 0) GOTO 32767< ISTAT = OTS$CVT_TU_L(DEC_STR(1:INPUT_LEN),DEC_VAL,%VAL(4),)6 ISTAT = OTS$CVT_L_TZ(DEC_VAL,HEX_STR,%VAL(2),%VAL(4)) DO I = 1,64$ IF (HEX_STR(I:I) .NE. ' ') GOTO 100 END DO100 PRINT *,HEX_STR(I:64) 3276J7 ENDww_g PROGRAM DEFINITIONS IMPLICIT NONE INCLUDE '($SSDEF)'CC F u n c t i o n sC1 INTEGER*4 FOR$ERROR_MESSAGE ! Decode Error Code0 INTEGER*4 LIB$GET_INPUT ! Get Input At Screen, INTEGER*4 LIB$GET_LUN ! Get a Unit Number. INTEGER*4 READ_PROMPT ! Get Input At Screen. INTEGER*4 STR$UPCASE ! Convert to UppercaseCC R e c o r d L a y o u tC STRUCTURE /DEFINE_RECORD/ UNION MAP CHARACTER*10 LOGICAL_NAME CHARACTER*900 DIRECTORKIES END MAP MAP CHARACTER*910 RECORD END MAP END UNION END STRUCTURE RECORD /DEFINE_RECORD/ DEFCC V a r i a b l e sC* CHARACTER*45 ERR_MESSAGE ! Error Message! INTEGER*4 IER ! I/O Error Code* INTEGER*2 LEN ! Used for Return Lengths- INTEGER*4 MASTER ! Master File Unit Number' CHARACTER*(*) OPTIONS ! User Options PARAMETER (OPTIONS =@ 2 'Add, Change, Inquire, Next, Delete, or End (A,C,I,N,D,E): ')/ INTEGER*2 OPT_LEN ! Length of OPTIONS String PLARAMETER (OPT_LEN = 58) !% INTEGER*2 RETURN ! Used for GOTOs.( CHARACTER*5 SELECTION ! User Selection, INTEGER*4 STATUS ! Function Return Status CALL BEGIN ! Get CRT type CALL CRTCL ! Clear the CRTCC O p e n F i l eC8 STATUS = LIB$GET_LUN(MASTER) ! Get Logical Unit Number. IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))% OPEN ( UNIT = MASTER, ! Unit Number, 1 NAME = 'LES:DEFINITIONS.IDX',! File Name0 2 ORGANIZATION = 'INDEXED', ! File Organization5 3 RECORMDTYPE = 'VARIABLE', ! Variable Length Records% 4 ACCESS = 'KEYED', ! Access by Key) 5 STATUS = 'OLD', ! File already exists) 6 KEY = (1:10), ! Key Size and Location! 7 IOSTAT = IER, ! Error Status 8 ERR = 9000, ! Error Routine 9 SHARED ) ! Share the File100 DO WHILE (.TRUE.) CALL PLACE(1,23)> STATUS = READ_PROMPT( OPTIONS,OPT_LEN,! Prompt, Prompt Length$ 2 SELECTION,LEN, ! Answer, Length 3 0 ) ! Timeout) STATUS = STR$UPCASE(SELECTION,SELECTION)7 IF (SELECTINON(1:1) .EQ. 'E') GOTO 900 ! Quit if 'END'6 IF (SELECTION(1:1) .EQ. 'A') GOTO 1000 ! Add a Record9 IF (SELECTION(1:1) .EQ. 'C') GOTO 2000 ! Change a Record: IF (SELECTION(1:1) .EQ. 'I') GOTO 3000 ! Look At a Record= IF (SELECTION(1:1) .EQ. 'N') GOTO 4000 ! Look At Next Record9 IF (SELECTION(1:1) .EQ. 'D') GOTO 5000 ! Delete a Record CALL PLACE(1,24)- CALL SWRT(28,'Invalid Selection, Try Again') 198 END DOCC C l o s e F i l e sC&900 CLOSE (MASTER) ! Close The File COALL CRTCL ! Clear the CRT CALL EXIT ! Quit& GOTO 32767 ! Should Never Get HereCC A d d a R e c o r dC1000 RETURN = 1$ GOTO 7000 ! Ask For Logical Name 1010 CONTINUE+ WRITE ( UNIT = MASTER, ! Write the Record 2 IOSTAT = IER, ! to the File 2 ERR = 9003 ) DEF.RECORD ! 1098 GOTO 198CC C h a n g e R e c o r dC2000 RETURN = 2 GOTO 7000 ! Ask For The Key'2010 GOTO 6000 ! Read File Using Key2020 REWRITE(UNIT = MASTER, 2 ERR = 9002, 2P IOSTAT = IER ) DEF.RECORD UNLOCK( UNIT = MASTER, 2 IOSTAT = IER, 2 ERR = 9002) 2098 GOTO 198CC I n q u i r eC3000 RETURN = 3 GOTO 7000 ! Ask For the Key'3010 GOTO 6000 ! Read File Using Key 3020 CONTINUE3030 PRINT *,DEF.RECORD 3098 GOTO 198CC N e x t R e c o r dC 4000 CONTINUE 4098 GOTO 198CC D e l e t e R e c o r dC5000 RETURN = 5 GOTO 7000 ! Ask For the Key'5010 GOTO 6000 ! Read File Using Key 5020 CONTINUE 5098 GOTO Q198C&C R e a d R e c o r d B y K e yC6000 READ ( UNIT = MASTER, 2 KEY = DEF.LOGICAL_NAME, 3 KEYID = 0, 4 IOSTAT = IER, 5 ERR = 9001) DEF.RECORD' GOTO (1098,2020,3020,4098,5020) RETURN 6098 GOTO 198CC A s k F o r K e yC7000 CALL CRTCL CALL PLACE(10,10)* STATUS = LIB$GET_INPUT( DEF.LOGICAL_NAME, 2 'Logical Name: ', 3 LEN )/ IF ((LEN .EQ. 0) .OR. (.NOT. STATUS)) GOTO 198' GOTO (1010,2010,3010,4098,5010) RETURN 7098 GOTO 198CC E rR r o r R o u t i n e sC19000 PRINT *,'Error Opening Master Password File', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE CALL EXIT+9001 PRINT *,'Error In READ BY KEY Routine', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE CALL EXIT9002 PRINT *,'Error In REWRITE', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERR_MESSAGE CALL EXIT#9003 PRINT *,'Error In ADD Routine', STATUS = FOR$ERROR_MESSAGE(IER,ERR_MESSAGE) PRINT *,ERRS_MESSAGE CALL EXIT 32767 ENDww 1** D E _ M M F S _ D R I V E R* PROGRAM DEMMFS_DRIVERCC Needs Options File on Link.C PSECT_ATTR = GBL, PAGEC< DICTIONARY 'CDD$TOP.USER.X25_REC/LIST' ! X25 Master Mailbox RECORD /MBX/ X25 !7 DICTIONARY 'CDD$TOP.USER.MMFS_REC/LIST' ! MMFS Mailbox RECORD /MMFS/ MMFS !' INCLUDE '($IODEF)' ! QIO Parameters- INCLUDE '($SECDEF)' ! Glbl Section Params9 INCLUDE 'SYS$INCLUDE:COMSATQUE.PAR' ! COMSAT Que Layou Tt5 INCLUDE 'SYS$INCLUDE:MMFSDEF.PAR' ! MMFS Parameters7 INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR' ! MMFS Queue Layout5 INCLUDE 'SYS$INCLUDE:DPQENTRY.PAR' ! DP Queue Entry5 INCLUDE 'SYS$INCLUDE:SYSERR.PAR' ! VCS Error Params; INCLUDE 'SYS$INCLUDE:SCANHEADR.PAR' ! Scan Record Offsets> INCLUDE 'SYS$INCLUDE:SCNDATDEF.PAR' ! Scan Record Definition7 INCLUDE 'SYS$INCLUDE:WHOLESCAN.PAR' ! Scan Record Def9 INCLUDE 'SYS$INCLUDE:DAINIT.PAR' ! Data Aqc Init Record8 INTEGER*2 ANY_CURRENT_CONTROL US ! # of Current Controls/ INTEGER*4 ASCEFC_ERR(3) ! SYS$ASCEFC Err Msg 2 /'SYS$','EFC ','ERR '/ !/ INTEGER*4 CRMPSC_ERR(3) ! SYS$CRMPSC Err Msg 2 /'SYS$','CRMP','SC '/ !0 INTEGER*2 CTL(1024) ! Ptr to Current Controls1 BYTE CURRENT_CONTROLS(1024) ! Current Controls7 INTEGER*2 CURRENT_CONTROLS_MAX ! Maximum Virtual Crct* PARAMETER (CURRENT_CONTROLS_MAX = 1024) !2 INTEGER*4 ERROR_RETURN(2) ! VECTOR Error Status) INTEGER*4 FILE_NUM(200) ! File Numbers3 INTEGER*4 GET V_LUN_ERR(3) ! LIB$GET_LUN Error Msg 2 /'LIB$','GET_','LUN '/ !, INTEGER*4 INFO_FLAG /71/ ! Flag From TIMER, INTEGER*2 INFO_LUN ! Unit of Section File/ INTEGER*4 INIT_ERROR(3) ! Init Error Message 2 /'INIT',' -ER','ROR '/ !" INTEGER*4 LEN ! Bytes Returned0 INTEGER*4 LUERRMSG(3) ! General Vector Errors 2 /' ',' ',' '/ !1 CHARACTER*16 MBX_INPUT ! MBX From X.25 Routine0 CHARACTER*16 MBX_OUTPUT ! MBX To X.25 Routine, INTEGER*2 MMFS_LEN ! MMFS Length from W X25* INTEGER*2 MMFS_TRANS ! MMFS Transaction2 INTEGER*2 MMFS_TRANS_MAX ! MMFS Transaction Max% PARAMETER (MMFS_TRANS_MAX = 32767) !) BYTE OUT_REC(512) ! Output Byte Array/ INTEGER*4 PASS_ADDR(2) ! Addresses of Global" BYTE PRCNAM(12) ! Process Name. 2 /'D','A','$','D','E','M','M','F','S',3*' '/' CHARACTER*8 PROCID ! VMS Job Number3 BYTE QUEUE_NAME(12,200) ! Queue Names for Global% INTEGER*4 QUEUE_NUM ! Queue Number& INTEGER*4 READ_CODE ! MBX Read Code- INTEGER*4 X RECORD_NUM(200) ! Record Numbers- INTEGER*4 REQUEST_FLAG /70/ ! Flag to TIMER( BYTE REQUEST_TYPE(200) ! Request Type. INTEGER*4 RET_ADDR(2) ! From Global Section" INTEGER*2 RSPNS ! RTU Response) INTEGER*2 SEC_CHAN ! Channel of Global- INTEGER*2 SEC_LEN ! Global Section Length- INTEGER*4 SEC_MASK ! Mask for Glbl Section- INTEGER*4 SETEF_ERR(3) ! SYS$SETEF Err Msg 2 /'SYS$','SETE','F '/ !/ INTEGER*4 SPECIAL(5) ! VECTOR Special Fields- INTEGER*4 STATUS ! FYunction Return Status1 INTEGER*2 TBL_PTR /0/ ! Global Section Pointer/ INTEGER*2 TIMER(200) ! Timeouts in Glbl Sctn5 INTEGER*2 TRANS_NUMBER(200) ! Trans #s in Glbl Sctn2 INTEGER*2 TRANSACTION_NUMBER ! MMFS Trans Number* CHARACTER*16 USER_IN_MBX ! User Mailbox3 INTEGER*2 USER_IN_MBX_CHAN ! User Mailbox Channel, INTEGER*4 VCSID /760/ ! VECTOR Program ID/ INTEGER*4 WAITFR_ERR(3) ! SYS$WAITFR Err Msg 2 /'SYS$','WAIT','FR '/ !CC F u n c t i o n sC% INTEGER*4 DE_MM ZFSIZE ! Remove MMFS+ INTEGER*4 LIB$GET_LUN ! Get Logical Unit- INTEGER*4 SYS$ASCEFC ! Setup Event Cluster/ INTEGER*4 SYS$ASSIGN ! Setup Mailbox Channel( INTEGER*4 SYS$CREMBX ! Create Mailbox( INTEGER*4 SYS$CREPRC ! Create Process0 INTEGER*4 SYS$CRMPSC ! Create/Map Global Sctn) INTEGER*4 SYS$QIOW ! Queue I/O Request' INTEGER*4 SYS$SETEF ! Set Event Flag- INTEGER*4 SYS$WAITFR ! Wait For Event Flag+ INTEGER*4 UFO_CREATE ! User Open Routine' EXTERNAL UFO_CREATE ![ '' '' ''C.C S t r u c t u r e s a n d R e c o r d sC STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 WRITER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUSCC C o m m o n B l o c k sC) COMMON /UFO/ SEC_CHAN ! From UFO_CREATE COMMON /RECS/ MMFS* COMMON /VCS/ VCSID, ERROR_RETURN, SPECIALCC G l o b a l C o m m o nC0 COMMON /GBL/ TBL_PTR, ! Array Element Pointer( 2 TRANS_NUMBER, ! Transaction Number 3 QUEUE_NAME, ! Qu\eue Name 4 TIMER, ! How Many Minutes 5 FILE_NUM, ! File Number! 6 RECORD_NUM, ! Record Number" 7 REQUEST_TYPE, ! Request Type 8 X25, ! X25 Mailboxes 9 CTL, ! Ptr to Controls) 9 CURRENT_CONTROLS, ! Current Controls1 9 ANY_CURRENT_CONTROLS ! # of Current ControlsCC P r o c e s s i n gC. CALL DA$SIMINT( VCSID, ! Init Using VCSID, 2 PRCNAM, ! Process Name, 2 SPECIAL, ! Special Fields,( 2 ERROR_RETURN ) ! and Error Return.= IF (ERROR_R ]ETURN(1) .NE. DMS$_SUCCESS) THEN ! If error, then3 CALL LU$ERROR(VCSID,ERROR_RETURN, ! Log the error) 2 INIT_ERROR,SPECIAL,ERROR_RETURN)! and CALL EXIT ! Quit. END IF !, CALL GETPID(PROCID) ! Get the Job Number8 STATUS = LIB$GET_LUN(INFO_LUN) ! Allocate Unit Number+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ^! 2 GET_LUN_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------= SEC_LEN = ((%LOC(ANY_CURRENT_CONTROLS) ! Calculate Size for< 2 - %LOC(TBL_PTR) + 2 + 511) / 512) ! the Global Section.> ! last addr - first addr + length of last element + 511 / 512, OPEN ( UNIT = INFO_LUN, ! Open Dummy File) 2 FILE = 'ACTIVITY.TBL', ! That will be& 3 STATUS = 'NEW', ! Mapped into the, 4 INITIALSIZE = SEC_LEN, ! Global Section. 5 USEROPEN = _UFO_CREATE ) ! CLOSE (INFO_LUN) !C C Create Global Section and Map C ACTIVITY.TBL into the SectionC4 SEC_MASK = SEC$M_WRT .OR. SEC$M_DZRO .OR. SEC$M_GBL6 PASS_ADDR(1) = %LOC(TBL_PTR) ! Beginning of SectionB PASS_ADDR(2) = %LOC(ANY_CURRENT_CONTROLS) ! End of Global Section6 STATUS = SYS$CRMPSC( PASS_ADDR, ! Create and Map the! 2 RET_ADDR, ! Global Section. 2 , ! 2 %VAL(SEC_MASK), ! Mask+ 2 'ACTIVITY_TBL ', ! Global Section Name 2 ,, !) 2 %VAL(SEC_`CHAN),,,,) ! Channel Number+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 CRMPSC_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------C"C C r e a t e M a i l b o x e sC+ USER_IN_MBX = X25.USER_IN ! Mailbox Name3 STATUS = SYS$CREMBX( %VAL(1), ! Permanent Mailboax, 2 USER_IN_MBX_CHAN, ! Channel for Mailbox 3 %VAL(200), ! Max Size 4 ,,, !" 5 USER_IN_MBX ) ! Mailbox Name+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '4D455243'X ! CREM! LUERRMSG(3) = '20205842'X ! BX, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SPECIAL, ! 2 ERROR_RbETURN ) ! CALL EXIT ! Quit END IF !-----------------4 STATUS = SYS$ASCEFC(%VAL(REQUEST_FLAG),'CLUSTER',,)+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 ASCEFC_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------& DO WHILE (.TRUE.) !*** L O O P ***+ c READ_CODE = IO$_READVBLK ! QIO Operation! MMFS_LEN = 512 ! Size of QIO STATUS = SYS$QIOW(, !. 2 %VAL(USER_IN_MBX_CHAN), ! Mailbox Channel 3 %VAL(READ_CODE), ! Read 4 IOSTATUS,,, ! IOSB 5 %REF(MMFS), ! Data Buffer* 6 %VAL(MMFS_LEN),,,, ) ! Length of Data/ IF (.NOT. STATUS) THEN ! If it didn't work,8 ERROR_RETURN(1) = DMS$_SYS_SRV ! Say it's a VMS error, ERROR_RETURN(2) = STATUS ! Tell the Error# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '574F4d951'X ! QIOW LUERRMSG(3) = '20202020'X !0 CALL LU$ERROR( VCSID, ! Vector Error Routine 2 ERROR_RETURN, ! 3 LUERRMSG, ! Error Message 4 SPECIAL, ! 5 ERROR_RETURN ) ! CALL EXIT END IF3 MMFS_LEN = IOSTATUS.MSG_LEN ! Size of QIO buffer IF (MMFS.HDR.FUNC .GT. 2) THEN= STATUS = DE_MMFSIZE(MMFS,MMFS_LEN,OUT_REC, ! Remove MMFS. 2 RSPNS,TRANSACTION_NUMBER) ! from the Data.$ IF (TRANSACTION_NUMBER .LE. 0) THEN* ERROR_RETURN(1) = 2 ! Setup Error Codese ERROR_RETURN(2) = 0 !" LUERRMSG(1) = '6F72655A'X ! Zero" LUERRMSG(2) = '61725420'X ! tra" LUERRMSG(3) = '2320736E'X ! ns #/ CALL LU$ERROR( VCSID, ! Vector Error Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 ERROR_RETURN ) ! CALL EXIT ! Return END IF ! IF (TRANSACTION_1 IF ((RSPNS .EQ. FRS) .OR. (RSPNS .EQ. NRS)) THEN, IF (TIMER(TRANSACTION_NUMBER) .LT. 0) THEN0 MFS$_FINAL_STATE = 3 ! Final State of Request3 MFS$_REQ_TYPE = REQUEST_TYPE(TRfANSACTION_NUMBER)2 MFS$_QUE_LENGTH = 244 ! Length of Data Returned) QUEUE_NUM = 0 ! Zero the Queue Number1 CALL LQ$PUTQUE(VCSID, ! Send Data to the Queue& 2 QUEUE_NAME(1,TRANSACTION_NUMBER), 3 MFS$_ENTRY_LONGWORDS, 4 244, 5 QUEUE_NUM, 6 SPECIAL, 7 ERROR_RETURN ) END IF ! IF (TIMER(TRANSAC! END IF ! IF ((RSPNS .EQ. FR END IF ! IF (MMFS.HDR.FUNC7 STATUS = SYS$SETEF(%VAL(REQUEST_FLAG)) ! Notify TIMER+ IF (.NOT. STATUS) THEN ! If Errogr, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 SETEF_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------7 STATUS = SYS$WAITFR(%VAL(INFO_FLAG)) ! Wait for TIMER+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CAhLL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 WAITFR_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !----------------- END DO !*** L O O P *** END ** D E _ M M F S I Z E*5 INTEGER*4 FUNCTION DE_MMFSIZE(MMFS,MMFS_LEN,OUT_REC," 2 RESPONSE,TRANSACTION_NUMBER ) IMPLICIT NONE# INCLUDE 'SYS$INCLUDE:MMFSDEF.PAR'( DICTIONARY 'CDD$TOP.USER.MMFS_REC/LIST' RECORD /MMFS/ MMFS! BYTE DATA_NAME(16) i! Data Name& INTEGER*2 DN_LEN ! Data Name Length( INTEGER*2 DS_LEN ! Data Stream Length* INTEGER*4 ERROR_RETURN(2) ! Error Return INTEGER*2 I ! Loop Counter+ INTEGER*4 LUERRMSG(3) ! Vector Error Text, INTEGER*2 MMFS_LEN ! Length of MMFS Buffer- INTEGER*4 OCTETS_IN_MSG ! Octets In Message/ INTEGER*4 OCTETS_IN_SUB ! Octets In Sub-Field& BYTE OUT_REC(*) ! Output Byte Array# INTEGER*2 RESPONSE ! RTU Response, INTEGER*4 SPECIAL(5) ! Vector Special Info# INTEGER*4 STATUS j! Return Status7 INTEGER*2 TRANSACTION_NUMBER ! MMFS Transaction Number& INTEGER*4 VCSID ! Vector Program ID INTEGER*2 WORD ! Work Word INTEGER*2 X ! General Purpose* COMMON /VCS/ VCSID, ERROR_RETURN, SPECIAL' RESPONSE = 0 ! Clear Response First X = 0 ! Buffer Pointer: IF (MMFS.DATA(X) .NE. OC) THEN ! If first byte not an OC* ERROR_RETURN(1) = 2 ! Setup Error Codes ERROR_RETURN(2) = 0 !" LUERRMSG(1) = '4F206F4E'X ! No O" LUERRMSG(2) = '74657463'X ! ctet" kLUERRMSG(3) = '746E4320'X ! cnt4 CALL LU$ERROR( VCSID, ! Call Vector Error Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 ERROR_RETURN ) !" STATUS = 0 ! Set Return Status GOTO 32767 ! Return END IF WORD = MMFS.DATA(1) X = 2 IF (BTEST(WORD,7)) THEN/C Octet Count Content Subfield is a long field OCTETS_IN_MSG = 0$ OCTETS_IN_SUB = IAND(WORD,'007F'X) DO I = 1,OCTETS_IN_SUB3 OCTETS_IN_MSG = OCTETS_IN_MSG*256 + MMFS.DATA(X) X = X + 1 ENlD DO3 OCTETS_IN_MSG = 2 + OCTETS_IN_SUB + OCTETS_IN_MSG ELSE1C Octet Count Content Subfield is a short field.( OCTETS_IN_MSG = 2 + IAND(WORD,'007F'X) END IF'C IF (OCTETS_IN_MSG .NE. MMFS_LEN) THEN+C ERROR_RETURN(1) = 2 ! Setup Error CodesC ERROR_RETURN(2) = 0 !#C LUERRMSG(1) = '6574634F'X ! Octe#C LUERRMSG(2) = '6F4E2074'X ! t No#C LUERRMSG(3) = '74522074'X ! t rt5C CALL LU$ERROR( VCSID, ! Call Vector Error LoggingC 2 ERROR_RETURN, !C 3 LUERRMSG, !C m4 SPECIAL, !C 5 ERROR_RETURN ) !#C STATUS = 0 ! Set Return StatusC GOTO 32767 ! ReturnC END IF IF (MMFS.DATA(X) .NE. TN) THEN* ERROR_RETURN(1) = 2 ! Setup Error Codes ERROR_RETURN(2) = 0 !" LUERRMSG(1) = '4E205254'X ! TR n" LUERRMSG(2) = '4620746F'X ! ot f" LUERRMSG(3) = '646E756F'X ! ound4 CALL LU$ERROR( VCSID, ! Call Vector Error Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 ERROR_RETURN ) !" STATUS = 0 ! Set Return Status GOTOn 32767 ! Return END IF X = X + 1 ! Bump Pointer$ WORD = MMFS.DATA(X) ! Make a Word X = X + 1 ! Bump the Pointer* IF (BTEST(WORD,7)) THEN ! If Bit 7 Set?-C Id subfield is a long field. ! If so, then4 TRANSACTION_NUMBER = 0 ! Clear Transaction Number8 OCTETS_IN_SUB = IAND(WORD,'007F'X) ! Octs in Sub Field6 DO I = 1,OCTETS_IN_SUB ! Calculated Transaction Num0 TRANSACTION_NUMBER = TRANSACTION_NUMBER * 256 2 + MMFS.DATA(X)! X = X + 1 ! Bump the Pointer$ o END DO ! DO I = 1,OCTETS_IN_SUB ELSE ! Else) TRANSACTION_NUMBER = IAND(WORD,'007F'X) END IF ! IF (BTEST(WORD,7))*: IF (MMFS.DATA(X) .EQ. PC) THEN ! If its a Procedure Code X = X + 1 ! Bump Counter5 IF (MMFS.DATA(X) .EQ. FRS) THEN ! If Final Response! RESPONSE = FRS ! Set Response= ELSE IF (MMFS.DATA(X) .EQ. NRS) THEN ! If Negative Response! RESPONSE = NRS ! Set Response( END IF ! IF (MMFS.DATA(X) .EQ. FRS)D ELSE IF ((MMFS.DATA(X) .EQ. CRQ) .OR. (MMFSp.DATA(X) .EQ. CMD)) THEN X = X + 1 ! Bump the Pointer# IF (MMFS.DATA(X) .EQ. IG2) THEN ! X = X + 1 ! Bump it Again$ IF (MMFS.DATA(X) .EQ. WRI) THEN! X = X + 1 ! Bump it Once More! IF (MMFS.DATA(X) .EQ. DN) THEN X = X + 1 ! Bump it Again' WORD = MMFS.DATA(X) ! Make a Word* IF (BTEST(WORD,7)) THEN ! Test Bit 70 DN_LEN = IBITS(WORD,0,7)! Length is one byte X = X + 1 ! Bump Pointer& DO I = 1,DN_LEN ! Move the Length" DATA_NAME(I) = MMqFS.DATA(X) ! X = X + 1 ! Bump Pointer END DO ! DO I = 1,DN_LEN ELSE ! Else X = X + 1 ! Bump Pointer DN_LEN = 1 ! Length is 1- DATA_NAME(1) = MMFS.DATA(X) ! Move Length# END IF ! IF (BTEST(WORD,7)) X = X + 1 ! Bump Pointer, DO WHILE ((MMFS.DATA(X) .NE. CT) .AND. 2 (X .LT. MMFS_LEN ))! X = X + 1 ! Bump Pointer# END DO ! DO WHILE ((MMFS.DA, DO WHILE ((MMFS.DATA(X) .NE. DS) .AND. 2 (X .LT. MMFS_LEN ))!r X = X + 1 ! Bump Pointer# END DO ! DO WHILE ((MMFS.DA X = X + 1 ! Bump Pointer( WORD = MMFS.DATA(X) ! Make a Word X = X + 1 ! Bump Pointer1 IF (BTEST(WORD,7)) THEN ! Test bit 7, If On$ DS_LEN = 0 ! Data Stream Length& OCTETS_IN_SUB = IAND(WORD,'007F'X)0 DO I = 1,OCTETS_IN_SUB ! Calculate DS Length) DS_LEN = DS_LEN * 256 + MMFS.DATA(X) X = X + 1 ! Bump Pointer END DO ! DO I = 1,OCTETS ELSE ! Else0 DS_LEN = s IAND(WORD,'007F'X) ! Byte is Length# END IF ! IF (BTEST(WORD,7))- DO I = 1,DS_LEN ! For length of Stream2 OUT_REC(I) = MMFS.DATA(X) ! Move the Stream! X = X + 1 ! Bump Pointer END DO ! DO I = 1,DS_LEN ELSE ! Else,. ERROR_RETURN(1) = 2 ! Setup Error Codes ERROR_RETURN(2) = 0 !& LUERRMSG(1) = '44206F4E'X ! No D% LUERRMSG(2) = '20617461'X ! ata& LUERRMSG(3) = '656D614E'X ! Name7 CALL LU$ERROR(VCSID, ! Call Vector tError Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 ERROR_RETURN ) !& STATUS = 0 ! Set Return Status GOTO 32767 ! Return END IF ELSE+ ERROR_RETURN(1) = 2 ! Setup Error Codes ERROR_RETURN(2) = 0 !# LUERRMSG(1) = '20324749'X ! IG2# LUERRMSG(2) = '20746F4E'X ! Not# LUERRMSG(3) = '20495257'X ! WRI5 CALL LU$ERROR( VCSID, ! Call Vector Error Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 u ERROR_RETURN ) !# STATUS = 0 ! Set Return Status GOTO 32767 ! Return END IF ! ELSE !- ERROR_RETURN(1) = 2 ! Setup Error Codes ERROR_RETURN(2) = 0 !% LUERRMSG(1) = '49206F4E'X ! No I# LUERRMSG(2) = '20203247'X ! G2 LUERRMSG(3) = '20202020'X !6 CALL LU$ERROR(VCSID, ! Call Vector Error Logging 2 ERROR_RETURN, ! 3 LUERRMSG, ! 4 SPECIAL, ! 5 ERROR_RETURN ) !% STATUS = 0 ! Set Return Status GOTO 32767 ! Re'vturn END IF END IF32767 DE_MMFSIZE = STATUS RETURN ENDwwsƏCC D I R E C TC C FORT DIRECTC LINK DIRECT,DIRC CHARACTER*80 FILENAME /'*.RNO'/ CHARACTER*80 RETSTR(25) INTEGER*4 NUM INTEGER*4 DIR NUM = DIR(FILENAME,RETSTR) PRINT *,NUM PRINT *,FILENAME PRINT *,RETSTR ENDww ** D i s p l a y B i t s*' INTEGER*4 FUNCTION DISPLAY_BITS(VALUE) INCLUDE '($SSDEF)' CHARACTER*1 TRANSL_FR CHAwRACTER*1 TRANSL_TO INTEGER*4 NO INTEGER*4 OTS$CVT_L_TB INTEGER*4 STR$TRANSLATE INTEGER*4 STATUS INTEGER*4 VALUE INTEGER*2 X& STRUCTURE /WORK/ ! Define Work Area UNION ! MAP ! CHARACTER*255 STRING ! CHARACTER*32 BINARY_STRING ! END MAP ! MAP ! BYTE ARRAY(255) !! CHARACTER*1 BINARY_ARRAY(32) ! END MAP ! END UNION ! END STRUCTURE !- RECORD /WORK/ WORK ! Work Area Is a Record( COMMON /WORK/ WORK ! Common Work Arxea CALL PLACE(13, 7)2 CALL SWRT(33,'31 30 29 28 27 26 25 24 23 22 21 ') CALL SWRT(14,'20 19 18 17 16') CALL PLACE ( 13,10)2 CALL SWRT(33,'15 14 13 12 11 10 9 8 7 6 5 ') CALL SWRT(14,' 4 3 2 1 0') 10 STATUS = OTS$CVT_L_TB( VALUE,& 2 %DESCR(WORK.BINARY_STRING(1:32)), 2 %VAL(32), 2 %VAL(4) ) TRANSL_FR = '0' TRANSL_TO = ' ' ! Space STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string/ 2 WORK.BINARY_STRING(1:32), ! changing zeryoes) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status TRANSL_FR = '1' TRANSL_TO = 'Y' STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string- 2 WORK.BINARY_STRING(1:32), ! changing ones% 2 TRANSL_TO, TRANSL_FR ) ! to Ys.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status DO 355 X = 1, 32 J = IFIX(FLOAT(X+15) / 16) I = X - ((J*16) - 16) CALL PLACE(62-I*3,14-J*3) NO = 33 - X&355 zCALL SWRT(1,WORK.BINARY_ARRAY(NO))32767 DISPLAY_BITS = SS$_NORMAL RETURN ENDwwƏ IMPLICIT INTEGER (A - Z)& DICTIONARY 'CDD$TOP.RTU.PNT_REC/LIST' INCLUDE '($SSDEF)'$ INCLUDE 'DTR$LIBRARY:DAB.FOR/LIST'% INTEGER*4 DTR$COMMAND ! DTR Routine& INTEGER*4 DTR$CONTINUE ! DTR Routine" INTEGER*4 DTR$DTR ! DTR Routine/ INTEGER*4 DTR$INIT ! Datatrieve Init Function/ CHARACTER*132 MESSAGES ! Datatrieve Interface INTEGER*4 SET_RTU_FILE" INTEGER*4 STATUS ! {Error Status0 CHARACTER*132 AUXILIARY ! Datatrieve Interface BYTE SCN$_RTU_ID(12)5 2 /'5','0','0','.','T','U','L','S','A',' ',' ',' '/ STATUS = DTR$INIT( DAB, 100, 2 MESSAGES, 3 AUXILIARY, 4 DTR$M_SEMI_COLON_OPT ). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))7 STATUS = SET_RTU_FILE(SCN$_RTU_ID) ! Set File Logical IF (.NOT. STATUS) THEN* PRINT *,'Can''t Setup File Logical Name' CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF: STATUS = DTR$COMMAND(DAB,|'@RTU$:WPL_EXTRACT_VPID_HOST;' )>C STATUS = DTR$COMMAND(DAB,':CDD$TOP.RTU.EXTRACT_VPID_HOST;' )$ STATUS = DTR$DTR(DAB,DTR$M_OPT_CMD) STATUS = DTR$CONTINUE(DAB) 32767 END ( INTEGER*4 FUNCTION SET_RTU_FILE(RTU_ID) INTEGER*4 LIB$SET_LOGICAL INTEGER*2 CHANNEL CHARACTER*1 DOT /'.'/ INTEGER*2 LENGTH /0/ CHARACTER*21 RTU_FILE BYTE RTU_ID(12) INTEGER*4 STATUS /1/ CHARACTER*1 UNDL /'_'/& STRUCTURE /STRING/ ! Structure for! UNION ! String Redefinition MAP } ! With Byte Array. CHARACTER*12 STRING ! END MAP ! MAP ! BYTE BARRAY(12) ! END MAP ! END UNION ! END STRUCTURE !' RECORD /STRING/ CNV ! Record is CNV@ CALL LU$MOVBYT(12, RTU_ID, CNV.BARRAY,0) ! Move Bytes To String6 CALL STR$TRANSLATE( RTU_FILE, ! Translate the String& 2 CNV.STRING, ! Into RTU_FILE name 2 UNDL, ! Making Underlines 2 DOT ) ! From Dots.+ CALL STR$TRIM( RTU_FILE, ! Trim Filename 2 RTU_FILE, ! Of all G~arbage$ 2 LENGTH ) ! And Get the Length.; RTU_FILE = RTU_FILE(1:LENGTH) // '.RTU' ! Create FileName RTU_FILE = 'RTU$:' // RTU_FILE? STATUS = LIB$SET_LOGICAL('RTUDAT',RTU_FILE)! File Logical Name.32767 SET_RTU_FILE = STATUS ! Return Status RETURN ENDww Ə INTEGER*4 ERROR INTEGER*4 LIB$SIGNAL INTEGER*4 STATUS TYPE 100#100 FORMAT('$Enter Error Number: ') ACCEPT *,ERROR! STATUS = LIB$SIGNAL(%VAL(ERROR)) ENDww+gƏ SUBROUTINE EXECUTION_MODE(MODE)** E X E C U T I O N _ M O D E*** Returns MODE to the Caller.*%* IF (MODE .EQ. 0) JOB_TYPE = 'Other''* IF (MODE .EQ. 1) JOB_TYPE = 'Network'%* IF (MODE .EQ. 2) JOB_TYPE = 'Batch'+* IF (MODE .EQ. 3) JOB_TYPE = 'Interactive'* INTEGER*4 SYS$GETJPIW INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' INTEGER*4 ISTAT STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE STRUCTURE /IOSBLK/ INTEGER*4 STATUS, ZEROED END STRUCTURE RECORD /ITMLST/ JPI_LIST(2) RECORD /IOSBLK/ IOSB INTEGER*4 MODE JPI_LIST( 1).BUFLEN = 4 JPI_LIST( 1).ITMCOD = JPI$_MODE! JPI_LIST( 1).BUFADR = %LOC(MODE) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).END_LIST = 0$ ISTAT = SYS$GETJPIW(,,,JPI_LIST,,,). IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ENDwwƏ!! E X P A N D . F O R! INTEGER STATUS! CHARACTER*256 OLD_FILE, NEW_FILE INTEGER*2 OLD_LEN, NEW_LEN INTEGER OLD_LUN, NEW_LUN INTEGER MAP, MAP_LEN EXTERNAL EXPAND_DATA INTEGER LIB$GET_LUN, 2 LIB$GET_INPUT, 2 LIB$GET_VM, 2 LIB$FREE_VM STATUS = LIB$GET_LUN (OLD_LUN)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS))" STATUS = LIB$GET_INPUT (OLD_FILE, 2 'File to expand: ', 2 OLD_LEN)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS)) OPEN (UNIT = OLD_LUN, 2 STATUS = 'OLD', 2 FILE = OLD_FILE(1:OLD_LEN), 2 FORM = 'UNFORMATTED') STATUS = LIB$GET_LUN (NEW_LUN)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS))" STATUS = LIB$GET_INPUT (NEW_FILE,$ 2 'File to hold expanded data: ', 2 NEW_LEN)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS)) OPEN (UNIT = NEW_LUN, 2 STATUS = 'NEW', 2 CARRIAGECONTROL = 'NONE', 2 FILE = NEW_FILE(1:NEW_LEN)) READ (UNIT = OLD_LUN) MAP_LEN# STATUS = LIB$GET_VM (MAP_LEN, MAP)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS)) CALL EXPAND_DATA (%VAL(MAP), 2 MAP_LEN, 2 OLD_LUN, 2 NEW_LUN)$ STATUS = LIB$FREE_VM (MAP_LEN, MAP)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS)) END8 SUBROUTINE EXPAND_DATA (MAP, MAP_LEN, OLD_LUN, NEW_LUN)" INTEGER MAP_LEN, OLD_LUN, NEW_LUN BYTE MAP(MAP_LEN) INTEGER STATUS, 2 IOSTAT, 2 IO_OK, 2 STATUS_OK PARAMETER (IO_OK = 0) PARAMETER (STATUS_OK = 1) INCLUDE '($FORDEF)' INTEGER CONTEXT LOGICAL EOF CHARACTER*32767 RECORD, RECORD2 INTEGER RECORD_LEN, RECORD2_LEN INTEGER DCX$EXPAND_INIT, 2 DCX$EXPAND_DATA, 2 DCX$EXPAND_DONE READ (UNIT = OLD_LUN) MAP1 STATUS = DCX$EXPAND_INIT (CONTEXT, %LOC(MAP(1)))1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) EOF = .FALSE. READ (UNIT = OLD_LUN, 2 IOSTAT = IOSTAT) RECORD_LEN IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STATUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF DO WHILE (.NOT. EOF), READ (UNIT = OLD_LUN) RECORD (1:RECORD_LEN)# STATUS = DCX$EXPAND_DATA (CONTEXT, 2 RECORD(1:RECORD_LEN), 2 RECORD2, 2 RECORD2_LEN)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) WRITE (UNIT = NEW_LUN,& 2 FMT = '(A)') RECORD2(1:RECORD2_LEN) READ (UNIT = OLD_LUN, 2 IOSTAT = IOSTAT) RECORD_LEN IF (IOSTAT .NE. IO_OK) THEN CALL ERRSNS (,,,,STATUS)& IF (STATUS .NE. FOR$_ENDDURREA) THEN! CALL LIB$SIGNAL (%VAL(STA TUS)) ELSE EOF = .TRUE. STATUS = STATUS_OK END IF END IF END DO# STATUS = DCX$EXPAND_DONE (CONTEXT)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS)) ENDwwA A** F I N G E R* PROGRAM FINGER IMPLICIT NONE INCLUDE '($FORIOSDEF)' INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)'C)C E x t e r n a l D e f i n i t i o n sCC Module: STATEDEFC EXTERNAL SCH$C_CEF EXTERNAL SCH$C_COLPG EXTERNAL SCH$C_COM EXTERNAL SCH$C_COMO EXTERNAL SCH$C_CUR EXTERNAL SCH$C_FPG EXTERNAL SCH$C_HIB EXTERNAL SCH$C_HIBO EXTERNAL SCH$C_LEF EXTERNAL SCH$C_LEFO EXTERNAL SCH$C_MWAIT EXTERNAL SCH$C_PFW EXTERNAL SCH$C_SUSP EXTERNAL SCH$C_SUSPO+ INTEGER*2 ACCOUNT_LEN ! Length of Account) CHARACTER*80 BLANKS ! String of Blanks' INTEGER*4 CONTEXT ! Proc ID Wildcard( CHARACTER*11 CPUTIM ! CPU Time String. CHARACTER*23 DATETIME ! Data and Time String. CHARACTER*45 ERR_MESSAGE ! I/O Error Message) CHARACTER*23 EXPIRES ! Expiration Date/ INTEGER*2 FIRST_TIME ! Just a Flag for GETJPI( INTEGER*2 FLGLEN ! Login Flags Length- CHARACTER*40 FOREIGN_COMMAND ! Foreign Line1 INTEGER*4 FOR$ERROR_MESSAGE ! Get I/O Error Text' INTEGER*4 GET_LFLGS ! Get Login Flags, INTEGER*4 GET_PRIMEDAYS ! Get Primary Days/ INTEGER*4 GET_PRIVILEGES ! Get VMS Privileges' INTEGER*4 GPGCNT ! Global Page Count" INTEGER*2 I ! Loop Counter, etc& CHARACTER*55 IMAGNAME ! Program Name. INTEGER*4 IMAGNAME_LEN ! Program Name Length! INTEGER*4 ISTAT ! Error Status INTEGER*2 J ! Just Like I% CHARACTER*13 JOB_TYPE ! Type of Job+ CHARACTER*255 L_FLAGS ! Text Login Flags1 INTEGER*4 LIB$DATE_TIME ! Date and Time Routine. INTEGER*4 LIB$GET_FOREIGN ! Get Foreign Line- INTEGER*4 LIB$GET_INPUT ! Get Input Routine1 INTEGER*4 LIB$GET_LUN ! Get Logical Unit Number' INTEGER*4 LIB$SYS_FAO ! Format Output0 CHARACTER*23 LOGIN_I ! Last Interactive Login, CHARACTER*23 LOGIN_N ! Last Network Login- INTEGER*4 LOGINTIM(2) ! Login Time Quadword, CHARACTER*39 LOGINTIME ! Login Time String. INTEGER*2 MAIL_FILE ! Mail File Logical Unit+ INTEGER*2 MAIL_NEWMES ! New Mail Messages& BYTE MAIL_REC(272) ! VMSMAIL Record* INTEGER*4 MASTER_PID ! Master Process Id6 CHARACTER*8 MASTER_PROCID ! Master Process Id String INTEGER*4 MODE ! Process Mode& CHARACTER*8 NULLS ! Null Characters" INTEGER*4 PAGEFLTS ! Page Faults INTEGER*4 PID ! Process Id% CHARACTER*15 PRCNAM ! Process Name, INTEGER*4 PRCNAM_LEN ! Process Name Length% CHARACTER*27 PRIMEDAYS ! Prime Days# INTEGER*4 PRIORITY ! Job Priority. EXTERNAL PRIV_USEROPEN ! Privileged Useropen( INTEGER*2 PRIVLEN ! Privileges Length, CHARACTER*255 PRIVSTR ! Privileges String) CHARACTER*8 PROCID ! Process Id String. CHARACTER*23 PWDCHNG ! Password Change Date+ CHARACTER*23 PWDLIFE ! Password Lifetime* CHARACTER*8 QUAD_TIME ! Quad Time String" CHARACTER*15 S_UIC ! UIC String% INTEGER*2 SCREEN ! SYS$OUTPUT Unit) CHARACTER*27 SECONDARY ! Secondary Days INTEGER*4 SIZE ! Job Size" INTEGER*4 STATE ! Process State. CHARACTER*5 STATE_STR ! Process State String# INTEGER*4 STATUS ! Return Status- INTEGER*4 STR$TRANSLATE ! Translate Routine- INTEGER*4 STR$UPCASE ! Convert To Uppercase( INTEGER*4 SYS$ASCTIM ! Time Conversion5 INTEGER*4 SYS$GETJPIW ! Get Job Process Information, INTEGER*4 SYS$GETUAI ! Get UAF Information" CHARACTER*23 TEMP ! Misc String! CHARACTER*7 TERMINAL ! Terminal* INTEGER*4 TERMINAL_LEN ! Terminal Length0 CHARACTER*33 TRANSL_FR ! Translate From String2 CHARACTER*1 TRANSL_TO /' '/ ! Translate To String" CHARACTER*12 USERNAME ! Username* INTEGER*4 USERNAME_LEN ! Username Length- CHARACTER*12 USRNAM ! Username From GETJPI) INTEGER*4 USRNAM_LEN ! Length of USRNAM INTEGER*2 X ! Used Like I( EQUIVALENCE (MAIL_NEWMES, MAIL_REC(34))** U A F R E C O R D* STRUCTURE /UAFREC/ UNION MAP CHARACTER*12 USERNAME INTEGER*4 UIC CHARACTER*12 ACCOUNT CHARACTER*32 OWNER CHARACTER*16 DEVICE CHARACTER*64 DIRECTORY CHARACTER*256 COM_FILE CHARACTER*40 CLI CHARACTER*32 TABLES INTEGER*4 PASSWORD(2) CHARACTER*8 PASSWORD2 INTEGER*4 LGIFAILS INTEGER*2 SALT BYTE B_ENCRYPT BYTE B_ENCRYPT2 INTEGER*4 PWD_LENGTH INTEGER*4 Q_EXPIRATION(2) INTEGER*4 Q_PWD_LIFETIME(2) INTEGER*4 Q_PWD_DATE(2) CHARACTER*8 Q_PWD2_DATE INTEGER*4 Q_LASTLOGIN_I(2) INTEGER*4 Q_LASTLOGIN_N(2) INTEGER*4 PRIV(2) INTEGER*4 DEF_PRIV(2) CHARACTER*20 MIN_CLASS CHARACTER*20 MAX_CLASS INTEGER*4 LOGIN_FLAGS INTEGER*4 NETWORK_ACCESS_P INTEGER*4 NETWORK_ACCESS_S INTEGER*4 BATCH_ACCESS_P INTEGER*4 BATCH_ACCESS_S INTEGER*4 LOCAL_ACCESS_P INTEGER*4 LOCAL_ACCESS_S INTEGER*4 DIALUP_ACCESS_P INTEGER*4 DIALUP_ACCESS_S INTEGER*4 REMOTE_ACCESS_P INTEGER*4 REMOTE_ACCESS_S INTEGER*4 PRIMEDAYS INTEGER*4 PRI INTEGER*4 QUEPRI INTEGER*4 MAXJOBS INTEGER*4 MAXACCTJOBS INTEGER*4 MAXDETACH INTEGER*4 PRCCNT INTEGER*4 BIOLM INTEGER*4 DIOLM INTEGER*4 TQCNT INTEGER*4 ASTLM INTEGER*4 ENQLM INTEGER*4 FILLM INTEGER*4 SHRFILLM INTEGER*4 WSQUOTA INTEGER*4 DFWSCNT INTEGER*4 WSEXTENT INTEGER*4 PGFLQUOTA INTEGER*4 CPUTIM INTEGER*4 BYTLM INTEGER*4 PBYTLM INTEGER*4 JTQUOTA INTEGER*2 W_PROXY_LIM INTEGER*2 W_PROXIES INTEGER*2 W_ACCOUNT_LIM INTEGER*2 W_ACCOUNTS CHARACTER*8 S_CPUTIM END MAP MAP CHARACTER*12 %FILL INTEGER*2 UIC_MEM INTEGER*2 UIC_GRP END MAP MAP CHARACTER*16 %FILL BYTE ACCOUNT_LEN CHARACTER*11 %FILL BYTE OWNER_LEN CHARACTER*31 %FILL BYTE DEVICE_LEN CHARACTER*15 %FILL BYTE DIRECTORY_LEN CHARACTER*63 %FILL BYTE COM_FILE_LEN CHARACTER*255 %FILL BYTE CLI_LEN CHARACTER*39 %FILL BYTE TABLES_LEN END MAP END UNION END STRUCTURE RECORD /UAFREC/ UAF** W O R K A R E A S* STRUCTURE /LOGMAP/ UNION MAP INTEGER*4 LAST_DATE INTEGER*4 LAST_TIME END MAP MAP CHARACTER*8 LASTLOGIN END MAP END UNION END STRUCTURE RECORD /LOGMAP/ LOG STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE STRUCTURE /IOSBLK/ INTEGER*4 STATUS, ZEROED END STRUCTURE RECORD /ITMLST/ ITEM_LIST(53) RECORD /ITMLST/ JPI_LIST(14) RECORD /IOSBLK/ IOSB ITEM_LIST( 1).BUFLEN = 9$ ITEM_LIST( 1).ITMCOD = UAI$_ACCOUNT) ITEM_LIST( 1).BUFADR = %LOC(UAF.ACCOUNT)) ITEM_LIST( 1).RETADR = %LOC(ACCOUNT_LEN) ITEM_LIST( 2).BUFLEN = 4" ITEM_LIST( 2).ITMCOD = UAI$_ASTLM' ITEM_LIST( 2).BUFADR = %LOC(UAF.ASTLM) ITEM_LIST( 2).RETADR = 0 ITEM_LIST( 3).BUFLEN = 4+ ITEM_LIST( 3).ITMCOD = UAI$_BATCH_ACCESS_P0 ITEM_LIST( 3).BUFADR = %LOC(UAF.BATCH_ACCESS_P) ITEM_LIST( 3).RETADR = 0 ITEM_LIST( 4).BUFLEN = 4+ ITEM_LIST( 4).ITMCOD = UAI$_BATCH_ACCESS_S0 ITEM_LIST( 4).BUFADR = %LOC(UAF.BATCH_ACCESS_S) ITEM_LIST( 4).RETADR = 0 ITEM_LIST( 5).BUFLEN = 4" ITEM_LIST( 5).ITMCOD = UAI$_BIOLM' ITEM_LIST( 5).BUFADR = %LOC(UAF.BIOLM) ITEM_LIST( 5).RETADR = 0 ITEM_LIST( 6).BUFLEN = 4" ITEM_LIST( 6).ITMCOD = UAI$_BYTLM' ITEM_LIST( 6).BUFADR = %LOC(UAF.BYTLM) ITEM_LIST( 6).RETADR = 0 ITEM_LIST( 7).BUFLEN = 32& ITEM_LIST( 7).ITMCOD = UAI$_CLITABLES( ITEM_LIST( 7).BUFADR = %LOC(UAF.TABLES) ITEM_LIST( 7).RETADR = 0 ITEM_LIST( 8).BUFLEN = 4# ITEM_LIST( 8).ITMCOD = UAI$_CPUTIM( ITEM_LIST( 8).BUFADR = %LOC(UAF.CPUTIM) ITEM_LIST( 8).RETADR = 0 ITEM_LIST( 9).BUFLEN = 40# ITEM_LIST( 9).ITMCOD = UAI$_DEFCLI% ITEM_LIST( 9).BUFADR = %LOC(UAF.CLI) ITEM_LIST( 9).RETADR = 0 ITEM_LIST(10).BUFLEN = 16# ITEM_LIST(10).ITMCOD = UAI$_DEFDEV( ITEM_LIST(10).BUFADR = %LOC(UAF.DEVICE) ITEM_LIST(10).RETADR = 0 ITEM_LIST(11).BUFLEN = 64# ITEM_LIST(11).ITMCOD = UAI$_DEFDIR+ ITEM_LIST(11).BUFADR = %LOC(UAF.DIRECTORY) ITEM_LIST(11).RETADR = 0 ITEM_LIST(12).BUFLEN = 8% ITEM_LIST(12).ITMCOD = UAI$_DEF_PRIV* ITEM_LIST(12).BUFADR = %LOC(UAF.DEF_PRIV) ITEM_LIST(12).RETADR = 0 ITEM_LIST(13).BUFLEN = 4$ ITEM_LIST(13).ITMCOD = UAI$_DFWSCNT) ITEM_LIST(13).BUFADR = %LOC(UAF.DFWSCNT) ITEM_LIST(13).RETADR = 0 ITEM_LIST(14).BUFLEN = 4" ITEM_LIST(14).ITMCOD = UAI$_DIOLM' ITEM_LIST(14).BUFADR = %LOC(UAF.DIOLM) ITEM_LIST(14).RETADR = 0 ITEM_LIST(15).BUFLEN = 4, ITEM_LIST(15).ITMCOD = UAI$_DIALUP_ACCESS_P1 ITEM_LIST(15).BUFADR = %LOC(UAF.DIALUP_ACCESS_P) ITEM_LIST(15).RETADR = 0 ITEM_LIST(16).BUFLEN = 4, ITEM_LIST(16).ITMCOD = UAI$_DIALUP_ACCESS_S1 ITEM_LIST(16).BUFADR = %LOC(UAF.DIALUP_ACCESS_S) ITEM_LIST(16).RETADR = 0 ITEM_LIST(17).BUFLEN = 4" ITEM_LIST(17).ITMCOD = UAI$_ENQLM' ITEM_LIST(17).BUFADR = %LOC(UAF.ENQLM) ITEM_LIST(17).RETADR = 0 ITEM_LIST(18).BUFLEN = 8' ITEM_LIST(18).ITMCOD = UAI$_EXPIRATION. ITEM_LIST(18).BUFADR = %LOC(UAF.Q_EXPIRATION) ITEM_LIST(18).RETADR = 0 ITEM_LIST(19).BUFLEN = 4" ITEM_LIST(19).ITMCOD = UAI$_FILLM' ITEM_LIST(19).BUFADR = %LOC(UAF.FILLM) ITEM_LIST(19).RETADR = 0 ITEM_LIST(20).BUFLEN = 4" ITEM_LIST(20).ITMCOD = UAI$_FLAGS- ITEM_LIST(20).BUFADR = %LOC(UAF.LOGIN_FLAGS) ITEM_LIST(20).RETADR = 0 ITEM_LIST(21).BUFLEN = 4$ ITEM_LIST(21).ITMCOD = UAI$_JTQUOTA) ITEM_LIST(21).BUFADR = %LOC(UAF.JTQUOTA) ITEM_LIST(21).RETADR = 0 ITEM_LIST(22).BUFLEN = 8( ITEM_LIST(22).ITMCOD = UAI$_LASTLOGIN_I/ ITEM_LIST(22).BUFADR = %LOC(UAF.Q_LASTLOGIN_I) ITEM_LIST(22).RETADR = 0 ITEM_LIST(23).BUFLEN = 8( ITEM_LIST(23).ITMCOD = UAI$_LASTLOGIN_N/ ITEM_LIST(23).BUFADR = %LOC(UAF.Q_LASTLOGIN_N) ITEM_LIST(23).RETADR = 0 ITEM_LIST(24).BUFLEN = 256# ITEM_LIST(24).ITMCOD = UAI$_LGICMD* ITEM_LIST(24).BUFADR = %LOC(UAF.COM_FILE) ITEM_LIST(24).RETADR = 0 ITEM_LIST(25).BUFLEN = 4+ ITEM_LIST(25).ITMCOD = UAI$_LOCAL_ACCESS_P0 ITEM_LIST(25).BUFADR = %LOC(UAF.LOCAL_ACCESS_P) ITEM_LIST(25).RETADR = 0 ITEM_LIST(26).BUFLEN = 4+ ITEM_LIST(26).ITMCOD = UAI$_LOCAL_ACCESS_S0 ITEM_LIST(26).BUFADR = %LOC(UAF.LOCAL_ACCESS_S) ITEM_LIST(26).RETADR = 0 ITEM_LIST(27).BUFLEN = 4% ITEM_LIST(27).ITMCOD = UAI$_LOGFAILS* ITEM_LIST(27).BUFADR = %LOC(UAF.LGIFAILS) ITEM_LIST(27).RETADR = 0 ITEM_LIST(28).BUFLEN = 4( ITEM_LIST(28).ITMCOD = UAI$_MAXACCTJOBS- ITEM_LIST(28).BUFADR = %LOC(UAF.MAXACCTJOBS) ITEM_LIST(28).RETADR = 0 ITEM_LIST(29).BUFLEN = 4& ITEM_LIST(29).ITMCOD = UAI$_MAXDETACH+ ITEM_LIST(29).BUFADR = %LOC(UAF.MAXDETACH) ITEM_LIST(29).RETADR = 0 ITEM_LIST(30).BUFLEN = 4$ ITEM_LIST(30).ITMCOD = UAI$_MAXJOBS) ITEM_LIST(30).BUFADR = %LOC(UAF.MAXJOBS) ITEM_LIST(30).RETADR = 0 ITEM_LIST(31).BUFLEN = 4- ITEM_LIST(31).ITMCOD = UAI$_NETWORK_ACCESS_P2 ITEM_LIST(31).BUFADR = %LOC(UAF.NETWORK_ACCESS_P) ITEM_LIST(31).RETADR = 0 ITEM_LIST(32).BUFLEN = 4- ITEM_LIST(32).ITMCOD = UAI$_NETWORK_ACCESS_S2 ITEM_LIST(32).BUFADR = %LOC(UAF.NETWORK_ACCESS_S) ITEM_LIST(32).RETADR = 0 ITEM_LIST(33).BUFLEN = 32" ITEM_LIST(33).ITMCOD = UAI$_OWNER' ITEM_LIST(33).BUFADR = %LOC(UAF.OWNER) ITEM_LIST(33).RETADR = 0 ITEM_LIST(34).BUFLEN = 4# ITEM_LIST(34).ITMCOD = UAI$_PBYTLM( ITEM_LIST(34).BUFADR = %LOC(UAF.PBYTLM) ITEM_LIST(34).RETADR = 0 ITEM_LIST(35).BUFLEN = 4& ITEM_LIST(35).ITMCOD = UAI$_PGFLQUOTA+ ITEM_LIST(35).BUFADR = %LOC(UAF.PGFLQUOTA) ITEM_LIST(35).RETADR = 0 ITEM_LIST(36).BUFLEN = 4# ITEM_LIST(36).ITMCOD = UAI$_PRCCNT( ITEM_LIST(36).BUFADR = %LOC(UAF.PRCCNT) ITEM_LIST(36).RETADR = 0 ITEM_LIST(37).BUFLEN = 4 ITEM_LIST(37).ITMCOD = UAI$_PRI% ITEM_LIST(37).BUFADR = %LOC(UAF.PRI) ITEM_LIST(37).RETADR = 0 ITEM_LIST(38).BUFLEN = 4& ITEM_LIST(38).ITMCOD = UAI$_PRIMEDAYS+ ITEM_LIST(38).BUFADR = %LOC(UAF.PRIMEDAYS) ITEM_LIST(38).RETADR = 0 ITEM_LIST(39).BUFLEN = 8! ITEM_LIST(39).ITMCOD = UAI$_PRIV& ITEM_LIST(39).BUFADR = %LOC(UAF.PRIV) ITEM_LIST(39).RETADR = 0 ITEM_LIST(40).BUFLEN = 8 ITEM_LIST(40).ITMCOD = UAI$_PWD* ITEM_LIST(40).BUFADR = %LOC(UAF.PASSWORD) ITEM_LIST(40).RETADR = 0 ITEM_LIST(41).BUFLEN = 8% ITEM_LIST(41).ITMCOD = UAI$_PWD_DATE, ITEM_LIST(41).BUFADR = %LOC(UAF.Q_PWD_DATE) ITEM_LIST(41).RETADR = 0 ITEM_LIST(42).BUFLEN = 4' ITEM_LIST(42).ITMCOD = UAI$_PWD_LENGTH, ITEM_LIST(42).BUFADR = %LOC(UAF.PWD_LENGTH) ITEM_LIST(42).RETADR = 0 ITEM_LIST(43).BUFLEN = 8) ITEM_LIST(43).ITMCOD = UAI$_PWD_LIFETIME0 ITEM_LIST(43).BUFADR = %LOC(UAF.Q_PWD_LIFETIME) ITEM_LIST(43).RETADR = 0 ITEM_LIST(44).BUFLEN = 4# ITEM_LIST(44).ITMCOD = UAI$_QUEPRI( ITEM_LIST(44).BUFADR = %LOC(UAF.QUEPRI) ITEM_LIST(44).RETADR = 0 ITEM_LIST(45).BUFLEN = 4, ITEM_LIST(45).ITMCOD = UAI$_REMOTE_ACCESS_P1 ITEM_LIST(45).BUFADR = %LOC(UAF.REMOTE_ACCESS_P) ITEM_LIST(45).RETADR = 0 ITEM_LIST(46).BUFLEN = 4, ITEM_LIST(46).ITMCOD = UAI$_REMOTE_ACCESS_S1 ITEM_LIST(46).BUFADR = %LOC(UAF.REMOTE_ACCESS_S) ITEM_LIST(46).RETADR = 0 ITEM_LIST(47).BUFLEN = 4% ITEM_LIST(47).ITMCOD = UAI$_SHRFILLM* ITEM_LIST(47).BUFADR = %LOC(UAF.SHRFILLM) ITEM_LIST(47).RETADR = 0 ITEM_LIST(48).BUFLEN = 4" ITEM_LIST(48).ITMCOD = UAI$_TQCNT' ITEM_LIST(48).BUFADR = %LOC(UAF.TQCNT) ITEM_LIST(48).RETADR = 0 ITEM_LIST(49).BUFLEN = 4 ITEM_LIST(49).ITMCOD = UAI$_UIC% ITEM_LIST(49).BUFADR = %LOC(UAF.UIC) ITEM_LIST(49).RETADR = 0 ITEM_LIST(50).BUFLEN = 12% ITEM_LIST(50).ITMCOD = UAI$_USERNAME* ITEM_LIST(50).BUFADR = %LOC(UAF.USERNAME)* ITEM_LIST(50).RETADR = %LOC(USERNAME_LEN) ITEM_LIST(51).BUFLEN = 4% ITEM_LIST(51).ITMCOD = UAI$_WSEXTENT* ITEM_LIST(51).BUFADR = %LOC(UAF.WSEXTENT) ITEM_LIST(51).RETADR = 0 ITEM_LIST(52).BUFLEN = 4$ ITEM_LIST(52).ITMCOD = UAI$_WSQUOTA) ITEM_LIST(52).BUFADR = %LOC(UAF.WSQUOTA) ITEM_LIST(52).RETADR = 0 ITEM_LIST(53).END_LIST = 0 JPI_LIST( 1).BUFLEN = 8 JPI_LIST( 1).ITMCOD = JPI$_PID JPI_LIST( 1).BUFADR = %LOC(PID) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).BUFLEN = 15" JPI_LIST( 2).ITMCOD = JPI$_PRCNAM# JPI_LIST( 2).BUFADR = %LOC(PRCNAM)' JPI_LIST( 2).RETADR = %LOC(PRCNAM_LEN) JPI_LIST( 3).BUFLEN = 8& JPI_LIST( 3).ITMCOD = JPI$_MASTER_PID' JPI_LIST( 3).BUFADR = %LOC(MASTER_PID) JPI_LIST( 3).RETADR = 0 JPI_LIST( 4).BUFLEN = 55$ JPI_LIST( 4).ITMCOD = JPI$_IMAGNAME% JPI_LIST( 4).BUFADR = %LOC(IMAGNAME)) JPI_LIST( 4).RETADR = %LOC(IMAGNAME_LEN) JPI_LIST( 5).BUFLEN = 8$ JPI_LIST( 5).ITMCOD = JPI$_LOGINTIM( JPI_LIST( 5).BUFADR = %LOC(LOGINTIM(1)) JPI_LIST( 5).RETADR = 0 JPI_LIST( 6).BUFLEN = 4 JPI_LIST( 6).ITMCOD = JPI$_MODE! JPI_LIST( 6).BUFADR = %LOC(MODE) JPI_LIST( 6).RETADR = 0 JPI_LIST( 7).BUFLEN = 4$ JPI_LIST( 7).ITMCOD = JPI$_PAGEFLTS% JPI_LIST( 7).BUFADR = %LOC(PAGEFLTS) JPI_LIST( 7).RETADR = 0 JPI_LIST( 8).BUFLEN = 4! JPI_LIST( 8).ITMCOD = JPI$_STATE" JPI_LIST( 8).BUFADR = %LOC(STATE) JPI_LIST( 8).RETADR = 0 JPI_LIST( 9).BUFLEN = 7$ JPI_LIST( 9).ITMCOD = JPI$_TERMINAL% JPI_LIST( 9).BUFADR = %LOC(TERMINAL)) JPI_LIST( 9).RETADR = %LOC(TERMINAL_LEN) JPI_LIST(10).BUFLEN = 12$ JPI_LIST(10).ITMCOD = JPI$_USERNAME# JPI_LIST(10).BUFADR = %LOC(USRNAM)' JPI_LIST(10).RETADR = %LOC(USRNAM_LEN) JPI_LIST(11).BUFLEN = 4 JPI_LIST(11).ITMCOD = JPI$_PRI% JPI_LIST(11).BUFADR = %LOC(PRIORITY) JPI_LIST(11).RETADR = 0 JPI_LIST(12).BUFLEN = 4" JPI_LIST(12).ITMCOD = JPI$_PPGCNT! JPI_LIST(12).BUFADR = %LOC(SIZE) JPI_LIST(12).RETADR = 0 JPI_LIST(13).BUFLEN = 4" JPI_LIST(13).ITMCOD = JPI$_GPGCNT# JPI_LIST(13).BUFADR = %LOC(GPGCNT) JPI_LIST(13).RETADR = 0 JPI_LIST(14).END_LIST = 0& DO 10 I = 1,31 ! Setup the Compare310 TRANSL_FR(I:I) = CHAR(I) ! String For Matching1 TRANSL_FR(32:32) = CHAR(127) ! and Translation TRANSL_FR(33:33) = CHAR(0) ! TRANSL_TO = CHAR(32) DO 20 I = 1,820 NULLS(I:I) = CHAR(0)C"C O p e n O u t p u t F i l eC30 ISTAT = LIB$GET_LUN(SCREEN) OPEN ( UNIT = SCREEN, 2 RECL = 510, 2 STATUS = 'NEW', 2 FORM = 'FORMATTED', 2 FILE = 'SYS$OUTPUT' )1 ISTAT = LIB$GET_FOREIGN(USERNAME,,USERNAME_LEN,)7 IF ((.NOT. ISTAT) .OR. (USERNAME_LEN .EQ. 0)) GOTO 100" USERNAME(USERNAME_LEN+1:12) = ' ' GOTO 110$100 ISTAT = LIB$GET_INPUT( USERNAME, 2 'Username ', 2 USERNAME_LEN )" IF (USERNAME_LEN .EQ. 0) GOTO 900" USERNAME(USERNAME_LEN+1:12) = ' '9110 ISTAT = STR$TRANSLATE( USERNAME, ! Translate Username$ 2 USERNAME, ! From Inputed String 2 TRANSL_TO, ! Making Spaces 2 TRANSL_FR ) ! From Garbage( STATUS = SYS$GETUAI( , ! Null Argument 2 , ! Null Argument 2 USERNAME, ! Username 2 ITEM_LIST,,, ) ! Item List IF (.NOT. STATUS) THEN PRINT *,'User Not On File' CALL EXIT END IF* STATUS = LIB$SYS_FAO( '[!OB,!OB]',,S_UIC, 2 %VAL(UAF.UIC_GRP), 2 %VAL(UAF.UIC_MEM)) ISTAT = SYS$ASCTIM( , 2 LOGIN_I, 2 %REF(UAF.Q_LASTLOGIN_I), 2 , )( IF ((UAF.Q_LASTLOGIN_I(1) .EQ. 0) .AND.( 2 (UAF.Q_LASTLOGIN_I(2) .EQ. 0)) THEN LOGIN_I = ' ' END IF ISTAT = SYS$ASCTIM( , 2 LOGIN_N, 2 %REF(UAF.Q_LASTLOGIN_N), 2 , )( IF ((UAF.Q_LASTLOGIN_N(1) .EQ. 0) .AND.( 2 (UAF.Q_LASTLOGIN_N(2) .EQ. 0)) THEN LOGIN_N = ' ' END IF5 ISTAT = SYS$ASCTIM(,EXPIRES,%REF(UAF.Q_EXPIRATION),)' IF ((UAF.Q_EXPIRATION(1) .EQ. 0) .AND.' 2 (UAF.Q_EXPIRATION(2) .EQ. 0)) THEN EXPIRES = ' (None)' END IF7 ISTAT = SYS$ASCTIM(,PWDLIFE,%REF(UAF.Q_PWD_LIFETIME),)3 ISTAT = SYS$ASCTIM(,PWDCHNG,%REF(UAF.Q_PWD_DATE),)4 CALL LIB$EMUL(-100000,UAF.CPUTIM,0,%REF(QUAD_TIME))5 ISTAT = SYS$ASCTIM(,CPUTIM,%REF(QUAD_TIME),%VAL(1) )F ISTAT = GET_LFLGS(UAF.LOGIN_FLAGS,L_FLAGS,FLGLEN)! Decode Login Flags9 ISTAT = GET_PRIMEDAYS(UAF.PRIMEDAYS,PRIMEDAYS,SECONDARY)1 ISTAT = GET_PRIVILEGES(UAF.PRIV,PRIVSTR,PRIVLEN) WRITE ( SCREEN, FMT='(A)' ) ' '( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'Username: ', 2 USERNAME, 2 'Owner: ', 2 UAF.OWNER(2:UAF.OWNER_LEN+1)( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'Account: ', 2 UAF.ACCOUNT(1:ACCOUNT_LEN), 2 'UIC: ', 2 S_UIC( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'CLI: ', 2 UAF.CLI(2:UAF.CLI_LEN+1), 2 'Tables: '," 2 UAF.TABLES(2:UAF.TABLES_LEN+1)" WRITE ( SCREEN, FMT='(1X,A,A,A)') 2 'Default: ',# 2 UAF.DEVICE(2:UAF.DEVICE_LEN+1),( 2 UAF.DIRECTORY(2:UAF.DIRECTORY_LEN+1) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'LGICMD: ',& 2 UAF.COM_FILE(2:UAF.COM_FILE_LEN+1) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Login flags: ', 2 L_FLAGS(1:FLGLEN) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Primary days: ', 2 PRIMEDAYS WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Secondary days: ', 2 SECONDARY) WRITE ( SCREEN, FMT='(1X,A,A,T33,A,I2)') 2 'Expiration: ', 2 EXPIRES, 2 'Pwdminimum: ', 2 UAF.PWD_LENGTH WRITE ( SCREEN, FMT='(1X,A,I)')( 2 'Login Failures Since Last Login: ', 2 UAF.LGIFAILS WRITE ( SCREEN, FMT='(1X,A,A)')" 2 'Last Interactive Login ', 2 LOGIN_I WRITE ( SCREEN, FMT='(1X,A,A)')" 2 'Last Non-Interactive Login ', 2 LOGIN_N( WRITE ( SCREEN, FMT='(1X,A,A,T43,A,A)') 2 'Pwdlifetime: ', 2 PWDLIFE, 2 'Pwdchange: ', 2 PWDCHNG3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Maxjobs: ',UAF.MAXJOBS, 2 'Fillm: ',UAF.FILLM, 2 'Bytlm: ',UAF.BYTLM3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)')# 2 'Maxacctjobs:',UAF.MAXACCTJOBS, 2 'Shrfillm: ',UAF.SHRFILLM, 2 'Pbytlm: ',UAF.PBYTLM3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)')! 2 'Maxdetach: ',UAF.MAXDETACH, 2 'Biolm: ',UAF.BIOLM, 2 'Jtquota: ',UAF.JTQUOTA3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Prclm: ',UAF.PRCCNT, 2 'Diolm: ',UAF.DIOLM, 2 'Wsdef: ',UAF.DFWSCNT3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Prio: ',UAF.PRI, 2 'Astlm: ',UAF.ASTLM, 2 'Wsquo: ',UAF.WSQUOTA3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Queprio: ',UAF.QUEPRI, 2 'Tqelm: ',UAF.TQCNT, 2 'Wsextent: ',UAF.WSEXTENT2 WRITE ( SCREEN, FMT='(1X,A,A,T21,A,I6,T41,A,I7)') 2 'CPU: ',CPUTIM, 2 'Enqlm: ',UAF.ENQLM, 2 'Pgflquo: ',UAF.PGFLQUOTA7 WRITE ( SCREEN, FMT='(1X,A)') 'Authorized Privileges:'" I = INDEX(PRIVSTR(1:255),CHAR(9))$ IF (PRIVSTR(1:5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(1:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) J = I + 1& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 1804 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:PRIVLEN)7180 WRITE ( SCREEN, FMT='(1X,A)') 'Default Privileges:'5 ISTAT = GET_PRIVILEGES(UAF.DEF_PRIV,PRIVSTR,PRIVLEN)" I = INDEX(PRIVSTR(1:255),CHAR(9))$ IF (PRIVSTR(1:5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(1:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) J = I + 1& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 7004 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:PRIVLEN)700 CONTEXT = -17 BLANKS = ' ' //. 2 ' ' FIRST_TIME = 1710 DO WHILE (.TRUE.)+ ISTAT = SYS$GETJPIW(,CONTEXT,,JPI_LIST,,,)( IF (ISTAT .EQ. SS$_NOMOREPROC) GOTO 800# IF (USRNAM .NE. USERNAME) GOTO 710 IF (.NOT. FIRST_TIME) GOTO 715 PRINT *,' ' PRINT 791, 2 ' Job Id ', 2 'Term ',% 2 'Proc Name ',0 2 'Program Name ', 2 'State', 2 ' Ph.Mem ', 2 'Pr' FIRST_TIME = 0)715 CALL OTS$CVT_L_TZ(PID,PROCID,%VAL(8))4 CALL OTS$CVT_L_TZ(MASTER_PID,MASTER_PROCID,%VAL(8))& CALL SYS$ASCTIM(,LOGINTIME,LOGINTIM,)( IF (LOGINTIM(1) .EQ. 0) LOGINTIME = ' ' CALL LIB$DATE_TIME(DATETIME)$ IF (MODE .EQ. 0) JOB_TYPE = 'Other'& IF (MODE .EQ. 1) JOB_TYPE = 'Network'$ IF (MODE .EQ. 2) JOB_TYPE = 'Batch'* IF (MODE .EQ. 3) JOB_TYPE = 'Interactive' STATE_STR = ' '% IF (STATE .EQ. %LOC(SCH$C_CEF)) THEN STATE_STR = 'CEF', ELSE IF (STATE .EQ. %LOC(SCH$C_COLPG)) THEN STATE_STR = 'COLPG'* ELSE IF (STATE .EQ. %LOC(SCH$C_COM)) THEN STATE_STR = 'COM'+ ELSE IF (STATE .EQ. %LOC(SCH$C_COMO)) THEN STATE_STR = 'COMO'* ELSE IF (STATE .EQ. %LOC(SCH$C_CUR)) THEN STATE_STR = 'CUR'* ELSE IF (STATE .EQ. %LOC(SCH$C_FPG)) THEN STATE_STR = 'FPG'* ELSE IF (STATE .EQ. %LOC(SCH$C_HIB)) THEN STATE_STR = 'HIB'+ ELSE IF (STATE .EQ. %LOC(SCH$C_HIBO)) THEN STATE_STR = 'HIBO'* ELSE IF (STATE .EQ. %LOC(SCH$C_LEF)) THEN STATE_STR = 'LEF'+ ELSE IF (STATE .EQ. %LOC(SCH$C_LEFO)) THEN STATE_STR = 'LEFO', ELSE IF (STATE .EQ. %LOC(SCH$C_MWAIT)) THEN STATE_STR = 'MWAIT'* ELSE IF (STATE .EQ. %LOC(SCH$C_PFW)) THEN STATE_STR = 'PFW'+ ELSE IF (STATE .EQ. %LOC(SCH$C_SUSP)) THEN STATE_STR = 'SUSP', ELSE IF (STATE .EQ. %LOC(SCH$C_SUSPO)) THEN STATE_STR = 'SUSPO' END IF1 ISTAT = STR$TRANSLATE( USERNAME(1:USERNAME_LEN), 2 USERNAME(1:USERNAME_LEN), 2 TRANSL_TO, TRANSL_FR ). IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)). IMAGNAME = IMAGNAME(1:IMAGNAME_LEN) // BLANKS( PRCNAM = PRCNAM(1:PRCNAM_LEN) // BLANKS0720 STATUS = INDEX(IMAGNAME(1:IMAGNAME_LEN),']') IF (STATUS .GT. 0) THEN, IMAGNAME = IMAGNAME(STATUS+1:55) // BLANKS GOTO 720 END IF, I = INDEX(IMAGNAME,'.') ! Find Extension# IF (I .GT. 1) THEN ! Remove the7 IMAGNAME = IMAGNAME(1:I-1) // BLANKS ! File Extension END IF ! PRINT 790, 2 PROCID, 2 TERMINAL(1:TERMINAL_LEN), 2 PRCNAM, 2 IMAGNAME, 2 STATE_STR, 2 SIZE+GPGCNT, 2 PRIORITY END DO790 FORMAT( A8,TR1,A7,TR1,A15,! 2 TR1,A15,TR1,A5TR1,I10,TR1,I2 )791 FORMAT( A8,TR1,A7,TR1,A15,! 2 TR1,A15,TR1,A5TR1,A10,TR1,A2 )CC O p e n M a i l F i l eC"800 ISTAT = LIB$GET_LUN(MAIL_FILE) OPEN ( UNIT = MAIL_FILE, 1 FILE = 'VMSMAIL',$ 2 DEFAULT FILE = 'SYS$SYSTEM:.DAT', 3 USER OPEN = PRIV_USEROPEN, 4 STATUS = 'OLD', 5 ORGANIZATION = 'INDEXED', 6 ACCESS = 'KEYED', 7 RECORD TYPE = 'VARIABLE', 8 FORM = 'UNFORMATTED', 9 IOSTAT = STATUS, 9 ERR = 900, 9 READ ONLY, SHARED )  READ ( UNIT = MAIL_FILE, 1 KEYEQ = USERNAME, 2 KEYID = 0, 3 IOSTAT = STATUS ) MAIL_REC IF (STATUS .NE. 0) THEN- IF (STATUS .EQ. FOR$IOS_INPSTAREQ) GOTO 810 GOTO 900 END IF 810 IF (MAIL_NEWMES .GT. 0) THEN TEMP = ' '& WRITE (SCREEN,FMT='(1X,A)') 'Mail: ' IF (MAIL_NEWMES .EQ. 1) THEN/ WRITE (SCREEN,FMT='(1X,A)') ' 1 New Message' ELSE IF (MAIL_NEWMES .GT. 1$ 2 .AND. MAIL_NEWMES .LT. 10 ) THEN WRITE (TEMP,FMT='(I1,A)') 2 MAIL_NEWMES,' New Messages'# WRITE (SCREEN,FMT='(1X,A)') TEMP% ELSE IF (MAIL_NEWMES .GE. 10 ) THEN WRITE (TEMP,FMT='(I3,A)') 2 MAIL_NEWMES,' New Messages'# WRITE (SCREEN,FMT='(1X,A)') TEMP END IF ELSE4 WRITE (SCREEN,FMT='(1X,A)') 'No New Mail Messages' END IF2890 CALL PRIV_CLOSE(MAIL_FILE) ! Close Mail FileCC C l o s e F i l eC*900 CLOSE (SCREEN) ! Close Output File998 CALL EXIT ! Quit' GOTO 32767 ! Should Never Get Here 32767 END 9 INTEGER*4 FUNCTION GET_LFLGS(LOGIN_FLAGS,L_FLAGS,LENGTH)CC L o g i n F l a g sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)' CHARACTER*(*) L_FLAGS INTEGER*4 LOGIN_FLAGS INTEGER*2 LENGTH LENGTH = 07 IF (BTEST(LOGIN_FLAGS,UAI$V_DISCTLY) .EQ. .TRUE.) THEN L_FLAGS = 'Disctly ' LENGTH = 8 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_DEFCLI) .EQ. .TRUE.) THEN* L_FLAGS = L_FLAGS(1:LENGTH) // 'Defcli ' LENGTH = LENGTH + 7 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_LOCKPWD) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Lockpwd ' LENGTH = LENGTH + 8 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_CAPTIVE) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Captive ' LENGTH = LENGTH + 8 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_DISACNT) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Disuser ' LENGTH = LENGTH + 8 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_DISWELCOM) .EQ. .TRUE.) THEN. L_FLAGS = L_FLAGS(1:LENGTH) // 'Diswelcome ' LENGTH = LENGTH + 11 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_DISMAIL) .EQ. .TRUE.) THEN. L_FLAGS = L_FLAGS(1:LENGTH) // 'Disnewmail ' LENGTH = LENGTH + 11 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_NOMAIL) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Dismail ' LENGTH = LENGTH + 8 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_GENPWD) .EQ. .TRUE.) THEN* L_FLAGS = L_FLAGS(1:LENGTH) // 'Genpwd ' LENGTH = LENGTH + 7 END IF; IF (BTEST(LOGIN_FLAGS,UAI$V_PWD_EXPIRED) .EQ. .TRUE.) THEN/ L_FLAGS = L_FLAGS(1:LENGTH) // 'Pwd_Expired ' LENGTH = LENGTH + 12 END IF< IF (BTEST(LOGIN_FLAGS,UAI$V_PWD2_EXPIRED) .EQ. .TRUE.) THEN0 L_FLAGS = L_FLAGS(1:LENGTH) // 'Pwd2_Expired ' LENGTH = LENGTH + 13 END IF5 IF (BTEST(LOGIN_FLAGS,UAI$V_AUDIT) .EQ. .TRUE.) THEN) L_FLAGS = L_FLAGS(1:LENGTH) // 'Audit ' LENGTH = LENGTH + 6 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_DISREPORT) .EQ. .TRUE.) THEN- L_FLAGS = L_FLAGS(1:LENGTH) // 'Disreport ' LENGTH = LENGTH + 10 END IF< IF (BTEST(LOGIN_FLAGS,UAI$V_DISRECONNECT) .EQ. .TRUE.) THEN0 L_FLAGS = L_FLAGS(1:LENGTH) // 'Disreconnect ' LENGTH = LENGTH + 13 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_AUTOLOGIN) .EQ. .TRUE.) THEN- L_FLAGS = L_FLAGS(1:LENGTH) // 'Autologin ' LENGTH = LENGTH + 10 END IF32767 GET_LFLGS = SS$_NORMAL RETURN END ; INTEGER*4 FUNCTION GET_PRIMEDAYS(DAYS,PRIMEDAYS,SECONDARY)CC G e t _ P r i m e d a y sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)'# INTEGER*4 DAYS ! Primedays Value0 INTEGER*2 LENGTH ! Length of Primedays String CHARACTER*(*) PRIMEDAYS CHARACTER*(*) SECONDARY STRUCTURE /WORK/ UNION MAP% CHARACTER*27 PRIMEDAYS ! Prime Days BYTE %FILL) CHARACTER*27 SECONDARY ! Secondary Days END MAP MAP CHARACTER*4 PRIME_DAY(7) CHARACTER*4 SCNDY_DAY(7) END MAP END UNION END STRUCTURE RECORD /WORK/ W W.PRIMEDAYS(1:27) = ' ' W.SECONDARY(1:27) = ' '0 IF (BTEST(DAYS,UAI$V_MONDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(1) = 'Mon ' W.SCNDY_DAY(1) = ' ' ELSE W.SCNDY_DAY(1) = 'Mon ' W.PRIME_DAY(1) = ' ' END IF1 IF (BTEST(DAYS,UAI$V_TUESDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(2) = 'Tue ' W.SCNDY_DAY(2) = ' ' ELSE W.SCNDY_DAY(2) = 'Tue ' W.PRIME_DAY(2) = ' ' END IF3 IF (BTEST(DAYS,UAI$V_WEDNESDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(3) = 'Wed ' W.SCNDY_DAY(3) = ' ' ELSE W.SCNDY_DAY(3) = 'Wed ' W.PRIME_DAY(3) = ' ' END IF2 IF (BTEST(DAYS,UAI$V_THURSDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(4) = 'Thu ' W.SCNDY_DAY(4) = ' ' ELSE W.SCNDY_DAY(4) = 'Thu ' W.PRIME_DAY(4) = ' ' END IF0 IF (BTEST(DAYS,UAI$V_FRIDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(5) = 'Fri ' W.SCNDY_DAY(5) = ' ' ELSE W.SCNDY_DAY(5) = 'Fri ' W.PRIME_DAY(5) = ' ' END IF2 IF (BTEST(DAYS,UAI$V_SATURDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(6) = 'Sat ' W.SCNDY_DAY(6) = ' ' ELSE W.SCNDY_DAY(6) = 'Sat ' W.PRIME_DAY(6) = ' ' END IF0 IF (BTEST(DAYS,UAI$V_SUNDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(7) = 'Sun ' W.SCNDY_DAY(7) = ' ' ELSE W.SCNDY_DAY(7) = 'Sun ' W.PRIME_DAY(7) = ' ' END IF PRIMEDAYS = W.PRIMEDAYS SECONDARY = W.SECONDARY 32767 GET_PRIMEDAYS = SS$_NORMAL RETURN END 8 INTEGER*4 FUNCTION GET_PRIVILEGES(PRIVS,PRIVSTR,LENGTH)CC G e t _ P r i v i l e g e sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($PRVDEF)' INCLUDE '($UAIDEF)' INTEGER*2 I INTEGER*2 LENGTH CHARACTER*(*) PRIVSTR INTEGER*4 PRIVS(2) LENGTH = 0 I = 03 IF (BTEST(PRIVS(1),PRV$V_CMKRNL) .EQ. .TRUE.) THEN PRIVSTR = 'CMKRNL ' LENGTH = 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_CMEXEC) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'CMEXEC ' LENGTH = LENGTH + 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSNAM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSNAM ' LENGTH = LENGTH + 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_GRPNAM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'GRPNAM ' LENGTH = LENGTH + 7 END IF5 IF (BTEST(PRIVS(1),PRV$V_ALLSPOOL) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'ALLSPOOL ' LENGTH = LENGTH + 9 END IF I = LENGTH3 IF (BTEST(PRIVS(1),PRV$V_DETACH) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'DETACH ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF5 IF (BTEST(PRIVS(1),PRV$V_DIAGNOSE) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'DIAGNOSE ' LENGTH = LENGTH + 9 I = I + 9 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_LOG_IO) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'LOG_IO ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_GROUP) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'GROUP ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_NOACNT) .EQ. .TRUE.) THEN( PRIVSTR = PRIVSTR(1:LENGTH) // 'ACNT ' LENGTH = LENGTH + 5 I = I + 5 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMCEB) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMCEB ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PSWAPM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PSWAPM ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SETPRI) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SETPRI ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SETPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SETPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_TMPMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'TMPMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_WORLD) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'WORLD ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_MOUNT) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'MOUNT ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF1 IF (BTEST(PRIVS(1),PRV$V_OPER) .EQ. .TRUE.) THEN( PRIVSTR = PRIVSTR(1:LENGTH) // 'OPER ' LENGTH = LENGTH + 5 I = I + 5 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_EXQUOTA) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'EXQUOTA ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_NETMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'NETMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_VOLPRO) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'VOLPRO ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_BUGCHK) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'BUGCHK ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMGBL) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMGBL ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSGBL) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSGBL ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PFNMAP) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PFNMAP ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_SHMEM) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'SHMEM ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_BYPASS) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'BYPASS ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSLCK) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSLCK ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_SHARE) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'SHARE ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_UPGRADE) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'UPGRADE ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF6 IF (BTEST(PRIVS(1),PRV$V_DOWNGRADE) .EQ. .TRUE.) THEN- PRIVSTR = PRIVSTR(1:LENGTH) // 'DOWNGRADE ' LENGTH = LENGTH + 10 I = I + 10 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_GRPPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'GRPPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_READALL) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'READALL ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF5 IF (BTEST(PRIVS(1),PRV$V_SECURITY) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'SECURITY ' LENGTH = LENGTH + 9 I = I + 9 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF!32767 GET_PRIVILEGES = SS$_NORMAL RETURN ENDww`ťC$C F O R $ E R R O R _ M E S S A G EC2 INTEGER*4 FUNCTION FO*zƥ STOCKTON FOR$ERROR_MESSAGE*G쥐 STOCKTON FOR$ERROR_MESSAGE`Rr縷 STOCKTON ERRORV* STOCKTON SYSTAT@* STOCKTON FINGER F쥐C1$C F O R $ E R R O R _ M E S S A G EC22 INTEGER*4 FUNCTION FOR$ERROR_MESSAGE(IER,MESSAGE)C)=C To create this function, I did a FORTRAN/LIST/SHOW=INCLUDE.;C Then I edited the listing. It has the Condition Symbols,R<C and the definitions of what each means. If FORIOSDEF ever5C changes, some of these values might have to change. C$ INCLUDE '($FORIOSDEF)' INTEGER*4 FLAGS /1/N INTEGER*4 IER CHARACTER*(*) MESSAGE INTEGER*4 MSGLENO# BYTE OUT_ARR(0:3) ! 0 - Reserved  ! 1 - Count of FAO args ! 2 - User Value ! 3 - Reserved INTEGER*4 STATUSS MESSAGE = ' ' CALL ERRSNS(,,,,STATUS)9 CALL LIB$SYS_GETMSG(STATUS,MSGLEN,MESSAGE,FLAGS,OUT_ARR)G+ MESSAGE = MESSAGE(1:INDEX(MESSAGE,'!/')-1)I# IF (MESSAGE(1:2) .NE. ' ') RETURNE% IF (IER .EQ. FOR$IOS_FILNOTFOU) THEN! MESSAGE = 'File Doesn''t Exist'O RETURN END IFE% IF (IER .EQ. FOR$IOS_NOTFORSPE) THEN'* MESSAGE = 'not a FORTRAN specific error' RETURN! ! ERRSNS only - IOSTAT can not ! return this value.I END IFO% IF (IER .EQ. FOR$IOS_SYNERRNAM) THENd, MESSAGE = 'syntax error in NAMELIST input' RETURN END IFO% IF (IER .EQ. FOR$IOS_TOOMANVAL) THEN 3 MESSAGE = 'too many values for NAMELIST variable' RETURN END IF % IF (IER .EQ. FOR$IOS_INVREFVAR) THENI+ MESSAGE = 'invalid reference to variable'  RETURN END IFD" IF (IER .EQ. FOR$IOS_REWERR) THEN MESSAGE = 'REWIND error' RETURN END IF % IF (IER .EQ. FOR$IOS_DUPFILSPE) THENe+ MESSAGE = 'duplicate file specifications'$ RETURN END IF % IF (IER .EQ. FOR$IOS_INPRECTOO) THEND$ MESSAGE = 'input record too long ' RETURN END IF " IF (IER .EQ. FOR$IOS_BACERR) THEN MESSAGE = 'BACKSPACE error'I RETURN END IF % IF (IER .EQ. FOR$IOS_ENDDURREA) THEN % MESSAGE = 'end-of-file during read'E RETURN END IF " ! (ERRSNS only - IOSTAT returns% ! a negative value for this error)% IF (IER .EQ. FOR$IOS_RECNUMOUT) THENr) MESSAGE = 'record number outside range'O RETURN END IF% IF (IER .EQ. FOR$IOS_OPEDEFREQ) THEN* MESSAGE = 'OPEN or DEFINE FILE required' RETURN END IFu% IF (IER .EQ. FOR$IOS_TOOMANREC) THEN/ MESSAGE = 'too many records in I/O statement'  RETURN END IF " IF (IER .EQ. FOR$IOS_CLOERR) THEN MESSAGE = 'CLOSE error'C RETURN END IFG% IF (IER .EQ. FOR$IOS_FILNOTFOU) THENo MESSAGE = 'file not found 'I RETURN END IFR" IF (IER .EQ. FOR$IOS_OPEFAI) THEN MESSAGE = 'open failure' RETURN END IFR% IF (IER .EQ. FOR$IOS_MIXFILACC) THENG% MESSAGE = 'mixed file access modes'D RETURN END IF % IF (IER .EQ. FOR$IOS_INVLOGUNI) THENe) MESSAGE = 'invalid logical unit number'  RETURN END IFE% IF (IER .EQ. FOR$IOS_ENDFILERR) THENI MESSAGE = 'ENDFILE error'D RETURN END IF % IF (IER .EQ. FOR$IOS_UNIALROPE) THENi MESSAGE = 'unit already open'E RETURN END IF % IF (IER .EQ. FOR$IOS_SEGRECFOR) THENE+ MESSAGE = 'segmented record format error' RETURN END IFO% IF (IER .EQ. FOR$IOS_ATTACCNON) THENa3 MESSAGE = 'attempt to access non-existent record'R RETURN END IFC% IF (IER .EQ. FOR$IOS_INCRECLEN) THENe( MESSAGE = 'inconsistent record length' RETURN END IFR% IF (IER .EQ. FOR$IOS_ERRDURWRI) THENr MESSAGE = 'error during write' RETURN END IF.% IF (IER .EQ. FOR$IOS_ERRDURREA) THEN  MESSAGE = 'error during read't RETURN END IFD& IF (IER .EQ. FOR$IOS_RECIO_OPE) THEN % MESSAGE = 'recursive I/O operation'l RETURN END IFI% IF (IER .EQ. FOR$IOS_INSVIRMEM) THENE) MESSAGE = 'insufficient virtual memory'N RETURN END IF% IF (IER .EQ. FOR$IOS_NO_SUCDEV) THENO MESSAGE = 'no such device' RETURN END IFi% IF (IER .EQ. FOR$IOS_FILNAMSPE) THENR+ MESSAGE = 'file name specification error'i RETURN END IFn% IF (IER .EQ. FOR$IOS_INCRECTYP) THEN& MESSAGE = 'inconsistent record type' RETURN END IFn% IF (IER .EQ. FOR$IOS_KEYVALERR) THENE3 MESSAGE = 'keyword value error in OPEN statement'S RETURN END IFc% IF (IER .EQ. FOR$IOS_INCOPECLO) THENI0 MESSAGE = 'inconsistent OPEN/CLOSE parameters' RETURN END IF % IF (IER .EQ. FOR$IOS_WRIREAFIL) THEN_$ MESSAGE = 'write to READONLY file' RETURN END IF% IF (IER .EQ. FOR$IOS_INVARGFOR) THEN : MESSAGE = 'invalid argument to FORTRAN Run-Time Library' RETURN END IFE% IF (IER .EQ. FOR$IOS_INVKEYSPE) THEN ' MESSAGE = 'invalid key specification'I RETURN END IFG% IF (IER .EQ. FOR$IOS_INCKEYCHG) THENI6 MESSAGE = 'inconsistent key change or duplicate key' RETURN END IF % IF (IER .EQ. FOR$IOS_INCFILORG) THENQ, MESSAGE = 'inconsistent file organization' RETURN END IF % IF (IER .EQ. FOR$IOS_SPERECLOC) THEN_% MESSAGE = 'specified record locked'a RETURN END IFh% IF (IER .EQ. FOR$IOS_NO_CURREC) THENO MESSAGE = 'no current record'  RETURN END IFf% IF (IER .EQ. FOR$IOS_REWRITERR) THENQ MESSAGE = 'REWRITE error'  RETURN END IFo" IF (IER .EQ. FOR$IOS_DELERR) THEN MESSAGE = 'DELETE error' RETURN END IFS" IF (IER .EQ. FOR$IOS_UNLERR) THEN MESSAGE = 'UNLOCK error' RETURN END IF)" IF (IER .EQ. FOR$IOS_FINERR) THEN MESSAGE = 'FIND error' RETURN END IF % IF (IER .EQ. FOR$IOS_LISIO_SYN) THENE, MESSAGE = 'list-directed I/O syntax error' RETURN END IFI% IF (IER .EQ. FOR$IOS_INFFORLOO) THENE" MESSAGE = 'infinite format loop' RETURN END IF'% IF (IER .EQ. FOR$IOS_FORVARMIS) THEN + MESSAGE = 'format/variable-type mismatch'! RETURN END IFO% IF (IER .EQ. FOR$IOS_SYNERRFOR) THENH$ MESSAGE = 'syntax error in format' RETURN END IFI% IF (IER .EQ. FOR$IOS_OUTCONERR) THENS% MESSAGE = 'output conversion error'N RETURN END IFR% IF (IER .EQ. FOR$IOS_INPCONERR) THEN $ MESSAGE = 'input conversion error' RETURN END IFO% IF (IER .EQ. FOR$IOS_OUTSTAOVE) THENn/ MESSAGE = 'output statement overflows record'I RETURN END IF_% IF (IER .EQ. FOR$IOS_INPSTAREQ) THENe4 MESSAGE = 'input statement requires too much data' RETURN END IF % IF (IER .EQ. FOR$IOS_VFEVALERR) THENE4 MESSAGE = 'variable format expression value error' RETURN END IF< ! Error numbers 70-77 refer to hardware exceptions and are ! not returned by IOSTAT.o" IF (IER .EQ. FOR$IOS_INTOVF) THEN MESSAGE = 'integer overflow' RETURN END IF " IF (IER .EQ. FOR$IOS_INTDIV) THEN$ MESSAGE = 'integer divide by zero' RETURN END IFP" IF (IER .EQ. FOR$IOS_FLTOVF) THEN MESSAGE = 'floating overflow'I RETURN END IF_" IF (IER .EQ. FOR$IOS_FLTDIV) THEN- MESSAGE = 'floating/decimal divide by zero'D RETURN END IF " IF (IER .EQ. FOR$IOS_FLTUND) THEN MESSAGE = 'floating underflow' RETURN END IF" IF (IER .EQ. FOR$IOS_SUBRNG) THEN$ MESSAGE = 'subscript out of range' RETURN END IF A ! Error numbers 80-89 refer to Math Library reported errors and  ! are not returned by IOSTAT.a% IF (IER .EQ. FOR$IOS_WRONUMARG) THEN ' MESSAGE = 'wrong number of arguments'o RETURN END IFm% IF (IER .EQ. FOR$IOS_INVARGMAT) THENI. MESSAGE = 'invalidDIM) THEN. MESSAGE = 'adjustable array dimension error' RETURN END IF! STATUS = 2 ! Didn't Do the Job FOR$ERROR_MESSAGE = STATUS RETURN ENDwwaƏ PROGRAM Fiscal_CalendarsCC NAMEC Fiscal_CalendarsCC DESCRIPTION3C Generate a fiscal calendar for the year(s) given.C C RETURNS C SS$_NORMALC C REFERENCES C (FiscalDef) C (FiscalNam) C Str$Trim C Sys$Asctim C (TimDef)CC NOTES0C Only years between 1860 and 9999 are accepted.CC Define types. IMPLICIT NONE. INCLUDE 'LES:ESI$FORTRAN$STARLET (FISCALDEF)'. INCLUDE 'LES:ESI$FORTRAN$STARLET (FISCALNAM)'+ INCLUDE 'LES:ESI$FORTRAN$STARLET (TIMDEF)'C Define routines. EXTERNAL Lib$Get_Input, 1 Str$Trim, 1 Sys$Asctim INTEGER Lib$Get_Input, 1 Str$Trim, 1 Sys$AsctimC Define global variables.C Define local variables. INTEGER MAX_YEAR INTEGER MIN_YEAR PARAMETER ( MIN_YEAR = 1860, 1 MAX_YEAR = 9999 ) LOGICAL Filing INTEGER From_Year INTEGER I INTEGER Length CHARACTER*132 Line INTEGER Space1 INTEGER Space2 CHARACTER*80 String RECORD /TIM$R_TIME/ Time INTEGER To_Year INTEGER Weeks INTEGER Year(C See if the output should go to a file. 100 IF (IAND (Lib$Get_Input: 1 (String, 'Output a fiscal calendar to a file? ', 1 Length), 1) .EQ. 0) 1 CALL EXIT (1)8 Filing = String (:1) .EQ. 'Y' .OR. String (:1) .EQ. 'y' IF (.NOT. Filing)2 1 OPEN (UNIT = 1, FILE = 'TT:', STATUS = 'NEW', 1 CARRIAGECONTROL = 'LIST') 110 IF (Filing) THEN*C Get the filename and range of years. IF (IAND (Lib$Get_Input/ 1 (String, 'Output file and FY to FY: ', 1 Length), 1) .EQ. 0) 1 GOTO 100! Space1 = INDEX (String, ' ')6 Space2 = INDEX (String (Space1+1:), ' ') + Space1A READ (String (Space1:Space2), '(BN,I10)', ERR=192) From_Year9 READ (String (Space2:), '(BN,I10)', ERR=192) To_Year$ IF (To_Year .LT. From_Year .OR.< 1 From_Year .LT. MIN_YEAR .OR. MAX_YEAR .LT. From_Year .OR.4 1 To_Year .LT. MIN_YEAR .OR. MAX_YEAR .LT. To_Year) 1 GOTO 192= OPEN (UNIT = 1, FILE = String (:Space1), STATUS = 'NEW',' 1 CARRIAGECONTROL = 'LIST', ERR=190) ELSEC Get the fiscal year. IF (IAND (Lib$Get_Input6 1 (String, 'Fiscal Year: ', Length), 1) .EQ. 0) 1 GOTO 1001 READ (String, '(BN,I10)', ERR=195) From_Year> IF (From_Year .LT. MIN_YEAR .OR. MAX_YEAR .LT. From_Year) 1 GOTO 195 To_Year = From_Year ENDIF GOTO 200C Input error messages.C 190 WRITE (6,*) 'Cannot create calendar file ', String (:Space1-1) GOTO 110 192 WRITE (6, '(X,A,I4,A,I4)') 1 'The years must be between ', 1 MIN_YEAR, ' and ', MAX_YEAR GOTO 110 195 WRITE (6, '(X,A,I4,A,I4)') 1 'The year must be between ', 1 MIN_YEAR, ' and ', MAX_YEAR GOTO 110(C Loop through each of the fiscal years.& 200 DO 7123 Year = From_Year, To_Year WRITE (1,*) IF (Filing)4 1 WRITE (1, '(/,/,/,/,/,T30,A,/,/,T30,A,I4,/,/,/)')! 1 'ELECTROSPACE SYSTEMS, INC.',! 1 'Fiscal Calendar - FY ', Year-C Loop through each of the fiscal months. Line = ' '/ DO 7112 I = FISCAL$C_APRIL, FISCAL$C_MARCH9C Write the name of the month, its starting date, ending-C date and the number of weeks in the month. WRITE (Line (12:), '(A,$)')3 1 TIM$C_MONTH_NAME (FISCAL$TO_STANDARD_MONTH (I)): CALL Fiscal$Start_of_Fiscal_Month (I, Year, Time, Weeks)1 CALL Sys$Asctim (Length, String, Time, %VAL(0))5 WRITE (Line (28:), '(A,'' to '',$)') String (:11)1 CALL Fiscal$End_of_Fiscal_Month (I, Year, Time)1 CALL Sys$Asctim (Length, String, Time, %VAL(0))- WRITE (Line (45:), '(A,10X,I1,'' weeks'')') 1 String (:11), Weeks$ CALL Str$Trim (Line, Line, Length)! WRITE (1, '(A)') Line (:Length) C Double space the file output. IF (Filing) 1 WRITE (1,*) 7112 CONTINUE@C Write a page separation between each calendar in the file.- IF (Filing .AND. Year .LT. To_Year) THEN WRITE (1, '(A)') CHAR (12) ELSE WRITE (1,*) ENDIF 7123 CONTINUE?C Continue with interactive input, or close the file and see if,C the user wants to generate more calendars. IF (.NOT. Filing) THEN GOTO 110 ELSE CLOSE (1)# WRITE (6,*) 'Calendar written' GOTO 100 ENDIF END ! Fiscal_CalendarswwAƏ** G B L _ R E C E I V E R*CC Needs Options File on Link.C PSECT_ATTR = GBL, PAGEC INCLUDE '($SECDEF)' INTEGER*4 SEC_MASK CHARACTER*12 DEVICE CHARACTER*12 PROCESS CHARACTER*6 TERMINAL INTEGER*4 PASS_ADDR(2) INTEGER*4 RET_ADDR(2) INTEGER*4 STATUS INTEGER*4 REQUEST_FLAG /70/ INTEGER*4 INFO_FLAG /71/ INTEGER*4 SYS$ASCEFC INTEGER*4 SYS$SETEF INTEGER*4 SYS$WAITFR INTEGER*4 SYS$MGBLSC COMMON /UFO/ SEC_CHAN COMMON /GBL/ DEVICE, 2 PROCESS, 2 TERMINAL4 STATUS = SYS$ASCEFC(%VAL(REQUEST_FLAG),'CLUSTER',,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))( STATUS = SYS$WAITFR(%VAL(REQUEST_FLAG))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PASS_ADDR(1) = %LOC(DEVICE) PASS_ADDR(2) = %LOC(TERMINAL) SEC_MASK = SEC$M_WRT6 STATUS = SYS$MGBLSC( PASS_ADDR, ! Address of Section 2 RET_ADDR, ! Address Mapped 3 ,$ 4 %VAL(SEC_MASK), ! Section Mask$ 5 'GLOBAL_SEC',,) ! Section Name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) DEVICE = '12345' TERMINAL = 'TEST' PROCESS = 'TESTER'$ STATUS = SYS$SETEF(%VAL(INFO_FLAG))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ENDww~Ə** G B L _ S E N D E R*CC Needs Options File on Link.C PSECT_ATTR = GBL, PAGEC INCLUDE '($SECDEF)' INTEGER*4 SEC_MASK INTEGER*2 INFO_LUN INTEGER*2 SEC_CHAN INTEGER*2 SEC_LEN CHARACTER*12 DEVICE CHARACTER*12 PROCESS CHARACTER*6 TERMINAL INTEGER*4 PASS_ADDR(2) INTEGER*4 RET_ADDR(2) INTEGER*4 STATUS INTEGER*4 REQUEST_FLAG /70/ INTEGER*4 INFO_FLAG /71/ INTEGER*4 UFO_CREATE EXTERNAL UFO_CREATE INTEGER*4 LIB$GET_LUN INTEGER*4 SYS$ASCEFC INTEGER*4 SYS$SETEF INTEGER*4 SYS$WAITFR INTEGER*4 SYS$CREPRC INTEGER*4 SYS$CRMPSC COMMON /UFO/ SEC_CHAN COMMON /GBL/ DEVICE, 2 PROCESS, 2 TERMINAL STATUS = LIB$GET_LUN(INFO_LUN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))4 SEC_MASK = SEC$M_WRT .OR. SEC$M_DZRO .OR. SEC$M_GBL> ! last addr - first addr + length of last element + 511 / 512< SEC_LEN = ((%LOC(TERMINAL) - %LOC(DEVICE) + 6 + 511) / 512) OPEN ( UNIT = INFO_LUN, 2 FILE = 'INFO.TMP', 3 STATUS = 'NEW', 4 INITIALSIZE = SEC_LEN, 5 USEROPEN = UFO_CREATE ) CLOSE (INFO_LUN) PASS_ADDR(1) = %LOC(DEVICE) PASS_ADDR(2) = %LOC(TERMINAL) STATUS = SYS$CRMPSC( PASS_ADDR, 2 RET_ADDR, 2 , 2 %VAL(SEC_MASK), 2 'GLOBAL_SEC', 2 ,, 2 %VAL(SEC_CHAN),,,,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = SYS$CREPRC( ," 2 'GBL_RECEIVER', ! Image Name 3 ,,,,,$ 4 'GBL_RECIEVER', ! Process Name 5 %VAL(4),,,) ! Priority0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) DEVICE = 'TEST' PROCESS = 'PROCESS' TERMINAL = 'CRT' PRINT *,'DEVICE=',DEVICE PRINT *,'PROCESS=',PROCESS PRINT *,'TERMINAL=',TERMINAL PRINT *,' '4 STATUS = SYS$ASCEFC(%VAL(REQUEST_FLAG),'CLUSTER',,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))' STATUS = SYS$SETEF(%VAL(REQUEST_FLAG))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))% STATUS = SYS$WAITFR(%VAL(INFO_FLAG))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,'DEVICE=',DEVICE PRINT *,'PROCESS=',PROCESS PRINT *,'TERMINAL=',TERMINAL ENDwwk/ ȏ SUBROUTINE GETPID(PROCID) INCLUDE '($JPIDEF)' STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 CODE INTEGER*4 BUFADR INTEGER*4 RETLEN END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE RECORD /ITMLST/ JPI_LIST(2) CHARACTER*8 PROCID CHARACTER*8 PIDTXT INTEGER*4 PID INTEGER*4 PID_LEN INTEGER*4 STATUS, SYS$GETJPI JPI_LIST(1).BUFLEN = 8 JPI_LIST(1).CODE = JPI$_PID JPI_LIST(1).BUFADR = %LOC(PID)# JPI_LIST(1).RETLEN = %LOC(PID_LEN) JPI_LIST(2).END_LIST = 0% STATUS = SYS$GETJPI (,,,JPI_LIST,,,)1 IF (.NOT. STATUS) CALL LIB$SIGNAL (%VAL(STATUS))& CALL OTS$CVT_L_TZ(PID,PIDTXT,%VAL(8))  PROCID(1:8) = PIDTXT(1:8) ENDwwN- INTEGER*4 FUNCTION GET_CHANNEL(FILENAME,LUN) IMPLICIT NONE INTEGER*2 CHAN CHARACTER*(*) FILENAME INTEGER*2 LUN INTEGER*4 STATUS INTEGER*4 LIB$GET_LUN INTEGER*4 UFO_OPEN EXTERNAL UFO_OPEN COMMON /CHANNEL/ CHAN STATUS = LIB$GET_LUN(LUN) OPEN ( UNIT = LUN, 1 NAME = FILENAME, 2 STATUS = 'OLD', 3 USEROPEN = UFO_OPEN, 4 ERR = 9000 ) GOTO 327679000 CHAN = -132767 GET_CHANNEL = CHAN RETURN ENDww`ȏ4 INTEGER*4 FUNCTION GET_DISK_QUOTA(U_GRP,U_MEM,DISK, 2 LEN,USED,PERM,OVRD)** G E T _ D I S K _ Q U O T A* IMPLICIT INTEGER*4 (A-Z) STRUCTURE /FILE_INFO_BLOCK/ UNION MAP BYTE FIB$L_ACCTL(3) BYTE FIB$B_WSIZE BYTE FIB$W_FID(6) BYTE FIB$W_DID(6) INTEGER*4 FIB$L_WCC INTEGER*2 FIB$W_NMCTL INTEGER*2 FIB$W_CNTRLFUNC INTEGER*4 FIB$L_CNTRLVAL INTEGER*4 FIB$L_EXVBN BYTE FIB$B_ALOPTS BYTE FIB$B_ALALIGN BYTE FIB$W_ALLOC(10) INTEGER*2 FIB$W_VERLIMIT INTEGER*2 RESERVED END MAP MAP CHARACTER*48 CHAR_FIB END MAP END UNION END STRUCTURE RECORD /FILE_INFO_BLOCK/ FIB STRUCTURE /QUOTA_BLOCK_DEF/ UNION MAP INTEGER*4 FLAGS INTEGER*2 UIC_MEMBER INTEGER*2 UIC_GROUP INTEGER*4 USAGE INTEGER*4 PERMQUOTA INTEGER*4 OVERDRAFT INTEGER*4 UNUSED(3) END MAP MAP CHARACTER*32 CHAR_QB END MAP END UNION END STRUCTURE% RECORD /QUOTA_BLOCK_DEF/ QUOTA_BLOCK CHARACTER*40 DISK INTEGER*2 CHAN INTEGER*2 IOSB(4) INTEGER*2 U_GRP INTEGER*2 U_MEM INTEGER*4 USED INTEGER*4 PERM INTEGER*4 OVRD INTEGER*4 STATUS INTEGER*4 RET_STATUS INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$DASSGN INTEGER*4 SYS$FAO INTEGER*4 SYS$QIOW IF (LEN .EQ. 0) THEN GET_DISK_QUOTA = 2 RETURN END IF. IF ((U_GRP .EQ. 0) .AND. (U_MEM .EQ. 0)) THEN GET_DISK_QUOTA = 2 RETURN END IF RET_STATUS = SS$_NORMAL( STATUS = SYS$ASSIGN(DISK(1:LEN),CHAN,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))7D FIB.FIB$L_CNTRLVAL = FIB$M_ALL_MEM .OR. FIB$M_ALL_GRP# FIB.FIB$L_CNTRLVAL = FIB$M_ALL_MEM& FIB.FIB$W_CNTRLFUNC = FIB$C_EXA_QUOTA!300 QUOTA_BLOCK.UIC_GROUP = U_GRP STATUS = SYS$QIOW(, 2 %VAL(CHAN), 2 %VAL(IO$_ACPCONTROL), 2 IOSB,,, 2 FIB.CHAR_FIB, 2 QUOTA_BLOCK.CHAR_QB, 2 LEN, 2 QUOTA_BLOCK.CHAR_QB,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))+ IF (IOSB(1) .EQ. SS$_NODISKQUOTA) GOTO 400$ IF (IOSB(1) .EQ. SS$_QFNOTACT) THEN! STATUS = SYS$DASSGN(%VAL(CHAN))1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) GET_DISK_QUOTA = 0 RETURN END IF0 IF (.NOT. IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))). IF ((QUOTA_BLOCK.UIC_GROUP .EQ. U_GRP) .AND.. 2 (QUOTA_BLOCK.UIC_MEMBER .EQ. U_MEM)) THEN USED = QUOTA_BLOCK.USAGE PERM = QUOTA_BLOCK.PERMQUOTA OVRD = QUOTA_BLOCK.OVERDRAFT END IF GOTO 300#400 STATUS = SYS$DASSGN(%VAL(CHAN))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) GET_DISK_QUOTA = RET_STATUS RETURN ENDww͸oC INTEGER*4 FUNCTION GET_NEW_PASSWORD(PASS,PASS_LEN,NPASS,NPASS_LEN) CHARACTER*(*) PASS CHARACTER*(*) NPASS CHARACTER*31 VERIFICATION CHARACTER*1 TR_FROM CHARACTER*1 TR_TO INTEGER*4 PASS_LEN INTEGER*4 NPASS_LEN INTEGER*4 VERI_LEN INTEGER*4 STATUS INTEGER*4 WAIT /30/ INTEGER*4 READ_NOECHO INTEGER*4 STR$TRANSLATE INTEGER*4 STR$UPCASE TR_FROM = CHAR(0) TR_TO = ' '-10 STATUS = READ_NOECHO( 'New Password: ',14, 2 NPASS,NPASS_LEN,WAIT) IF (.NOT. STATUS) GOTO 327673 STATUS = STR$TRANSLATE( NPASS,NPASS,TR_TO,TR_FROM)! STATUS = STR$UPCASE(NPASS,NPASS)7 NPASS(1:NPASS_LEN+4) = PASS(1:4) // NPASS(1:NPASS_LEN) NPASS_LEN = NPASS_LEN + 43 IF (NPASS(1:NPASS_LEN) .EQ. PASS(1:PASS_LEN)) THEN STATUS = 0 GOTO 32767 END IF PRINT *,' '+ STATUS = READ_NOECHO( 'Verification: ',14, 2 VERIFICATION,VERI_LEN,WAIT) IF (.NOT. STATUS) GOTO 32767A STATUS = STR$TRANSLATE( VERIFICATION,VERIFICATION,TR_TO,TR_FROM)/ STATUS = STR$UPCASE(VERIFICATION,VERIFICATION)C VERIFICATION(1:VERI_LEN+4) = PASS(1:4) // VERIFICATION(1:VERI_LEN) VERI_LEN = VERI_LEN + 4A IF (NPASS(1:NPASS_LEN) .NE. VERIFICATION(1:VERI_LEN)) STATUS = 032767 GET_NEW_PASSWORD = STATUS RETURN ENDww`Wo* INTEGER*4 FUNCTION GET_PRIV(EMP_NO,PRIVS) IMPLICIT INTEGER*4 (A-Z) INCLUDE '($SSDEF)' INCLUDE '($LNMDEF)' INTEGER*4 OTS$CVT_L_TB2 INTEGER*4 STR$TRANSLATE ! Translate Str Routine INTEGER*4 SYS$TRNLNM INTEGER*4 NUMBER- CHARACTER*1 TRANSL_FR ! Translate From Str+ CHARACTER*1 TRANSL_TO ! Translate To Str CHARACTER*1 BIT CHARACTER*4 EMP_NO CHARACTER*64 PRIVS CHARACTER*100 BINARY_STRING CHARACTER*80 RET_STRING% CHARACTER*11 TABNAM /'LNM$PROCESS'/& CHARACTER*8 LOGICAL_NAME /'SYS$PRIV'/ CHARACTER*255 RET_TABLE* INTEGER*2 TRNLST(20) /4, LNM$_STRING,4*0, 2 4, LNM$_LENGTH,4*0, 2 4, LNM$_TABLE, 6*0/ INTEGER*4 STATUS INTEGER*4 RET_LEN STRUCTURE /PRV/ UNION MAP CHARACTER*5 EMP_NUMBER INTEGER*4 PRIV(2) END MAP MAP CHARACTER*24 STRING END MAP END UNION END STRUCTURE RECORD /PRV/ PRIVILEGES TRNLST(1) = 255 TRNLST(3) = %LOC(RET_STRING) TRNLST(7) = 4 TRNLST(9) = %LOC(RET_LEN) TRNLST(13) = 255 TRNLST(15) = %LOC(RET_TABLE)2 STATUS = SYS$TRNLNM(,TABNAM,LOGICAL_NAME,,TRNLST) IF (STATUS .EQ. SS$_NOLOGNAM) 2 THEN GOTO 32767 END IF0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))* PRIVILEGES.STRING = RET_STRING(1:RET_LEN) EMP_NO = PRIVILEGES.EMP_NUMBER( STATUS = OTS$CVT_L_TB( PRIVILEGES.PRIV, 2 %DESCR(BINARY_STRING), 2 %VAL(100), 2 %VAL(8) ) PRIVS = BINARY_STRING(37:100)32767 GET_PRIV = STATUS RETURN ENDwwbƏC HELPOUT.FORC0C This program satisfies an initial help request0C and enters interactive HELP mode. The libraryC used is SYS$HELP:HELPLIB.HLB.C IMPLICIT INTEGER*4 (A - Z) CHARACTER*32 KEY& EXTERNAL LIB$PUT_OUTPUT,LIB$GET_INPUTCC Request a HELP key WRITE (6,2000)92000 FORMAT(1X,'What Topic would you like HELP with? ',$) READ (5,1000) KEY1000 FORMAT (A32)C C Locate and print the help text. STATUS = LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,KEY,& 1 'HELPLIB',,LIB$GET_INPUT)/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ENDww ƏCC LABSOL1.FORC0C This program satisfies an initial help request0C and enters interactive HELP mode. The library C used is specified by the user.C IMPLICIT INTEGER*4 (A-Z) CHARACTER KEY_WORD*32& EXTERNAL LIB$PUT_OUTPUT,LIB$GET_INPUTCC Request a HELP key_word TYPE 1000100 FORMAT ('$Topic you would like help with? ') ACCEPT 110, KEY_WORD110 FORMAT (A32)C C Locate and print the help text3 STATUS = LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,KEY_WORD,# 1 'DISK$COURSE:[USER]MYLIB'( 1 ,,LIB$GET_INPUT)/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))5 TYPE *, 'Returned to main program on exit from HELP' ENDwwȏ** H E X T O D E C*10 CHARACTER*64 HEX_STR INTEGER*4 DEC_VAL INTEGER*4 DEC_VAL_LEN INTEGER*4 ISTAT INTEGER*4 OTS$CVT_TZ_L INTEGER*4 LIB$GET_INPUT6 ISTAT = LIB$GET_INPUT(HEX_STR,'Hex Value ',INPUT_LEN)>20 ISTAT = OTS$CVT_TZ_L(HEX_STR(1:INPUT_LEN),DEC_VAL,%VAL(4),) PRINT *,DEC_VAL 32767 ENDww@j$Ə PROGRAM IDLEC C I D L ECC Written by Les StocktonC July 21, 1986CC IMPLICIT INTEGER*4 (A-Z)C& CHARACTER ASCTIM*13 /'0 00:05:00.00'/C INTEGER*4 BINTIM(2)# INTEGER*4 RANGE(2) /0,'7FFFFFFF'X/ INTEGER*4 ISTAT INTEGER*4 LIB$SPAWN INTEGER*4 SYS$SCHDWK INTEGER*4 SYS$SNDOPR INTEGER*4 SYS$PURGWS INTEGER*4 SYS$BINTIM INTEGER*4 SYS$HIBER INTEGER*4 SYS$DELPRCC I = 0 DO WHILE (.TRUE.) I = I + 1 PRINT *,'.'" ISTAT = SYS$BINTIM(ASCTIM,BINTIM), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$SCHDWK(,,BINTIM,), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$PURGWS(%REF(RANGE)), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$HIBER(), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))) IF (I .GE. 6) THEN ISTAT = SYS$DELPRC(,) 998 ENDDO32500 CALL EXIT(EXIT_STATUS) ENDww`Ə PROGRAM IDLEC C I D L ECC Written by Les StocktonC July 21, 1986CC IMPLICIT INTEGER*4 (A-Z) INCLUDE '($IODEF)' INCLUDE '($LIBDEF)' INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)') EXTERNAL CTRL_HIT ! CTRL/C AST Routine, CHARACTER*32 DEF_DIR ! Default Directory' CHARACTER*15 DEF_DEV ! Default Disk1 CHARACTER*30 ORG_PASSWORD /' '/ ! True Password* CHARACTER*30 PASSWORD ! Entered To Stop/ CHARACTER*2 TERMINAL /'TT'/ ! Terminal Screen0 CHARACTER*2 3 CURRENT_TIME ! Current Date/Time? CHARACTER*33 PASS_PROMPT /'Enter Password Used To Terminate '/$ CHARACTER*12 USERNAME ! User Name- CHARACTER*1 TRANSL_FR ! Translate From Str+ CHARACTER*1 TRANSL_TO ! Translate To Str( INTEGER*2 TT_CHAN ! Terminal Channel! INTEGER*2 HIT_CTRL ! CTRL flag( INTEGER*2 DIR_LEN ! Directory Length# INTEGER*2 DEV_LEN ! Disk Length( INTEGER*2 IOSB(4) ! I/O Status Block' INTEGER*2 PASS_LEN ! Password Length, INTEGER*2 ORG_LEN ! Tr ue Password Length7 INTEGER*4 RANGE(2) /0,'7FFFFFFF'X/ ! Working Set Range# INTEGER*4 ISTAT ! Return Status$ INTEGER*4 STATUS ! Return Status- INTEGER*4 OLD_CTRL_MSK ! Old CLI CTRL Mask- INTEGER*4 NEW_CTRL_MSK ! New CLI CTRL Mask+ INTEGER*4 USERNAME_LEN ! Username Length+ INTEGER*4 LIB$DISABLE_CTRL ! Disable CTRL* INTEGER*4 LIB$ENABLE_CTRL ! Enable CTRL. INTEGER*4 LIB$DATE_TIME ! Date/Time Routine3 INTEGER*4 LIB$SYS_TRNLOG ! Trans Logical Routine- INTEGER*4 SYS$ASSIGN ! Assign Term Routine# INTEGER*4 SYS$QIOW ! I/O Routine/ INTEGER*4 SYS$SNDOPR ! Send Operator Routine* INTEGER*4 SYS$PURGWS ! Purge WS Routine0 INTEGER*4 SYS$DELPRC ! Delete Process Routine/ INTEGER*4 SYS$GETJPIW ! Get Job Info Routine/ INTEGER*4 SYS$SETDDIR ! Set or Get Directory2 INTEGER*4 STR$TRANSLATE ! Translate Str Routine, STRUCTURE /ITMLST/ ! Item List for GETJPI UNION ! MAP !$ INTEGER*2 BUFLEN ! Buffer Length INTEGER*2 ITMCOD ! Item Code% INTEGER*4 BUFADR ! Buffer Address% INTEGER*4 RETADR ! Return Address END MAP ! MAP !# INTEGER*4 END_LIST ! End of List END MAP ! END UNION !( END STRUCTURE !____________________4 RECORD /ITMLST/ JPI_LIST(2) ! Record of Item List TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space1 JPI_LIST(1).BUFLEN = 12 ! Username is 12 Long8 JPI_LIST(1).ITMCOD = JPI$_USERNAME ! Get Username Code< JPI_LIST(1).BUFADR = %LOC(USERN AME) ! Location of Username; JPI_LIST(1).RETADR = %LOC(USERNAME_LEN) ! Length Returned) JPI_LIST(2).END_LIST = 0 ! End of List8 ISTAT = SYS$GETJPIW(,,,JPI_LIST,,,) ! Get The Username= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check StatusC ISTAT = STR$TRANSLATE( USERNAME(1:USERNAME_LEN),! Convert Username- 2 USERNAME(1:USERNAME_LEN),! changing null) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check StatusD ISTAT = SYS$ASS IGN ('SYS$COMMAND',TT_CHAN,,) ! Assign Terminal Chnl< IF (.NOT. ISTAT) CALL LIB$STOP (%VAL(ISTAT)) ! Check Status NEW_CTRL_MSK = LIB$M_CLI_CTRLY- ISTAT = LIB$DISABLE_CTRL(%REF(NEW_CTRL_MSK), 2 %REF(OLD_CTRL_MSK))@ FUNC_CODE = IO$_SETMODE .OR. IO$M_CTRLCAST ! Code to trap CTRLs+ ISTAT = SYS$QIOW(%VAL(1), ! Set Terminal 2 %VAL(TT_CHAN), ! to# 2 %VAL(FUNC_CODE), ! trap CTRL/C! 2 IOSB,,, ! I/O Status Block 2 CTRL_HIT, ! AST Routine# 2 HIT_CTRL,,,,) ! AST Parame ter; IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ! Check Status. IF (HIT_CTRL .EQ. 1) THEN ! Check if CTRL/C, FUNC_CODE = IO$_SETMODE .OR. IO$M_CTRLCAST9 ISTAT = SYS$QIOW(%VAL(1),%VAL(TT_CHAN),%VAL(FUNC_CODE)," 2 IOSB,,,CTRL_HIT,HIT_CTRL,,,,) HIT_CTRL = 0- IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) END IFC6C R e a d w i t h P r o m p t a n d T i m e dC< FUNC_CODE = IO$_READPROMPT .OR. IO$M_NOECHO .OR. IO$M_TIMED8 ISTAT = SYS$QIOW(%VAL(1),%VAL(TT_CHAN),%VAL (FUNC_CODE),' 2 IOSB,,,%REF(ORG_PASSWORD),%VAL(30), 2 %VAL(10),, 2 %REF(PASS_PROMPT),%VAL(33)), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)), IF (.NOT. IOSB(1)) ORG_PASSWORD = 'DEFAULT'' ORG_LEN = IOSB(2) ! Password Length I = 0 ! Loop Counter# DO WHILE (I .LT. 6) ! Main Loop@ FUNC_CODE = IO$_SETMODE .OR. IO$M_CTRLCAST ! Code to trap CTRLs+ ISTAT = SYS$QIOW(%VAL(1), ! Set Terminal 2 %VAL(TT_CHAN), ! to# 2 %VAL(FUNC_CODE), ! trap CTRL/C! 2 IOSB,,, !  I/O Status Block 2 CTRL_HIT, ! AST Routine# 2 HIT_CTRL,,,,) ! AST Parameter; IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ! Check Status" I = I + 1 ! Increment Counter4 ISTAT = LIB$DATE_TIME(CURRENT_TIME) ! Get the Time PRINT *,CHAR(27),'[2J'2 PRINT *,CHAR(27),'[9;11H', CHAR(27),'#3',USERNAME2 PRINT *,CHAR(27),'[10;11H',CHAR(27),'#4',USERNAME? PRINT *,CHAR(27),'[12;11H',CHAR(27),'#3is using this terminal'? PRINT *,CHAR(27),'[13;11H',CHAR(27),'#4is using this terminal'6 PRINT *,CHAR(27),'[15;11H',CHAR(27),'#3',CURRENT_TIME6 PRINT *,CHAR(27),'[16;11H',CHAR(27),'#4',CURRENT_TIME PRINT *,' '- ISTAT = SYS$PURGWS(%REF(RANGE)) ! Purge WSC6C R e a d w i t h P r o m p t a n d T i m e dC< FUNC_CODE = IO$_READPROMPT .OR. IO$M_NOECHO .OR. IO$M_TIMED7 ISTAT = SYS$QIOW(%VAL(1),%VAL(TT_CHAN),%VAL(FUNC_CODE)$ 2 ,IOSB,,,%REF(PASSWORD),%VAL(30), 2 %VAL(240),,,), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))3 IF (PASSWORD(1:IOSB(2)) .EQ. ! If entered String: 2 ORG_PASSWORD(1:ORG_LEN)) GOTO 32500 ! is Password, Quit 998 ENDDO PRINT *,CHAR(27),'<' PRINT *,CHAR(27),'[2J' PRINT *,CHAR(27),'[H'+ ISTAT = SYS$DELPRC(,) ! Commit Harikari32500 PRINT *,CHAR(27),'<' PRINT *,CHAR(27),'[2J' PRINT *,CHAR(27),'[H'> ISTAT = LIB$SYS_TRNLOG('SYS$DISK',DEV_LEN,%DESCR(DEF_DEV),,,)/ ISTAT = SYS$SETDDIR(0,DIR_LEN,%DESCR(DEF_DIR))@ PRINT *,'You''re at ',DEF_DEV(1:DEV_LEN),':',DEF_DIR(1:DIR_LEN) END* SUBROUTINE CTRL_HIT(FLAG) ! AST Routine** NOTE:<* It should be pointed out that if a person just 'sits' on<* CTRL/C, they can still kill this program. The only way to>* prevent it, is to run this program from a command procedure,* which has NOCONTROL_Y set.* IMPLICIT INTEGER*2 (A-Z) FLAG = 1 RETURN ENDww I7Ə PROGRAM ID_LIST** I D _ L I S T* INTEGER SYS$IDTOASC EXTERNAL SS$_NORMAL EXTERNAL SS$_NOSUCHID CHARACTER*31 NAME INTEGER IDENTIFIER INTEGER ATTRIBUTES INTEGER ID /-1/ INTEGER LENGTH INTEGER CONTEXT /0/ INTEGER NAME_DSC(2) /31,0/ INTEGER STATUS NAME_DSC(2) = %LOC(NAME) STATUS = %LOC(SS$_NORMAL)9 DO WHILE (STATUS .AND. (STATUS .NE. %LOC(SS$_NOSUCHID))) STATUS = SYS$IDTOASC( %VAL(ID), 2 LENGTH, 2 NAME_DSC, 2 IDENTIFIER, 2 ATTRIBUTES, 2 CONTEXT)8 IF (STATUS .AND. (STATUS .NE. %LOC(SS$_NOSUCHID))) THEN NAME(LENGTH+1:LENGTH+1) = ','( PRINT 10, NAME, IDENTIFIER, ATTRIBUTES910 FORMAT (1X,'Name: 'A31,'Id: ',Z8,', Attributes: ',Z8) END IF END DO) IF (STATUS .NE. %LOC(SS$_NOSUCHID)) THEN CALL SYS$FINISH_RDB(CONTEXT) END IF ENDww@Ə CHARACTER*10 CHARAC INTEGER N INTEGER SIZE" WRITE (UNIT=CHARAC,FMT='(I10)') N SIZE = 1= DO WHILE ((CHARAC(SIZE:SIZE) .EQ. ' ') .AND. (SIZE .LE. 10)) SIZE = SIZE + 1 END DO$ TYPE *,'Number = '//CHARAC(SIZE:10)wwWcƏ CHARACTER*10 PARMS INTEGER STRNUM INTEGER*2 PARM_SIZE READ (UNIT=PARMS(1:PARM_SIZE), 2 FMT='(BN,I1)') STRNUMww`'Ə PROGRAM IS_FILE_OPEN INTEGER*4 LIB$SET_SYMBOL INTEGER*4 LIB$GET_FOREIGN INTEGER LIB$GET_INPUT INTEGER*4 NAME_LEN INTEGER*4 LUN /1/ INTEGER*4 STATUS CHARACTER *256 FILENAME INTEGER*2 FN_SIZE CHARACTER*1 FILE_EXISTS /'N'/ CHARACTER*1 FILE_OPEN /'N'/ LOGICAL EXIST LOGICAL OPENED CHARACTER*255 NAME- STATUS = LIB$GET_FOREIGN(FILENAME,,FN_SIZE,) IF (.NOT. STATUS) THEN# STATUS = LIB$GET_INPUT (FILENAME, 2 'File to inquire about ', 2 FN_SIZE) IF (.NOT. STATUS) GOTO 32767 END IF' INQUIRE (FILE = FILENAME (1:FN_SIZE), 2 NAME = NAME, 2 EXIST = EXIST, 2 OPENED = OPENED) IF (EXIST) FILE_EXISTS = 'Y'3 STATUS = LIB$SET_SYMBOL('FILE_EXISTS',FILE_EXISTS)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) IF (OPENED) FILE_OPEN = 'Y'/ STATUS = LIB$SET_SYMBOL('FILE_OPEN',FILE_OPEN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) 32767 ENDww@_Ǐ** K W O T A . F O R* PROGRAM KWOTA IMPLICIT INTEGER*4 (A-Z) STRUCTURE /FILE_INFO_BLOCK/ UNION MAP BYTE FIB$L_ACCTL(3) BYTE FIB$B_WSIZE BYTE FIB$W_FID(6) BYTE FIB$W_DID(6) INTEGER*4 FIB$L_WCC INTEGER*2 FIB$W_NMCTL INTEGER*2 FIB$W_CNTRLFUNC INTEGER*4 FIB$L_CNTRLVAL INTEGER*4 FIB$L_EXVBN BYTE FIB$B_ALOPTS BYTE FIB$B_ALALIGN BYTE FIB$W_ALLOC(10) INTEGER*2 FIB$W_VERLIMIT  INTEGER*2 RESERVED END MAP MAP CHARACTER*48 CHAR_FIB END MAP END UNION END STRUCTURE RECORD /FILE_INFO_BLOCK/ FIB STRUCTURE /QUOTA_BLOCK_DEF/ UNION MAP INTEGER*4 FLAGS INTEGER*2 UIC_MEMBER INTEGER*2 UIC_GROUP INTEGER*4 USAGE INTEGER*4 PERMQUOTA INTEGER*4 OVERDRAFT INTEGER*4 UNUSED(3) END MAP MAP INTEGER*4 FILLER INTEGER*4 THE_UIC END MAP MAP CHARACTER*32 CHAR_QB END MAP END UNION END STRUCTURE% RECORD /QUOTA_BLOCK_DEF/ QUOTA_BLOCK CHARACTER*40 DISK INTEGER*2 CHAN INTEGER*2 IOSB(4) INTEGER*4 CONTXT INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INCLUDE '($KGBDEF)' RECORD /KGBDEF/ KGB INTEGER*4 SYS$QIOW INTEGER*4 SYS$FIND_HOLDER CONTXT = 0 WRITE (6,100)*100 FORMAT (1X,'Enter Disk To Access: ',$) READ (5,200) DISK_LEN, DISK200 FORMAT (Q,A)- STATUS = SYS$ASSIGN(DISK(1:DISK_LEN),CHAN,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))6 FIB.FIB$L_CNTRLVAL = FIB$M_ALL_MEM .OR. FIB$M_ALL_GRP& FIB.FIB$W_CNTRLFUNC = FIB$C_EXA_QUOTA300 STATUS = SYS$QIOW(, 2 %VAL(CHAN), 2 %VAL(IO$_ACPCONTROL), 2 IOSB,,, 2 FIB.CHAR_FIB, 2 QUOTA_BLOCK.CHAR_QB, 2 LEN, 2 QUOTA_BLOCK.CHAR_QB,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)); IF (IOSB(1) .EQ. SS$_NODISKQUOTA) STOP 'END OF QUOTA LIST'0 IF (.NOT. IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))7 WRITE (6,400) ' The UIC is : ', QUOTA_BLOCK.UIC_GROUP, 2 QUOTA_BLOCK.UIC_MEMBER7 WRITE (6,500) ' Current Usage is: ', QUOTA_BLOCK.USAGE; WRITE (6,500) ' Permanent Quota : ', QUOTA_BLOCK.PERMQUOTA; WRITE (6,500) ' Overdraft Quota : ', QUOTA_BLOCK.OVERDRAFT!400 FORMAT (A, '[',O5,',',O5,']')500 FORMAT (A,I8)3 STATUS = SYS$FIND_HOLDER(%VAL(THE_UIC), ! The UIC) 2 %REF(KGB.KGB$Q_HOLDER), ! The Holder 2 , ! Attribute 2 %REF(CONTXT)) ! Context. IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) PRINT *, KGB$T_NAME TYPE * GOTO 300 ENDww7 鏐3C L O G D E F - Log$* Routines And Data DefinitionsC5C The Log$* routines and constants are defined here.C C DESCRIPTION>C The Log$* system is primarily designed to interact with the<C Err$ system to form an easily manipulated error reporting=C system. A log file can be created that will automatically@C collect signalled error messages. Options allow the messages6C to be displayed to the user and/or/not to the file.C C HIST ORY/C V1.0 07-87 Jay R. Turner Initial developmentC PARAMETER ( 1 LOG$M_APPEND = 1, 1 LOG$M_SPOOL = 2, 1 LOG$M_SUBMIT = 4, 1 LOG$M_TO_FILE = 1, 1 LOG$M_TO_USER = 2, 1 LOG$M_AS_COMMENT = 4,! 1 LOG$M_TEMPORARY = '10000000'X 1 ) EXTERNAL 1 Log$Clear_Options, 1 Log$Close, 1 Log$Open, 1 Log$Set_Options, 1 Log$Write INTEGER 1 Log$Clear_Options, 1 Log$Close, 1 Log$Open, 1 Log$Set_Options, 1 Log$WriteC END. ! LogDefww[Ǐ** M A S T E R* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' INCLUDE '($SYIDEF)'CC F U N C T I O N SC* INTEGER*4 SYS$ASSIGN ! Assign a Channel( INTEGER*4 SYS$CREMBX ! Create Mailbox* INTEGER*4 SYS$DASSGN ! Deassign Channel( INTEGER*4 SYS$DELMBX ! Delete Mailbox) INTEGER*4 SYS$QIOW ! Queue I/O Request' EXTERNAL READ_MBX ! Read the Mailbox CHARACTER* (*) MBX_NAME PARAMETER (MBX_NAME = 'MAIN') CHARACTER*(*) CUSTOMER PARAMETER (CUSTOMER = 'SLAVE')1 CHARACTER*111 MBX_MESSAGE ! Mailbox Msg Buffer* INTEGER READ_CODE ! Read Function Bits, INTEGER WRITE_CODE ! Write Function Bits' INTEGER*2 MBX_CHAN ! Mailbox Channel* INTEGER*2 CUS_CHAN ! User's MBX Channel- INTEGER*4 STATUS ! Function Return Status, INTEGER*4 MESSAGE_LEN ! Length of Message& INTEGER*4 ACMODE ! MBX Access Mode INTEGER*4 AST_FLAG ! AST Flag* INTEGER*4 MBX_PROT ! Mailbox ProtectionC$C I / O S t a t u s B l o c k sC+ STRUCTURE /STATUS_BLOCK/ !---------------. INTEGER*2 IOSTAT, MSG_LEN ! IO Status Block INTEGER*4 READER_PID ! END STRUCTURE !1 RECORD /STATUS_BLOCK/ IOSTATUS !--------------- STRUCTURE /IOSBLK/ INTEGER*4 STS, RESERVED END STRUCTURE RECORD /IOSBLK/ IOSBCC C o m m o n B l o c kC COMMON /MBX_DATA/ MBX_CHAN, 2 MBX_MESSAGE, 2 IOSTAT, 2 MESSAGE_LEN, 2 STATUS, 2 READ_CODE, 2 MSG_LEN, 2 READER_PID, 2 IOSTATUS& ACMODE = PSL$C_USER ! Set User Mode* PRINT *,MBX_NAME,' is the Master Mailbox', PRINT *,CUSTOMER,' is the Customer Mailbox'CC C r e a t e M a i l b o xC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox! 2 MBX_CHAN, ! Chnl For Mailbox" 2 %VAL(111), ! Max Message Size 2 ,,ACMODE, ! Access Mode 2 MBX_NAME) ! Logical Name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C S e t M B X P r o t e c t i o nC* READ_CODE = IO$_SETMODE .OR. IO$M_SETPROT9 MBX_P ROT = 32768 .OR. 8192 .OR. 4096 ! World: Read Write STATUS = SYS$QIOW(, !" 2 %VAL(MBX_CHAN), ! MBX Channel% 2 %VAL(READ_CODE), ! Set Protection" 2 IOSTATUS,,, ! IO Status Block$ 2 ,MBX_PROT,,,,) ! MBX Protection0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))! CALL READ_MBX ! Read Mail Box# PRINT *,MBX_MESSAGE(1:MESSAGE_LEN)C"C S e t u p R e t u r n M B XC,150 STATUS = SYS$ASSIGN(CUSTOMER,CUS_CHAN,,) IF (.NOT. STATUS) THEN& PRINT *,'Error on Assign @ line !150' CALL LIB$STOP(%VAL(STATUS)) END IFCC W r i t e M e s s a g eC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW MBX_MESSAGE = 'MASTER' MESSAGE_LEN = 80' STATUS = SYS$QIOW(, ! Set Event Flag( 2 %VAL(CUS_CHAN), ! Their MBX Channel$ 2 %VAL(WRITE_CODE), ! Write It Now 2 IOSTATUS, ! IO Status Block 2 ,, !$ 2 %REF(MBX_MESSAGE), ! The Message) 2 %VAL(MESSAGE_LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)): STATUS = SYS$DELMBX(%VAL(CU"S_CHAN)) ! Delete User Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))8 STATUS = SYS$DASSGN(%VAL(CUS_CHAN)) ! Deassign User MBX6 STATUS = SYS$DELMBX(%VAL(MBX_CHAN)) ! Delete Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) END INTEGER*4 FUNCTION READ_MBX** R E A D _ M B X* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' INTEGER*4 SYS$QIOW INTEGER STATUS INTEGER MESSAGE_LEN INTEGER READ_CODE CHARACTER*111 MBX_MESSAGE I#NTEGER*2 MBX_CHAN, STRUCTURE /STATUS_BLOCK/ !----------------- INTEGER*2 IOSTAT, MSG_LEN ! IO Status Block INTEGER*4 READER_PID ! END STRUCTURE !2 RECORD /STATUS_BLOCK/ IOSTATUS !---------------- COMMON /MBX_DATA/ MBX_CHAN, 2 MBX_MESSAGE, 2 IOSTAT, 2 MESSAGE_LEN, 2 STATUS, 2 READ_CODE, 2 MSG_LEN, 2 READER_PID, 2 IOSTATUSCC R e a d M B XC READ_CODE = IO$_READVBLK MESSAGE_LEN = 1111 STATUS = SYS$QIOW(,%VAL(MBX_CHAN), ! MBX $Channel 2 %VAL(READ_CODE), ! Read Code& 2 %REF(IOSTATUS), ! IO Status Block 2 ,, ! 2 %REF(MBX_MESSAGE), ! Message) 2 %VAL(MESSAGE_LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" IF ((.NOT. IOSTATUS.IOSTAT) .AND.- 2 (IOSTATUS.IOSTAT .NE. SS$_ENDOFFILE)) THEN( CALL LIB$SIGNAL(%VAL(IOSTATUS.IOSTAT)) END IF( READ_MBX = SS$_NORMAL ! Say it's Okay RETURN ENDww'@ PROGRAM MBX_DEL** M B X _ D E L* IMPLICIT INTEGER*%4 (A - Z) INCLUDE '($LNMDEF)' INCLUDE '($PSLDEF)' INCLUDE '($IODEF)' INCLUDE '($SSDEF)' CHARACTER*80 MBX_NAME INTEGER LIB$GET_INPUT INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$CREMBX INTEGER*4 SYS$QIOW INTEGER*4 SYS$DELMBX INTEGER STATUS INTEGER READ_CODE INTEGER*2 MBX_CHAN INTEGER*2 MBX_LEN INTEGER*4 ACMODE ACMODE = PSL$C_KRNL MBX_NAME(1:80) = ' '@ STATUS = LIB$GET_INPUT(MBX_NAME,'Mailbox to Delete ? ',MBX_LEN) IF (.NOT. STATUS) GOTO 32767&2 STATUS = SYS$ASSIGN( %DESCR(MBX_NAME(1:MBX_LEN)), 2 MBX_CHAN, 2 %VAL(ACMODE),)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))' CALL GET_DVI_NAME(MBX_NAME(1:MBX_LEN))$ STATUS = SYS$DELMBX(%VAL(MBX_CHAN))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) 32767 END" SUBROUTINE GET_DVI_NAME(MBX_NAME) IMPLICIT INTEGER*4 (A - Z) INCLUDE '($IODEF)' INCLUDE '($LNMDEF)' INCLUDE '($PSLDEF)'1 INTEGER*2 BUFF_LEN /64/, ITEM_CODE /32/, IOSB(4)/ INTEGER*4 BUFF_ADR, S'TR_LEN /0/, TERMINATE /0/ CHARACTER*64 DEVICE_NAME CHARACTER*80 MBX_NAME) CHARACTER TABNAM*16 /'LNM$SYSTEM_TABLE'/ CHARACTER RET_STRING*255 CHARACTER RET_TABLE*255 INTEGER*4 RET_LEN /4/* INTEGER*2 TRNLST(20) /4, LNM$_STRING,4*0, 1 4, LNM$_LENGTH,4*0, 1 4, LNM$_TABLE,6*0/ INTEGER*4 SYS$GETDVIW INTEGER*4 SYS$TRNLNM PRINT *,MBX_NAMEC C InitializeC BUFF_ADR = %LOC (DEVICE_NAME)C Get the device nameBC STATUS = SYS$GETDVIW (%VAL(3),%VAL(MBX_CHAN),, BUF(F_LEN,IOSB,,,)0C IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))1C IF (.NOT.IOSB(1)) CALL LIB$STOP (%VAL(IOSB(1)))*C Set up TRNLST, the item list for $TRNLNM TRNLST(1) = 255 TRNLST(3) = %LOC(RET_STRING) TRNLST(7) = 4 TRNLST(9) = %LOC(RET_LEN) TRNLST(13) = 255 TRNLST(15) = %LOC(RET_TABLE)1C Access Contents of Supervisor Mode Logical Name/ STATUS = SYS$TRNLNM (,TABNAM,MBX_NAME,,TRNLST) IF (.NOT. STATUS) GOTO 32767C Write the device name0 TYPE *, 'Device name = ', RET_STR)ING(1:RET_LEN) 32767 RETURN ENDww8 Ǐ* * M E N U*8* This Menu program is designed to be run from within9* a DCL command procedure file. The file has the body of<* the menu embedded within it following the invoking of this * program.B* $ !-------------------------------------------------------------* $ VERIFY = F$VERIFY(0)* $ SET NOVERIFY#* $ ON ERROR THEN GOTO DISPLAY_MENU* $ EXECUTE == "$"* $DISPLAY_MENU:* $ EXECUTE LES:MENU* RUNOFF PROCESSING ME*NU*7* EDT Edit or Create Document ^@ROFF:ROFF_EDIT_DOC EDT*:* List of RUNOFF Documents ^@ROFF:ROFF_LIST_OF_DOCS *.RNO* $ !* $ GOTO DISPLAY_MENU* $ !&* $ WRITE SYS$OUTPUT "Have a Nice Day" * $THEEND:'* $ IF (VERIFY .AND. 1) THEN SET VERIFY* $ EXIT* IMPLICIT INTEGER*4 (A-Z) CHARACTER*5 ANSWER( CHARACTER*55 COMMAND(18) ! What To Do2 CHARACTER*45 ERROR_MESSAGE ! FORTRAN Error Text INTEGER*4 FLAG0 INTEGER*4 FOR$ERROR_MESSAGE ! Rtn to get Error' INTEGER*4 KID+ ! Virtual Keyboard ID! INTEGER*2 LEN ! ANSWER length3 INTEGER*4 LIB$DO_COMMAND ! Rtn to Do the Command* CHARACTER*80 LINE ! Line From menu COM+ INTEGER*2 LINE_LEN ! Length of Menu Line0 INTEGER*4 LINE_NUMBER /0/ ! Line on the Screen INTEGER*4 MASK ! INTEGER*4 MODIFIER !) INTEGER*2 OPTION_INDEX ! Option Number+ INTEGER*2 OPTION_MAX ! Number of Options1 INTEGER*4 OTS$CVT_L_TU ! Rtn convrt Int to Str" INTEGER*4 PBID ! Pasteboard ID CHARACTER*40 PROMPT , INTEGER*4 SMG$CREATE_PASTEBOARD% INTEGER*4 SMG$CREATE_VIRTUAL_DISPLAY& INTEGER*4 SMG$CREATE_VIRTUAL_KEYBOARD INTEGER*4 SMG$LABEL_BORDER$ INTEGER*4 SMG$PASTE_VIRTUAL_DISPLAY INTEGER*4 SMG$PUT_CHARS INTEGER*4 SMG$READ_STRING INTEGER*4 SMG$SET_CURSOR_ABS3 INTEGER*4 SMG$SET_KEYPAD_MODE ! Rtn to set Keypad# INTEGER*4 SMG$SET_OUT_OF_BAND_ASTS- CHARACTER*80 SPACES /' '/$ INTEGER*4 STATUS ! Return Status INTEGER*2 TERMINATOR' INTEGER*4 VDID ! Virtual Display- ID" COMMON /ID/ FLAG, PBID, VDID, KID INCLUDE '($SMGDEF)' INCLUDE '($TRMDEF)' INCLUDE '($SSDEF)'% EXTERNAL ASTSUB ! Routine to Trap ! the CTRL/ keys. STRUCTURE /WORK/ UNION MAP CHARACTER*10 %FILL CHARACTER*2 INDEX CHARACTER*1 DOT /'.'/ CHARACTER*2 %FILL CHARACTER*55 TEXT END MAP MAP CHARACTER*80 LINE END MAP END UNION END STRUCTURE RECORD /WORK/ OPTION SPACES(21:40) = SPACES(1:20) SPACES(41:60) = SPACES(1:20) SPACES(61:80) = S.PACES(1:20), PROMPT = 'Enter Selection ("L" to LOGOUT):' FLAG = .FALSE. MODIFIER = TRM$M_TM_PURGE 2 .OR. TRM$M_TM_ESCAPE 3 .OR. TRM$M_TM_CVTLOW MASK = 0 MASK = JIBSET(MASK,13) MASK = JNOT(MASK) OPEN ( UNIT = 1, 2 FILE = 'SYS$INPUT', 3 STATUS = 'OLD', 4 ERR = 9001, 5 CARRIAGECONTROL = 'NONE' )  READ ( UNIT = 1, 3 END = 32500, 4 FMT = '(Q,A)', 5 IOSTAT = STATUS, 6 ERR = 9000 ) LINE_LEN, LINED WRITE (2,'(A,A)') ' ',LINE'30 STATUS = SM/G$CREATE_PASTEBOARD(PBID)= STATUS = SMG$CREATE_VIRTUAL_DISPLAY(20,77,VDID,SMG$M_BORDER)> STATUS = SMG$LABEL_BORDER(VDID,LINE(1:LINE_LEN),,,SMG$M_BOLD)8 STATUS = SMG$CREATE_VIRTUAL_KEYBOARD(KID,'SYS$COMMAND')2 STATUS = SMG$PASTE_VIRTUAL_DISPLAY(VDID,PBID,3,3)9 STATUS = SMG$SET_OUT_OF_BAND_ASTS(PBID,MASK,ASTSUB,LIST)6 STATUS = SMG$SET_KEYPAD_MODE(KID,0) ! Set to Numeric90 LINE_NUMBER = 0 OPTION_INDEX = 0100 DO WHILE (.TRUE.) OPTION.LINE(1:12) = SPACES OPTION.LINE(14:80) = SP0ACES110 READ ( UNIT = 1, 3 END = 200, 4 FMT = '(Q,A)', 5 IOSTAT = STATUS, 6 ERR = 9000 ) LINE_LEN, LINED WRITE (2,'(A,A)') ' ',LINE)D WRITE (2,'(A,I)') ' LINE_LEN=',LINE_LEN LINE_NUMBER = LINE_NUMBER + 1/D WRITE (2,'(A,I)') ' LINE_NUMBER=',LINE_NUMBER IF (LINE_LEN .EQ. 0) GOTO 110 OPTION_INDEX = OPTION_INDEX + 1 OPTION_MAX = OPTION_INDEX" IF (LINE_NUMBER .GT. 17) GOTO 200. STATUS = INDEX(LINE,'^') ! Find End of Text OPTION.TEXT = LINE(1:STATUS-1)* COMMAND(OPTION_1INDEX) = LINE(STATUS+1:80)% STATUS = OTS$CVT_L_TU( OPTION_INDEX, 2 OPTION.INDEX, 3 %VAL(1), 4 %VAL(2) ) STATUS = SMG$PUT_CHARS( VDID, 2 OPTION.LINE, 3 LINE_NUMBER, 4 1 )=D WRITE (2,'(A,I)') ' Did the PUT_CHARS at line ',LINE_NUMBER(D WRITE (2,'(A,A)') ' LINE=',OPTION.LINE%D WRITE (2,'(A,I)') ' STATUS=',STATUS 198 END DO*200 STATUS = SMG$SET_CURSOR_ABS(VDID,20,1)'D WRITE (2,'(A,I10)') ' STATUS=',STATUS!D WRITE (2,'(A,I10)') ' KID=',KID'D WRITE (2,'(A,A )'2) ' PROMPT=',PROMPT+D WRITE (2,'(A,I10)') ' MODIFIER=',MODIFIER/D WRITE (2,'(A,I10)') ' TERMINATOR=',TERMINATOR#D WRITE (2,'(A,I10)') ' VDID=',VDID STATUS = SMG$READ_STRING(KID, 2 ANSWER, 3 PROMPT, 4 5, 5 MODIFIER,,, 6 LEN, 7 TERMINATOR, 8 VDID )3D WRITE (2,'(A,I)') ' LEN FROM READ_STRING IS ',LEN IF (LEN .EQ. 0) THEN OPTION_INDEX = 1 COMMAND(OPTION_INDEX) = 'EXIT' GOTO 32500 END IF IF (ANSWER(1:1) .EQ. 'L') THEN OPTION_INDEX = 1 COMMAN3D(OPTION_INDEX) = 'LO' GOTO 32500 END IF& STATUS = OTS$CVT_TU_L( ANSWER(1:LEN), 2 OPTION_INDEX, 3 %VAL(2) )@D WRITE (2,'(A,I)') ' STATUS after OTS$CVT on ANSWER is ',STATUS>D WRITE (2,'(A,I)') ' OPTION_INDEX converted is ',OPTION_INDEX IF ((OPTION_INDEX .LT. 0) .OR., 2 (OPTION_INDEX .GT. OPTION_MAX)) GOTO 90900 GOTO 32500** E r r o r T r a p s*59000 STATUS = FOR$ERROR_MESSAGE(STATUS,ERROR_MESSAGE) PRINT *,'Error On Read' PRINT *,ERROR_MESSAGE GOTO 32500549001 STATUS = FOR$ERROR_MESSAGE(STATUS,ERROR_MESSAGE)" PRINT *,'Error Opening SYS$INPUT' PRINT *,ERROR_MESSAGE GOTO 32500* * C l e a n u p R o u t i n e**32500 STATUS = SMG$DELETE_PASTEBOARD(PBID)8D WRITE (2,'(A,A)') 'Command is: ',COMMAND(OPTION_INDEX)/ STATUS = LIB$DO_COMMAND(COMMAND(OPTION_INDEX)) 32767 END  SUBROUTINE ASTSUB(LIST) IMPLICIT INTEGER*4 (A-Z) COMMON /ID/ FLAG,PBID,VDID,KID INCLUDE '($SMGDEF)': STATUS = SMG$CANCEL_INPUT(KID) ! Cancel Ou5tstanding Read# FLAG = .TRUE. ! Notify the UserD STATUS = SMG$PUT_CHARS(VDID,'Control/Key Pressed',20,1,,SMG$M_BOLD) RETURN ENDww`:** M M F S _ D R I V E R* PROGRAM MMFS_DRIVERCC Needs Options File on Link.C PSECT_ATTR = GBL, PAGEC' DICTIONARY 'CDD$TOP.USER.X25_REC/LIST' RECORD /MBX/ X25( DICTIONARY 'CDD$TOP.USER.MMFS_REC/LIST' RECORD /MMFS/ MMFS INCLUDE '($IODEF)' INCLUDE '($SECDEF)'# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'$ INC6LUDE 'SYS$INCLUDE:DPQENTRY.PAR'" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'% INCLUDE 'SYS$INCLUDE:SCANHEADR.PAR'% INCLUDE 'SYS$INCLUDE:SCNDATDEF.PAR'% INCLUDE 'SYS$INCLUDE:WHOLESCAN.PAR'" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'8 INTEGER*2 ANY_CURRENT_CONTROLS ! # of Current Controls/ INTEGER*4 ASCEFC_ERR(3) ! SYS$ASCEFC Err Msg 2 /'SYS$','EFC ','ERR '/ !/ INTEGER*4 CREPRC_ERR(3) ! SYS$CREPRC Err Msg 2 /'SYS$','CREP','RC '/ !( INTEGER*2 CTL(1024) ! Ptr to Controls1 BYTE CURRENT 7_CONTROLS(1024) ! Current Controls7 INTEGER*2 CURRENT_CONTROLS_MAX ! Maximum Virtual Crct* PARAMETER (CURRENT_CONTROLS_MAX = 1024) !2 INTEGER*4 ERROR_RETURN(2) ! VECTOR Error Status) INTEGER*4 FILE_NUM(200) ! File Numbers, INTEGER*4 INFO_FLAG /71/ ! Flag From TIMER/ INTEGER*4 INIT_ERROR(3) ! Init Error Message 2 /'INIT',' -ER','ROR '/ !" INTEGER*4 LEN ! Bytes Returned0 INTEGER*4 LUERRMSG(3) ! General Vector Errors 2 /' ',' ',' '/ !# INTEGER*4 MMFS_LEN ! 8MMFS Length( BYTE MMFS_QUE(12) ! Input Queue Name, 2 /'M','M','F','S','_','Q','U','E',4*' '/ !* INTEGER*2 MMFS_TRANS ! MMFS Transaction2 INTEGER*2 MMFS_TRANS_MAX ! MMFS Transaction Max$ PARAMETER (MMFS_TRANS_MAX = 200) !/ INTEGER*4 PASS_ADDR(2) ! Addresses of GlobalA INTEGER*2 PEND_PTR(CURRENT_CONTROLS_MAX) ! Pending Array Pointer6 BYTE PENDING_CONTROLS(244,2,1024) ! Controls Waiting2 INTEGER*2 PENDING_CONTROLS_MAX ! Maximum Waiting' PARAMETER (PENDING_CONTROLS_MAX = 2) !" B 9YTE PRCNAM(12) ! Process Name( 2 /'D','A','$','M','M','F','S',5*' '/ !' CHARACTER*8 PROCID ! VMS Job Number3 BYTE QUEUE_NAME(12,200) ! Queue Names for Global% INTEGER*4 QUEUE_NUM ! Queue Number& INTEGER*4 READ_CODE ! MBX Read Code- INTEGER*4 RECORD_NUM(200) ! Record Numbers- INTEGER*4 REQUEST_FLAG /70/ ! Flag to TIMER( BYTE REQUEST_TYPE(200) ! Request Type. INTEGER*4 RET_ADDR(2) ! From Global Section) INTEGER*2 SEC_CHAN ! Channel of Global- INTEGER*2 SEC_LEN ! :Global Section Length- INTEGER*4 SEC_MASK ! Mask for Glbl Section- INTEGER*4 SETEF_ERR(3) ! SYS$SETEF Err Msg 2 /'SYS$','SETE','F '/ !/ INTEGER*4 SPECIAL(5) ! VECTOR Special Fields- INTEGER*4 STATUS ! Function Return Status1 INTEGER*2 TBL_PTR /0/ ! Global Section Pointer/ INTEGER*2 TIMER(200) ! Timeouts in Glbl Sctn5 INTEGER*2 TRANS_NUMBER(200) ! Trans #s in Glbl Sctn* CHARACTER*16 USER_IN_MBX ! User Mailbox3 INTEGER*2 USER_IN_MBX_CHAN ! User Mailbox Channel+; CHARACTER*16 USER_OUT_MBX ! User Mailbox4 INTEGER*2 USER_OUT_MBX_CHAN ! User Mailbox Channel, INTEGER*4 VCSID /761/ ! VECTOR Program ID/ INTEGER*4 WAITFR_ERR(3) ! SYS$WAITFR Err Msg 2 /'SYS$','WAIT','FR '/ !( INTEGER*4 WRITE_CODE ! MBX Write Code% CHARACTER*(*) X_25 ! X.25 Mailbox PARAMETER (X_25 = 'X.25') !- INTEGER*2 X_25_CHAN ! X.25 Mailbox ChannelCC F u n c t i o n sC6 INTEGER*4 CLOSE_VIRTUAL_CIRCUIT ! Function for Close- INTEGER*4 GET_STATUS ! Func <tion for Status INTEGER*4 MMFSIZE ! Add MMFS4 INTEGER*4 OPEN_VIRTUAL_CIRCUIT ! Function for Open1 INTEGER*4 SEND_CONTROL ! Function for Controls+ INTEGER*4 SEND_SCAN ! Function for Scans- INTEGER*4 SYS$ASCEFC ! Setup Event Cluster/ INTEGER*4 SYS$ASSIGN ! Setup Mailbox Channel( INTEGER*4 SYS$CREMBX ! Create Mailbox( INTEGER*4 SYS$CREPRC ! Create Process0 INTEGER*4 SYS$CRMPSC ! Create/Map Global Sctn) INTEGER*4 SYS$QIOW ! Queue I/O Request' INTEGER*4 SYS$SETEF ! S=et Event Flag- INTEGER*4 SYS$WAITFR ! Wait For Event Flag+ INTEGER*4 UFO_CREATE ! User Open Routine' EXTERNAL UFO_CREATE ! '' '' ''C.C S t r u c t u r e s a n d R e c o r d sC STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 READER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUSCC C o m m o n B l o c k sC* COMMON /UFO/ SEC_CHAN ! From UFO_CREATE COMMON /RECS/ MMFS COMMON /MMFS/ MFS$_ENTRYCC G l o b a l C o m m o n>C0 COMMON /GBL/ TBL_PTR, ! Array Element Pointer( 2 TRANS_NUMBER, ! Transaction Number 3 QUEUE_NAME, ! Queue Name 4 TIMER, ! How Many Minutes 5 FILE_NUM, ! File Number! 6 RECORD_NUM, ! Record Number" 7 REQUEST_TYPE, ! Request Type 8 X25, ! X25 Mailboxes 9 CTL, ! Ptr to Controls) 9 CURRENT_CONTROLS, ! Current Controls1 9 ANY_CURRENT_CONTROLS ! # of Current ControlsCC P r o c e s s i n gC, CALL GETPID(PROCID) ! Get the Job Number. CAL?L DA$MFSINT( VCSID, ! Init Using VCSID, 2 PRCNAM, ! Process Name, 2 SPECIAL, ! Special Fields,( 2 ERROR_RETURN ) ! and Error Return., IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) THEN# CALL LU$ERROR(VCSID,ERROR_RETURN,$ 2 INIT_ERROR,SPECIAL,ERROR_RETURN) CALL EXIT END IFCC Create the Timer Sub-ProcessC C Remember VCS$SYSTEM:MMFS_TIMERC. STATUS = SYS$CREPRC( , ! Create a Process. 2 'MMFS_TIMER', ! Image Name 3 ,,,,, !" 4 'MMFS_TIMER', ! Proces@s Name 5 %VAL(4),,,) ! Priority+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 CREPRC_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------C"C C r e a t e M a i l b o x e sC; STATUS = SYS$ASSIGN(X_25,X_25_CHAN,,) ! Permanent Mailbox+ IF (.NOT. STATUS) THEN A ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '49535341'X ! ASSI! LUERRMSG(3) = '20204E47'X ! GN, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------> USER_IN_MBX = 'USER' // PROCID // 'IN' ! Input Mailbox Name9 USER_OUT_MBX = 'USE BR' // PROCID // 'OUT ' ! Mailbox Name3 STATUS = SYS$CREMBX( %VAL(1), ! Permanent Mailbox- 2 USER_OUT_MBX_CHAN, ! Channel for Mailbox 3 %VAL(512), ! Max Size 4 ,,, !# 5 USER_OUT_MBX ) ! Mailbox Name+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '4D455243'X ! CREM! LUERRMSG(3) = '20205842'X ! BX, CALL LU$ERROR( VCSID, C! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------3 STATUS = SYS$CREMBX( %VAL(1), ! Permanent Mailbox, 2 USER_IN_MBX_CHAN, ! Channel for Mailbox 3 %VAL(512), ! Max Size 4 ,,, !" 5 USER_IN_MBX ) ! Mailbox Name+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '2D4535953'X ! SYS$# LUERRMSG(2) = '4D455243'X ! CREM! LUERRMSG(3) = '20205842'X ! BX, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------C%C T e l l X . 2 5 W h o I a mC X25.USER_IN = USER_IN_MBX X25.USER_OUT = USER_OUT_MBX WRITE_CODE = IO$_WRITEVBLK STATUS = SYS$QIOW(, ! 2 %VAL(X_25_CHAN), ! Channel# 3 %VAL(WRITE_CODE), E ! Write Code 4 IOSTATUS, ! IOSB 5 ,, ! 6 %REF(X25), ! The Message 7 %VAL(32), ! Message Size% 8 %VAL(10),,, ) ! Wait 10 Seconds+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '574F4951'X ! QIOW LUERRMSG(3) = '20202020'X !, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SFPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------5C STATUS = SYS$ASCEFC(%VAL(REQUEST_FLAG),'CLUSTER',,),C IF (.NOT. STATUS) THEN ! If Error, then2C ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error-C ERROR_RETURN(2) = STATUS ! Set Error Code-C CALL LU$ERROR( VCSID, ! Signal the ErrorC 2 ERROR_RETURN, !C 2 ASCEFC_ERR, !C 2 SPECIAL, !C 2 ERROR_RETURN ) !C CALL EXIT ! Quit C END IF !----------------- ANY_CURGRENT_CONTROLS = 0 DO I = 1, CURRENT_CONTROLS_MAX PEND_PTR(I) = 0 CTL(I) = 0 CURRENT_CONTROLS(I) = 0 END DO& DO WHILE (.TRUE.) !*** L O O P ***8 IF (ANY_CURRENT_CONTROLS) THEN ! If any current ctrls: DO I = 1, ANY_CURRENT_CONTROLS ! then, for all of emF IF (.NOT. CURRENT_CONTROLS(CTL(I))) THEN ! If no ctl on this chnl8 IF (PEND_PTR(CTL(I))) THEN ! and there's ctls pending: MMFS_TRANS = MMFS_TRANS + 1 ! Increment transaction1 IF (MMFS_TRANS .GT. ! IfH transaction over: 2 MMFS_TRANS_MAX) MMFS_TRANS = 1 ! max, then start over.; STATUS = SEND_CONTROL(MMFS_TRANS, ! Send the Control.0 2 PENDING_CONTROLS(1,PEND_PTR(CTL(I)),CTL(I)), 3 MMFS.DATA,MMFS_LEN) !- PEND_PTR(CTL(I)) = PEND_PTR(CTL(I)) - 1# END IF ! IF (PEND_PTR(CTL(I))$ END IF ! IF (.NOT. CURRENT_' END DO ! DO I = 1, ANY_CURRENT END IF ! IF (ANY_CURRENT+ CALL LQ$GETQUE( VCSID, ! Get MMFS Queue 2 MMFS_QUE, ! Queue Name 2 MFS$_EINTRY, ! Record 2 LEN, ! Number of Bytes 2 QUEUE_NUM, ! Queue Number 2 SPECIAL, ! Special Fields# 2 ERROR_RETURN ) ! Error Status= IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) THEN ! If Not Success6 CALL LU$ERROR(VCSID,ERROR_RETURN, ! then Tell VECTOR6 2 INIT_ERROR,SPECIAL,ERROR_RETURN)! About the Error, CALL EXIT ! and Quit. END IFC$C C h e c k t h e R e q u e s tC2 MMFS_TRANS = MMFS_TRANS + 1 ! Increment Counter3 IF (MMFS_TRANS .GT. MMFS_TRANS_MAX) M JMFS_TRANS = 18 REQUEST_TYPE(MMFS_TRANS) = MFS$_REQUEST ! Request Type8 IF (MFS$_REQUEST .EQ. 1) THEN ! If Request is 1, then5 STATUS = OPEN_VIRTUAL_CIRCUIT() ! do Open Routine. MMFS_LEN = 20 !< ELSE IF (MFS$_REQUEST .EQ. 2) THEN ! If Request is 2, then6 STATUS = CLOSE_VIRTUAL_CIRCUIT() ! do Close Routine. MMFS_LEN = 20 !< ELSE IF (MFS$_REQUEST .EQ. 3) THEN ! If Request is 3, then2 STATUS = GET_STATUS() ! do Get_Status Routine. MMFS_LEN = 20 !7 ELSE IF (MFS$_REQUE KST .EQ. 4) THEN ! If Request is 4,> IF (CURRENT_CONTROLS(MFS$_OUTPUT_CHNL)) THEN ! Stack Control9 IF (MFS$_OUTPUT_CHNL .LE. CURRENT_CONTROLS_MAX) THEN8 PEND_PTR(MFS$_OUTPUT_CHNL) = ! Increment Pointer$ 2 PEND_PTR(MFS$_OUTPUT_CHNL) + 1 != CALL LU$MOVBYT(244,MFS$_ENTRY, ! Save Pending Control 2 PENDING_CONTROLS(1, !! 3 PEND_PTR(MFS$_OUTPUT_CHNL), ! 4 MFS$_OUTPUT_CHNL),1) ! END IF ! ELSE ! Else' STATUS = SEND_CONTROL(MMFS_TRANS, ! , 2 MFS$_LXMIT_BUFFER, !& 3 MMFS.DATA, ! do Control Routine. 4 MMFS_LEN )1 ANY_CURRENT_CONTROLS = ANY_CURRENT_CONTROLS + 1. CTL(ANY_CURRENT_CONTROLS) = MFS$_OUTPUT_CHNL END IF !7 ELSE IF (MFS$_REQUEST .EQ. 5) THEN ! If Request is 5,) STATUS = SEND_SCAN(MMFS_TRANS, ! then, 2 MFS$_XMIT_BUFFER, !( 3 MMFS.DATA, ! do Scan List Routine. 4 MMFS_LEN )7 FILE_NUM(MMFS_TRANS)=MFS$_SCAN_FILE_NUM ! File Number< RECORD_NUM(MMFS_TRANS) = MFS$_SCAN_REC_NUM ! Record Number END IFMCC S e n d T o X . 2 5C4 IF ((MFS$_REQUEST .GE. 4) .AND. ! If Sending Data* 2 (MFS$_REQUEST .LE. 5)) THEN ! then,/ MMFS.HDR.FUNC = MMFS_LEN ! Plug these fields' MMFS.HDR.VC_CHAN = MFS$_OUTPUT_CHNL ! END IF= WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_TIMED ! Write w/Timeout STATUS = SYS$QIOW(, !& 2 %VAL(USER_OUT_MBX_CHAN), ! Channel# 3 %VAL(WRITE_CODE), ! Write Code 4 IOSTATUS, ! IOSB 5 ,, ! 6 %REF(MMFS), ! The Message% 7 %VAL(MMFS_LEN+4), ! MNessage Size$ 8 %VAL(2),,, ) ! Seconds To Wait+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code# LUERRMSG(1) = '24535953'X ! SYS$# LUERRMSG(2) = '574F4951'X ! QIOW LUERRMSG(3) = '20202020'X !, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 LUERRMSG, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------/ TBL_PTR = O TBL_PTR + 1 ! Increment Table Ptr8 TRANS_NUMBER(TBL_PTR) = MMFS_TRANS ! Transaction Table3 TIMER(MMFS_TRANS) = MFS$_IO_TIMEOUT + 1 ! Timeout> CALL LU$MOVBYT( MFS$_QUE_NAME_LENGTH, ! Move Number of Bytes) 2 MFS$_QUE_NAME, ! Source Data Buffer0 3 QUEUE_NAME(1,MMFS_TRANS), ! Destination Data 4 1 ) ! Starting Byte7 STATUS = SYS$SETEF(%VAL(REQUEST_FLAG)) ! Notify TIMER+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_REPTURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 SETEF_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! CALL EXIT ! Quit END IF !-----------------8C STATUS = SYS$WAITFR(%VAL(INFO_FLAG)) ! Wait for TIMER,C IF (.NOT. STATUS) THEN ! If Error, then2C ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error-C ERROR_RETURN(2) = STATUS ! Set Error Code-C CALL LU$ERROR( VCSID, ! Signal the ErrorC 2 ERROR_RETURN, !C Q2 WAITFR_ERR, !C 2 SPECIAL, !C 2 ERROR_RETURN ) !C CALL EXIT ! Quit C END IF !----------------- END DO !*** L O O P *** END *,* C l o s e _ V i r t u a l _ C i r c u i t*) INTEGER*4 FUNCTION CLOSE_VIRTUAL_CIRCUIT# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'# DICTIONARY 'CDD$TOP.USER.MMFS_REC' RECORD /MMFS/ MMFS COMMON /RECS/ MMFS COMMON /MMFS/ MFS$_ENTRY INTEGER*4 STATUS& MMFS.HDR.FUNC = 2 ! Code For Close& MMFS.HDR.ERR_CODE =R 0 ! Zero Error/ MMFS.HDR.VC_CHAN = MFS$_PORT_AND_VC ! Channel? CALL LU$MOVBYT( MFS$_LOGICAL_NAME_LENGTH, ! For Length of Name. 2 MFS$_LOGICAL_NAME, ! Circuit Logical Name 2 MMFS.DATA, ! Data Buffer 2 1 ) ! Starting Position$32767 CLOSE_VIRTUAL_CIRCUIT = STATUS RETURN END *+* O p e n _ V i r t u a l _ C i r c u i t*( INTEGER*4 FUNCTION OPEN_VIRTUAL_CIRCUIT# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'# DICTIONARY 'CDD$TOP.USER.MMFS_REC' RECORD /MMFS/ MMFSS COMMON /RECS/ MMFS COMMON /MMFS/ MFS$_ENTRY INTEGER*4 STATUS% MMFS.HDR.FUNC = 1 ! Code For Open& MMFS.HDR.ERR_CODE = 0 ! Zero Error/ MMFS.HDR.VC_CHAN = MFS$_PORT_AND_VC ! Channel? CALL LU$MOVBYT( MFS$_LOGICAL_NAME_LENGTH, ! For Length of Name. 2 MFS$_LOGICAL_NAME, ! Circuit Logical Name 2 MMFS.DATA, ! Data Buffer 2 1 ) ! Starting Position#32767 OPEN_VIRTUAL_CIRCUIT = STATUS RETURN END ** G e t _ S t a t u s* INTEGER*4 FUNCTION GET_STATTUS# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'# DICTIONARY 'CDD$TOP.USER.MMFS_REC' RECORD /MMFS/ MMFS COMMON /RECS/ MMFS COMMON /MMFS/ MFS$_ENTRY INTEGER*4 STATUS' MMFS.HDR.FUNC = 3 ! Code For Status& MMFS.HDR.ERR_CODE = 0 ! Zero Error/ MMFS.HDR.VC_CHAN = MFS$_PORT_AND_VC ! Channel? CALL LU$MOVBYT( MFS$_LOGICAL_NAME_LENGTH, ! For Length of Name. 2 MFS$_LOGICAL_NAME, ! Circuit Logical Name 2 MMFS.DATA, ! Data Buffer 2 1 ) ! Starting Position32767 GET_STUATUS = STATUS RETURN END ** S e n d _ C o n t r o l*3 INTEGER*4 FUNCTION SEND_CONTROL( TRANS_NUM,IN_REC, 2 OUT_REC,MMFS_LEN ) IMPLICIT NONE# DICTIONARY 'CDD$TOP.USER.MMFS_REC' RECORD /MMFS/ MMFS COMMON /RECS/ MMFS CHARACTER*(*) DATA_NAME! PARAMETER (DATA_NAME = 'CONTRL') BYTE IN_REC(*) INTEGER*2 MMFS_LEN INTEGER*4 MMFSIZE BYTE OUT_REC(*) INTEGER*4 STATUS INTEGER*2 TRANS_NUM> STATUS = MMFSIZE(TRANS_NUM,DATA_NAME,IN_REC,OUT_REC,MMFS_LEVN)32767 SEND_CONTROL = STATUS RETURN END ** S e n d _ S c a n*0 INTEGER*4 FUNCTION SEND_SCAN( TRANS_NUM,IN_REC, 2 OUT_REC,MMFS_LEN) IMPLICIT NONE# DICTIONARY 'CDD$TOP.USER.MMFS_REC' RECORD /MMFS/ MMFS COMMON /RECS/ MMFS CHARACTER*(*) DATA_NAME! PARAMETER (DATA_NAME = 'CONTRL') BYTE IN_REC(*) INTEGER*2 MMFS_LEN INTEGER*4 MMFSIZE BYTE OUT_REC(*) INTEGER*4 STATUS INTEGER*2 TRANS_NUM> STATUS = MMFSIZE(TRANS_NUM,DATA_NAME,IN_REC,OUT_RECW,MMFS_LEN)32767 SEND_SCAN = STATUS RETURN END ** M M F S I Z E*0 INTEGER*4 FUNCTION MMFSIZE(TRANS_NUM,DATA_NAME, 2 IN_REC,OUT_REC,MMFS_LEN)# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'# INCLUDE 'SYS$INCLUDE:MMFSDEF.PAR'% CHARACTER*(*) DATA_NAME ! Data Name+ BYTE DATA_NAME_LEN ! Length of Data Name% INTEGER*2 HIGH_BIT ! High Bit Value PARAMETER (HIGH_BIT = 128) ! INTEGER*2 I ! Counter INTEGER*2 J ! Counter BYTE IN_REC(*) ! Input Record% INTEGER*2 MMFXS_LEN ! Length of MMFS* INTEGER*2 OFFSET ! Offset For Scan List% BYTE OUT_REC(*) ! Same as MMFS_REC# INTEGER*4 STATUS ! Return Status* BYTE TN_BYTES ! Transaction Number Size* INTEGER*2 TRANS_NUM ! Transaction Number) INTEGER*2 WORD ! Work area 1 word long. INTEGER*2 WORDS ! Number of Words in Stream INTEGER*4 X ! Work Number COMMON /MMFS/ MFS$_ENTRY$ STATUS = 0 ! Set Negative Status1 X = MOD(TRANS_NUM,1024) ! Find out how big the0 IF (X .LE. 127) THEN ! YTransaction Number is." OUT_REC(3) = TRANS_NUM ! Byte 4 TN_BYTES = 1 ELSE IF (X .LE. 255) THEN OUT_REC(3) = HIGH_BIT + 1 OUT_REC(4) = TRANS_NUM TN_BYTES = 2 ELSE OUT_REC(3) = HIGH_BIT + 2 WORD = IBITS(TRANS_NUM,0,8) OUT_REC(4) = WORD WORD = IBITS(TRANS_NUM,8,8) OUT_REC(5) = WORD TN_BYTES = 3 END IF DATA_NAME_LEN = LEN(DATA_NAME)) MMFS_LEN = 17 + TN_BYTES + DATA_NAME_LEN I = TN_BYTES + 3' OUT_REC(0) = OC ! Beginning of MMFS0 OUT_REC(1) Z= MMFS_LEN ! Length of MMFS prefix( OUT_REC(2) = TN ! Transaction Number OUT_REC(I+0) = PC ! Procedure) OUT_REC(I+1) = CRQ ! Kind of Procedure+ OUT_REC(I+2) = IG2 ! Instruction Group 2 OUT_REC(I+3) = WRI ! Write OUT_REC(I+4) = DN ! Data Name; OUT_REC(I+5) = HIGH_BIT + DATA_NAME_LEN ! Data Name Length, DO J = 1,DATA_NAME_LEN ! Insert Data Name- OUT_REC(I+5+J) = ICHAR(DATA_NAME(J:J)) ! '' END DO ! ''3 J = I + 6 + DATA_NAME_LEN ! Adjust Buffer Pointer. IF (MFS[$_REQUEST .EQ. 5) THEN ! If Scan List" OUT_REC(J) = OF ! Offset Field J = J + 1 ! Bump Pointer2 WORD = MFS$_PORT_N_LIST ! Figure Size of Offset OFFSET = IBITS(WORD,0,4) OFFSET = (OFFSET - 1) * 100 X = MOD(WORD,1024) IF (X .LE. 127) THEN OUT_REC(J) = WORD J = J + 1 ELSE IF (X .LE. 255) THEN OUT_REC(J) = HIGH_BIT + 1 OUT_REC(J+1)=WORD J = J + 2 ELSE OUT_REC(J) = HIGH_BIT + 2 OUT_REC(J+1)= IBITS(WORD,0,8) OUT_REC(J+2)= IBITS(WORD,8,8) \ J = J + 3 END IF END IF! OUT_REC(J) = DS ! Data Stream> IF (MFS$_NUM_OF_CODES .GT. (MFS$_HOST_CODES_LENGTH / 2)) THEN0 MFS$_NUM_OF_CODES = MFS$_HOST_CODES_LENGTH / 2 END IF X = J + 6 WORDS = 05 IF (MFS$_REQUEST .EQ. 5) THEN ! If it's a Scan List WORDS = 4 + MFS$_NUM_OF_CODES/ OUT_REC(J+ 4) = IBITS(MFS$_SCAN_REC_NUM1,0,8)/ OUT_REC(J+ 5) = IBITS(MFS$_SCAN_REC_NUM1,8,8)# OUT_REC(J+ 6) = MFS$_TRIGGER_TYPE" OUT_REC(J+ 7) = MFS$_OPT_VRT_CKT/ OUT_REC(J+ 8) = IBIT]S(MFS$_TRIGGER_VALUE,0,8)/ OUT_REC(J+ 9) = IBITS(MFS$_TRIGGER_VALUE,8,8). OUT_REC(J+10) = IBITS(MFS$_NUM_OF_CODES,0,8). OUT_REC(J+11) = IBITS(MFS$_NUM_OF_CODES,8,8)( CALL LU$MOVBYT( MFS$_NUM_OF_CODES * 2, 2 MFS$_HOST_CODES, 2 OUT_REC, J + 12 )7 ELSE IF (MFS$_REQUEST .EQ. 4) THEN ! If it's a Control DO I = 1, MFS$_NUM_OF_CODES, 22 IF ((MFS$_HOST_CODES(I) .GT. 63) .AND. ! Control) 2 (MFS$_HOST_CODES(I) .LT. 80)) THEN !/ OUT_REC(X + (WORDS*2)) = MFS$_HOST_CODES(I) !2 ^ OUT_REC(X + (WORDS*2)+1)= MFS$_HOST_CODES(I+1) ! WORDS = WORDS + 1 !/ ELSE IF ((MFS$_HOST_CODES(I) .GT. 79) .AND. !) 2 (MFS$_HOST_CODES(I) .LT. 96)) THEN !/ OUT_REC(X + (WORDS*2)) = MFS$_HOST_CODES(I) !2 OUT_REC(X + (WORDS*2)+1)= MFS$_HOST_CODES(I+1) !2 OUT_REC(X + (WORDS*2)+2)= MFS$_HOST_CODES(I+2) !2 OUT_REC(X + (WORDS*2)+3)= MFS$_HOST_CODES(I+3) ! WORDS = WORDS + 2 !0 ELSE IF ((MFS$_HOST_CODES(I) .GT. 95) .AND. !* 2 (MFS$_HOST_CODES(I) .LT. 112)) THEN !/ OUT_RE_C(X + (WORDS*2)) = MFS$_HOST_CODES(I) !2 OUT_REC(X + (WORDS*2)+1)= MFS$_HOST_CODES(I+1) ! WORDS = WORDS + 1 ! END IF !---------- END DO IF (WORDS .LT. 10) THEN OUT_REC(J + 4) = 0 OUT_REC(J + 5) = WORDS ELSE$ OUT_REC(J + 4) = IBITS(WORDS,0,8)$ OUT_REC(J + 5) = IBITS(WORDS,8,8) END IF END IF, OUT_REC(J+1) = WORDS ! Data Stream Length OUT_REC(J+2) = CT ! Count, OUT_REC(J+3) = WORDS * 2 ! Number of Bytes9 MMFS_LEN = MMFS_LEN + (WORDS * 2) !` Total Size of Output& STATUS = 1 ! Set Status to Success,32767 MMFSIZE = STATUS ! Return the Status RETURN END ** D A $ M F S I N T*+ SUBROUTINE DA$MFSINT( VCSID, RECORD_NAME,  2 SPECIAL, ERROR_RETURN ) IMPLICIT INTEGER (A-Z)' DICTIONARY 'CDD$TOP.USER.X25_REC/LIST' RECORD /MBX/ X25 INCLUDE '($SECDEF)'CIC Sysint.par contains the paramters and definitions with the syc$_ prefixC" INCLUDE 'SYS$INCLUDE:SYSINT.PAR'CIC Syserr.par contains the aparameters and definitions of the error returnsC" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'CJC Dainit.par contains the parameters and definitions with the da$i_ prefixC" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'CJC Dmscom.par contains the parameters and definitions with the dms$_ prefixC" INCLUDE 'SYS$INCLUDE:DMSCOM.PAR'C HC======================================================================  C!C Define the subprocess variablesC, BYTE FILE_NAME ( DA$I_FILE_NAME_LENGTH )-b BYTE RECORD_NAME ( DA$I_RECORD_NAME_LENGTH )( DATA FILE_NAME / 'V','G','E','N',8*' '/ DIMENSION INITREC( SYC$_IRSIZE)C9C Define record as integer for the initialization routineC INTEGER*4 FILE_NUMBER INTEGER*4 RECORD_NUMBER INTEGER*4 ERROR_RETURN ( 2 ) INTEGER*4 SPECIAL ( 5 ) INTEGER*4 ERR_RTN(2) 8 INTEGER*2 ANY_CURRENT_CONTROLS ! # of Current Controls/ INTEGER*4 CRMPSC_ERR(3) ! SYS$CRMPSC Err Msg 2 /'SYS$','CRMP','SC '/ !1 BYTE CURRENT_CONTROLS(1024) ! c Current Controls7 INTEGER*2 CURRENT_CONTROLS_MAX ! Maximum Virtual Crct* PARAMETER (CURRENT_CONTROLS_MAX = 1024) !) INTEGER*4 FILE_NUM(200) ! File Numbers3 INTEGER*4 GET_LUN_ERR(3) ! LIB$GET_LUN Error Msg 2 /'LIB$','GET_','LUN '/ !+ INTEGER*4 LIB$GET_LUN ! Get Logical Unit, INTEGER*2 INFO_LUN ! Unit of Section File3 BYTE QUEUE_NAME(12,200) ! Queue Names for Global/ INTEGER*4 PASS_ADDR(2) ! Addresses of Global- INTEGER*4 RECORD_NUM(200) ! Record Numbers( BYTE REQ dUEST_TYPE(200) ! Request Type. INTEGER*4 RET_ADDR(2) ! From Global Section) INTEGER*2 SEC_CHAN ! Channel of Global- INTEGER*2 SEC_LEN ! Global Section Length- INTEGER*4 SEC_MASK ! Mask for Glbl Section- INTEGER*4 STATUS ! Function Return Status0 INTEGER*4 SYS$CRMPSC ! Create/Map Global Sctn. INTEGER*2 TBL_PTR ! Global Section Pointer/ INTEGER*2 TIMER(200) ! Timeouts in Glbl Sctn5 INTEGER*2 TRANS_NUMBER(200) ! Trans #s in Glbl Sctn+ INTEGER*4 UFO_CREATE ! User Opeen Routine' EXTERNAL UFO_CREATE ! '' '' ''CC C o m m o nC* COMMON /UFO/ SEC_CHAN ! From UFO_CREATECC G l o b a l C o m m o nC0 COMMON /GBL/ TBL_PTR, ! Array Element Pointer( 2 TRANS_NUMBER, ! Transaction Number 3 QUEUE_NAME, ! Queue Name 4 TIMER, ! How Many Minutes 5 FILE_NUM, ! File Number! 6 RECORD_NUM, ! Record Number" 7 REQUEST_TYPE, ! Request Type 8 X25, ! X25 Mailboxes) 9 CURRENT_CONTROLS, ! Current Controls1 9 ANY_CUfRRENT_CONTROLS ! # of Current ControlsCCC Associate with system event flags cluster to reference the systemC startup flag (#64).CC+ CALL LU$ASCEFC ( VCSID, EVENT_FLAG_NUMBER,( 2 EVENT_FLAG_CLUSTER_NAME, PROTECTION, 2 PERMENANT, ERROR_RETURN )6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30C@C Set up virtual address space for data accesses by the process ?C Establishes a relationship (via SPECIAL) between this processC and interface buffer. C 0 CALL gLU$SETBUF ( VCSID, SPECIAL, ERROR_RETURN )0 IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) GO TO 30C@C Set appropriate initialization flag to indicate initializationC processing is in progress.C> CALL LU$INTFLG ( VCSID, SET_FLAG, SPECIAL(4), ERROR_RETURN )C6 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCRC Read initialization record from the VGEN initialization file (VGEN.DAT) for the 8C processing parameters necessary to start this process.=C This record contains all VGEN inhformation for this process,.C including process specidific data file name.C RECORD_NUMBER = 0 FILE_NUMBER = 0C0 CALL LR$GETREC ( VCSID, FILE_NAME, RECORD_NAME, 2 FILE_NUMBER, RECORD_NUMBER,$ 2 INITREC, SPECIAL, ERROR_RETURN )C5 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCEC Validate record by comparing passed VCS ID and the corresponding IDHC in the initialization record; If the ID's are not equal, the record is7C invalid and an appropriate error return is iindicated.C0 IF ( INITREC ( SYC$_VCSIDNM ) .NE. VCSID ) ThenC* ERROR_RETURN ( 1 ) = DMS$_ILL_VCS ERROR_RETURN ( 2 ) = 0 GO TO 30C ENDIFC CJC Set priority to the priority specified in the VGEN initialization recordC+ CALL LU$SETPRI( INITREC( SYC$_PRIOFFSET) )>C Clear initialization flag indicating initialization completeC 20 CONTINUE? CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SjUCCESS ) GO TO 30CC@C Wait for system startup flag (event flag #64) to be set before?C continuing to synchronize the startup of all system software.C; CALL LU$WAITFR ( VCSID, EVENT_FLAG_NUMBER, ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30C8 STATUS = LIB$GET_LUN(INFO_LUN) ! Allocate Unit Number+ IF (.NOT. STATUS) THEN ! If Error, then2 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROkR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 GET_LUN_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! GOTO 30 ! Quit END IF !-----------------= SEC_LEN = ((%LOC(ANY_CURRENT_CONTROLS) ! Calculate Size for@ 2 - %LOC(TBL_PTR) + 2 + 511) / 512) + 1 ! the Global Section.> ! last addr - first addr + length of last element + 511 / 512, OPEN ( UNIT = INFO_LUN, ! Open Dummy File) 2 FILE = 'ACTIVITY.TBL', ! That will be& 3 STATUS = 'NEW', ! Mapped into the, 4 INIlTIALSIZE = SEC_LEN, ! Global Section. 5 USEROPEN = UFO_CREATE ) ! CLOSE (INFO_LUN) !C C Create Global Section and Map C ACTIVITY.TBL into the SectionC4 SEC_MASK = SEC$M_WRT .OR. SEC$M_DZRO .OR. SEC$M_GBL6 PASS_ADDR(1) = %LOC(TBL_PTR) ! Beginning of SectionB PASS_ADDR(2) = %LOC(ANY_CURRENT_CONTROLS) ! End of Global Section6 STATUS = SYS$CRMPSC( PASS_ADDR, ! Create and Map the! 2 RET_ADDR, ! Global Section. 2 , ! 2 %VAL(SEC_MASK), ! Mask+ 2 'ACTIVITY_TBL 'm, ! Global Section Name 2 ,, !) 2 %VAL(SEC_CHAN),,,,) ! Channel Number+ IF (.NOT. STATUS) THEN ! If Error, then1 ERROR_RETURN(1) = DMS$_SYS_SRV ! Set VMS Error, ERROR_RETURN(2) = STATUS ! Set Error Code, CALL LU$ERROR( VCSID, ! Signal the Error 2 ERROR_RETURN, ! 2 CRMPSC_ERR, ! 2 SPECIAL, ! 2 ERROR_RETURN ) ! GOTO 30 ! Quit END IF !-----------------C&C Normal return; set up success statusC" ERROR_RETURN ( 1 ) = DMS$_SUCCESS ERRnOR_RETURN ( 2 ) = 0CC Purge working set pagesC$ CALL LU$PURGWS (VCSID,ERROR_RETURN) GO TO 40C2C Error return insure that the init flag is reset.C<30 CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERR_RTN )C 40 RETURN ENDww+** M M F S _ I N* PROGRAM MMFS_IN# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'2 INTEGER*4 ERROR_RETURN(2) ! VECTOR Error Status( BYTE MMFS_QUE(12) ! Input Queue Name, 2 /'M','M','F','S','_','Q','U','E',4*' '/ !2 I oNTEGER*4 MMFS_QUE_NUM /0/ ! Vector Queue Number+ INTEGER*2 OPTIONS_MAX ! Options List Max PARAMETER (OPTIONS_MAX = 4) !1 CHARACTER*25 OPTION(OPTIONS_MAX) ! Options List" BYTE PRCNAM(12) ! Process Name2 2 /'D','A','$','M','M','F','S','_','I','N',2*' '/* CHARACTER*4 QUIT /'QUIT'/ ! Quit Command+ INTEGER*2 SEL_LEN /4/ ! Selection Length+ INTEGER*2 SEL_NUM /0/ ! Selection Number) CHARACTER*4 SELECTION ! Menu Selection/ INTEGER*4 SPECIAL(5) ! VECTOR Special Fields- INTEGpER*4 STATUS ! Function Return Status, INTEGER*4 VCSID /762/ ! VECTOR Program ID% INTEGER*4 X ! Horizontal Position# INTEGER*4 Y ! Vertical PositionC C D a t aC DATA OPTION 1 /'1. Open Virtual Circuit ', 2 '2. Close Virtual Circuit', 3 '3. Send a Control ',! 4 '4. Send a Scan List ' /CC F u n c t i o n sC1 INTEGER*4 CLOSE_VIRTUAL_CIRCUIT ! Close Routine+ INTEGER*4 LIB$GET_INPUT ! Get User Input/ INTEGER*4 OPEN_VIRTUAL_CIRCUIT ! Oqpen Routine. INTEGER*4 OTS$CVT_TU_L ! Convert Str to Int+ INTEGER*4 SEND_CONTROL ! Control Routine* INTEGER*4 SEND_SCAN ! Scan List Routine* INTEGER*4 STR$UPCASE ! Convert To UpperCC I n i t i a l i z a t i o nC7 CALL DA$SIMINT( VCSID, ! Initialization using VCSID, 2 PRCNAM, ! Process Name, 2 SPECIAL, ! Special Fields,) 2 ERROR_RETURN ) ! Error Return Status CALL BEGIN ! Crt Setup X = 5C C M a i n P r o c e s s i n gC750 DO WHILE (SELECTIrON(1:SEL_LEN) .NE. QUIT(1:SEL_LEN))! CALL CRTCL ! Clear Crt Screen Y = 103 DO I = 1,OPTIONS_MAX ! For the Number of Options !# CALL PLACE(X,Y) ! Draw the Menu& CALL SWRT(LEN(OPTION(I)),OPTION(I)) ! Y = Y + 2 ! ! END DO !' CALL PLACE(X,20) ! Get the Selection7 STATUS = LIB$GET_INPUT(SELECTION,'Selection ',SEL_LEN). IF (.NOT. STATUS) CALL EXIT ! If error, Quit/ IF (SEL_LEN .EQ. 0) CALL EXIT ! If null, Quit= STATUS = STR$UPCASE(SELECTIONs,SELECTION)! Make all UppercaseD STATUS = OTS$CVT_TU_L(SELECTION(1:SEL_LEN),SEL_NUM,%VAL(2),%VAL(1)); IF ((SEL_NUM .GE. 1) .OR. (SEL_NUM .LE. OPTIONS_MAX)) THEN! GOTO (100,200,300,400), SEL_NUM END IF>58 IF (STATUS) CALL LQ$PUTQUE(VCSID, ! Put to the Queue, VCSID 1 MMFS_QUE, ! Queue Name 2 MFS$_ENTRY, ! Data Buffer 3 40, ! Buffer Length! 4 MMFS_QUE_NUM, ! Queue Number% 5 SPECIAL, ! Special Offset Buffer- 6 ERROR_RETURN ) ! Error Return for Vector END DO t !" CALL EXIT ! Quit When Finished1100 STATUS = OPEN_VIRTUAL_CIRCUIT( MFS$_QUE_NAME, 1 MFS$_IO_TIMEOUT, 2 MFS$_PORT, 3 MFS$_VC, 4 MFS$_LOGICAL_NAME ) MFS$_REQUEST = 1 MFS$_QUE_LENGTH = 32 GOTO 582200 STATUS = CLOSE_VIRTUAL_CIRCUIT( MFS$_QUE_NAME, 1 MFS$_IO_TIMEOUT, 2 MFS$_PORT, 3 MFS$_VC, 4 MFS$_LOGICAL_NAME ) MFS$_REQUEST = 2 MFS$_QUE_LENGTH = 32 GOTO 58)300 STATUS = SEND_CONTROL( MFS$_QUE_NAME, 1 MFS$_IO_TIMEOUT, 2 MFS$_uOUTPUT_CHNL, 3 MFS$_CTL_REC_ID, 4 MFS$_DATA_REC_ID, 5 MFS$_NUM_OF_CODES, 6 MFS$_HOST_CODES ) MFS$_REQUEST = 4 MFS$_QUE_LENGTH = 244 GOTO 58400 STATUS = SEND_SCAN() GOTO 58 END *** O p e n V i r t u a l C i r c u i t*8 INTEGER*4 FUNCTION OPEN_VIRTUAL_CIRCUIT(RESPONSE_QUEUE, 1 IO_TIMEOUT, 2 PORT, 3 VIRTUAL_CIRCUIT, 4 LOGICAL_NAME )% INTEGER*2 IO_TIMEOUT ! I/O Timeout+ INTEGER*4 LIB$GET_INPUT ! Get User Input. INTEGER*4v OTS$CVT_TU_L ! Convert Str to Int BYTE PORT ! Port Number' INTEGER*2 RESP_LEN ! RESPONSE Length) CHARACTER*16 SPACES ! Spaces & Blanks# INTEGER*4 STATUS ! Error Status) CHARACTER*8 STRING ! Character String* BYTE VIRTUAL_CIRCUIT ! Virtual Circuit STRUCTURE /WORK/ UNION MAP CHARACTER*8 STR END MAP MAP BYTE BYTES(8) END MAP END UNION END STRUCTURE RECORD /WORK/ RESPONSE_QUEUE STRUCTURE /WRK/ UNION MAP CHARACTER*16 STR END MAP MAPw BYTE BYTES(16) END MAP END UNION END STRUCTURE RECORD /WRK/ LOGICAL_NAME SPACES = ' ' CALL CRTCL CALL PLACE(5,10), STATUS = LIB$GET_INPUT( RESPONSE_QUEUE.STR, 1 'Response Queue ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT> RESPONSE_QUEUE.STR = RESPONSE_QUEUE.STR(1:RESP_LEN) // SPACES CALL PLACE(5,12) STATUS = LIB$GET_INPUT( STRING, 1 'I/O Timeout Period ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_xLEN), ! Convert String 1 IO_TIMEOUT, ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,14) STATUS = LIB$GET_INPUT( STRING, 1 'Port ', 2 RESP_LEN ) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String 1 PORT, ! to Integer 2 %VAL(1), ! One Byte Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,16) STATUS = LIB$GET_INPUT( STRING, 1 'Virtual Circuit ', 2 RESP_LEN ) IF y(.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String" 1 VIRTUAL_CIRCUIT, ! to Integer 2 %VAL(1), ! One Byte Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,18)* STATUS = LIB$GET_INPUT( LOGICAL_NAME.STR, 1 'Circuit Logical Name ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT: LOGICAL_NAME.STR = LOGICAL_NAME.STR(1:RESP_LEN) // SPACES#32767 OPEN_VIRTUAL_CIRCUIT = STATUS RETURN END *,* C l o s e V i r t u a l C i r c u i tz*9 INTEGER*4 FUNCTION CLOSE_VIRTUAL_CIRCUIT(RESPONSE_QUEUE, 1 IO_TIMEOUT, 2 PORT, 3 VIRTUAL_CIRCUIT, 4 LOGICAL_NAME )% INTEGER*2 IO_TIMEOUT ! I/O Timeout+ INTEGER*4 LIB$GET_INPUT ! Get User Input. INTEGER*4 OTS$CVT_TU_L ! Convert Str to Int BYTE PORT ! Port Number' INTEGER*2 RESP_LEN ! RESPONSE Length) CHARACTER*16 SPACES ! Spaces & Blanks# INTEGER*4 STATUS ! Error Status) CHARACTER*8 STRING ! Character String* BYTE VIRTUAL_CIRCUIT "{ ! Virtual Circuit STRUCTURE /WORK/ UNION MAP CHARACTER*8 STR END MAP MAP BYTE BYTES(8) END MAP END UNION END STRUCTURE RECORD /WORK/ RESPONSE_QUEUE STRUCTURE /WRK/ UNION MAP CHARACTER*16 STR END MAP MAP BYTE BYTES(16) END MAP END UNION END STRUCTURE RECORD /WRK/ LOGICAL_NAME SPACES = ' ' CALL CRTCL CALL PLACE(5,10), STATUS = LIB$GET_INPUT( RESPONSE_QUEUE.STR, 1 'Response Queue ', 2 RESP_LEN) IF (.NOT. STATUS)| CALL EXIT> RESPONSE_QUEUE.STR = RESPONSE_QUEUE.STR(1:RESP_LEN) // SPACES CALL PLACE(5,12) STATUS = LIB$GET_INPUT( STRING, 1 'I/O Timeout Period ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String 1 IO_TIMEOUT, ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,14) STATUS = LIB$GET_INPUT( STRING, 1 'Port ', 2 RESP_LEN ) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CV}T_TU_L( STRING(1:RESP_LEN), ! Convert String 1 PORT, ! to Integer 2 %VAL(1), ! One Byte Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,16) STATUS = LIB$GET_INPUT( STRING, 1 'Virtual Circuit ', 2 RESP_LEN ) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String" 1 VIRTUAL_CIRCUIT, ! to Integer 2 %VAL(1), ! One Byte Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,18)* STATUS = LIB$GET_INPUT( LOGICAL_NAME.STR, 1~ 'Circuit Logical Name ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT: LOGICAL_NAME.STR = LOGICAL_NAME.STR(1:RESP_LEN) // SPACES$32767 CLOSE_VIRTUAL_CIRCUIT = STATUS RETURN END ** S e n d C o n t r o l*1 INTEGER*4 FUNCTION SEND_CONTROL( RESPONSE_QUEUE, 1 IO_TIMEOUT, 2 OUTPUT_CHANNEL, 3 CONTROL_REC, 4 DATABASE_REC, 5 NUMBER_OF_CONTROLS, 6 CONTROL )# INTEGER*2 CONTROL(96) ! Controls, INTEGER*4 DISPLAY_BITS ! Display the Bits% I NTEGER*2 IO_TIMEOUT ! I/O Timeout+ INTEGER*4 LIB$GET_INPUT ! Get User Input+ INTEGER*4 LIB$SYS_FAO ! Formatted Output3 INTEGER*2 NUMBER_OF_CONTROLS ! Number of Controls. INTEGER*4 OTS$CVT_TU_L ! Convert Str to Int. INTEGER*4 OTS$CVT_TZ_L ! Control Hex to Int, INTEGER*2 OUTPUT_CHANNEL ! Output Channel CHARACTER*12 PROMPT ! Prompt' INTEGER*2 RESP_LEN ! RESPONSE Length+ CHARACTER*16 SPACES ! Spaces and Blanks$ INTEGER*4 STATUS ! Return Status) CHARACTER*8 STRING " ! Character String# INTEGER*4 STR$UPCASE ! Uppercase* BYTE VIRTUAL_CIRCUIT ! Virtual Circuit CHARACTER*3 YES ! 'YES' STRUCTURE /WORK/ UNION MAP CHARACTER*8 STR END MAP MAP BYTE BYTES(8) END MAP END UNION END STRUCTURE RECORD /WORK/ RESPONSE_QUEUE STRUCTURE /CR/ UNION MAP CHARACTER*12 STR END MAP MAP BYTE BYTES(12) END MAP END UNION END STRUCTURE RECORD /CR/ CONTROL_REC STRUCTURE /DB/ UNION MAP CHARACTER*12 STR END MAP MAP BYTE BYTES(12) END MAP END UNION END STRUCTURE RECORD /DB/ DATABASE_REC SPACES = ' ' YES = 'YES' CALL CRTCL CALL PLACE(5,4), STATUS = LIB$GET_INPUT( RESPONSE_QUEUE.STR, 1 'Response Queue ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT> RESPONSE_QUEUE.STR = RESPONSE_QUEUE.STR(1:RESP_LEN) // SPACES CALL PLACE(5,6) STATUS = LIB$GET_INPUT( STRING, 1 'I/O Timeout Period ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String 1 IO_TIMEOUT, ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,8)) STATUS = LIB$GET_INPUT( CONTROL_REC.STR, 1 'Control Record Id ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT8 CONTROL_REC.STR = CONTROL_REC.STR(1:RESP_LEN) // SPACES CALL PLACE(5,10)* STATUS = LIB$GET_INPUT( DATABASE_REC.STR, 1 'Database Record Id ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT: DATABASE_REC.STR = DATABASE_REC.STR(1:RESP_LEN) // SPACES CALL PLACE(5,12) STATUS = LIB$GET_INPUT( STRING, 1 'Output Channel Offset ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String" 1 OUTPUT_CHANNEL, ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero CALL PLACE(5,14) STATUS = LIB$GET_INPUT( STRING, 1 'Number of Controls ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TU_L( STRING(1:RESP_LEN), ! Convert String% 1 NUMBER_OF_CONTROLS, ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero CALL CRTCL I = 1% DO WHILE (I .LE. NUMBER_OF_CONTROLS)( STATUS = LIB$SYS_FAO( 'Control !UL. ',, 1 PROMPT, 2 %VAL(I) ) CALL PLACE(5,2) STATUS = LIB$GET_INPUT( STRING, 1 PROMPT, 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT< STATUS = OTS$CVT_TZ_L( STRING(1:RESP_LEN), ! Convert String 1 CONTROL(I), ! to Integer 2 %VAL(2), ! One Word Long! 3 %VAL(1) ) ! Blanks Are Zero" STATUS = DISPLAY_BITS(CONTROL(I)) CALL PLACE(5,23)/ CALL SWRT(30,' ') CALL PLACE(5,23) STATUS = LIB$GET_INPUT( STRING, 1 'Is This Correct? ', 2 RESP_LEN) IF (.NOT. STATUS) CALL EXIT% STATUS = STR$UPCASE( STRING, STRING)2 IF (STRING(1:RESP_LEN) .EQ. YES(1:RESP_LEN)) THEN I = I + 1 END IF END DO32767 SEND_CONTROL = STATUS RETURN END** S e n d S c a n* INTEGER*4 FUNCTION SEND_SCAN INTEGER*4 STATUS$ PRINT *,'No Function Available Yet'32767 SEND_SCAN = STATUS RETURN END + SUBROUTINE DA$SIMINT( VCSID, RECORD_NAME,  2 SPECIAL, ERROR_RETURN ) IMPLICIT INTEGER (A-Z)CIC Sysint.par contains the paramters and definitions with the syc$_ prefixC" INCLUDE 'SYS$INCLUDE:SYSINT.PAR'CIC Syserr.par contains the parameters and definitions of the error returnsC" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'CJC Dainit.par contains the parameters and definitions with the da$i_ prefixC" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'CJC Dmscom.par contains the parameters and definitions with the dms$_ prefixC" INCLUDE 'SYS$INCLUDE:DMSCOM.PAR'C HC======================================================================  C!C Define the subprocess variablesC, BYTE FILE_NAME ( DA$I_FILE_NAME_LENGTH )- BYTE RECORD_NAME ( DA$I_RECORD_NAME_LENGTH )( DATA FILE_NAME / 'V','G','E','N',8*' '/ DIMENSION INITREC( SYC$_IRSIZE)C9C Define record as integer for the initialization routineC INTEGER*4 FILE_NUMBER INTEGER*4 RECORD_NUMBER INTEGER*4 ERROR_RETURN ( 2 ) INTEGER*4 SPECIAL ( 5 ) INTEGER*4 ERR_RTN(2)  CCC Associate with system event flags cluster to reference the systemC startup flag (#64).CC+ CALL LU$ASCEFC ( VCSID, EVENT_FLAG_NUMBER,( 2 EVENT_FLAG_CLUSTER_NAME, PROTECTION, 2 PERMENANT, ERROR_RETURN )6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30C@C Set up virtual address space for data accesses by the process ?C Establishes a relationship (via SPECIAL) between this processC and interface buffer. C 0 CALL LU$SETBUF ( VCSID, SPECIAL, ERROR_RETURN )0 IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) GO TO 30C@C Set appropriate initialization flag to indicate initializationC processing is in progress.C> CALL LU$INTFLG ( VCSID, SET_FLAG, SPECIAL(4), ERROR_RETURN )C6 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCRC Read initialization record from the VGEN initialization file (VGEN.DAT) for the 8C processing parameters necessary to start this process.=C This record contains all VGEN information for this process,.C including process specidific data file name.C RECORD_NUMBER = 0 FILE_NUMBER = 0C0 CALL LR$GETREC ( VCSID, FILE_NAME, RECORD_NAME, 2 FILE_NUMBER, RECORD_NUMBER,$ 2 INITREC, SPECIAL, ERROR_RETURN )C5 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCEC Validate record by comparing passed VCS ID and the corresponding IDHC in the initialization record; If the ID's are not equal, the record is7C invalid and an appropriate error return is indicated.C0 IF ( INITREC ( SYC$_VCSIDNM ) .NE. VCSID ) ThenC* ERROR_RETURN ( 1 ) = DMS$_ILL_VCS ERROR_RETURN ( 2 ) = 0 GO TO 30C ENDIFC CJC Set priority to the priority specified in the VGEN initialization recordC+ CALL LU$SETPRI( INITREC( SYC$_PRIOFFSET) )>C Clear initialization flag indicating initialization completeC 20 CONTINUE? CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC@C Wait for system startup flag (event flag #64) to be set before?C continuing to synchronize the startup of all system software.C; CALL LU$WAITFR ( VCSID, EVENT_FLAG_NUMBER, ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC&C Normal return; set up success statusC" ERROR_RETURN ( 1 ) = DMS$_SUCCESS ERROR_RETURN ( 2 ) = 0CC Purge working set pagesC$ CALL LU$PURGWS (VCSID,ERROR_RETURN) GO TO 40C2C Error return insure that the init flag is reset.C<30 CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERR_RTN )C 40 RETURN ENDww* * M M F S _ R E A D _ Q U E U E* PROGRAM MMFS_READ_QUEUE# INCLUDE 'SYS$INCLUDE:MMFSQUE.PAR'" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'2 INTEGER*4 ERROR_RETURN(2) ! VECTOR Error Status( B YTE MMFS_QUE(12) ! Input Queue Name, 2 /'M','M','F','S','_','Q','U','E',4*' '/ !2 INTEGER*4 MMFS_QUE_NUM /0/ ! Vector Queue Number+ INTEGER*2 OPTIONS_MAX ! Options List Max PARAMETER (OPTIONS_MAX = 4) !1 CHARACTER*25 OPTION(OPTIONS_MAX) ! Options List" BYTE PRCNAM(12) ! Process Name4 2 /'D','A','$','M','M','F','S','_','R','E','A','D'/* CHARACTER*4 QUIT /'QUIT'/ ! Quit Command+ INTEGER*2 SEL_LEN /4/ ! Selection Length+ INTEGER*2 SEL_NUM /0/ ! Selection Number) CHARACTER*4 SELECTION ! Menu Selection/ INTEGER*4 SPECIAL(5) ! VECTOR Special Fields- INTEGER*4 STATUS ! Function Return Status CHARACTER*32 STR ! String, INTEGER*4 VCSID /762/ ! VECTOR Program ID% INTEGER*4 X ! Horizontal Position# INTEGER*4 Y ! Vertical PositionCC F u n c t i o n sC+ INTEGER*4 LIB$GET_INPUT ! Get User Input. INTEGER*4 OTS$CVT_TU_L ! Convert Str to Int* INTEGER*4 STR$UPCASE ! Convert To UpperCC I n i t i a l i z a t i o nC7 CALL DA$SIMINT( VCSID, ! Initialization using VCSID, 2 PRCNAM, ! Process Name, 2 SPECIAL, ! Special Fields,) 2 ERROR_RETURN ) ! Error Return Status CALL BEGIN ! Crt Setup! CALL CRTCL ! Clear Crt Screen X = 5C C M a i n P r o c e s s i n gC750 DO WHILE (SELECTION(1:SEL_LEN) .NE. QUIT(1:SEL_LEN)) Y = 10' CALL PLACE(X,20) ! Get the Selection? STATUS = LIB$GET_INPUT(SELECTION,'Read Queue (Y,N): ',SEL_LEN). IF (.NOT. STATUS) CALL EXIT ! If error, Quit/ IF (SEL_LEN .EQ. 0) CALL EXIT ! If null, Quit= STATUS = STR$UPCASE(SELECTION,SELECTION)! Make all Uppercase558 CALL LQ$GETQUE( VCSID, ! Put to the Queue, VCSID 1 MMFS_QUE, ! Queue Name 2 MFS$_ENTRY, ! Data Buffer 3 BYTES, ! Buffer Length! 4 MMFS_QUE_NUM, ! Queue Number% 5 SPECIAL, ! Special Offset Buffer- 6 ERROR_RETURN ) ! Error Return for Vector, IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) THEN PRINT *,'No More Entries' SELECTION = 'QUIT' END IF DO I = 1,32 STR(I:I) = CHAR(MFS$_ENTRY(I)) END DO CALL PLACE(X,Y) PRINT *,STR END DO !" CALL EXIT ! Quit When Finished END + SUBROUTINE DA$SIMINT( VCSID, RECORD_NAME,  2 SPECIAL, ERROR_RETURN ) IMPLICIT INTEGER (A-Z)CIC Sysint.par contains the paramters and definitions with the syc$_ prefixC" INCLUDE 'SYS$INCLUDE:SYSINT.PAR'CIC Syserr.par contains the parameters and definitions of the error returnsC" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'CJC Dainit.par contains the parameters and definitions with the da$i_ prefixC" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'CJC Dmscom.par contains the parameters and definitions with the dms$_ prefixC" INCLUDE 'SYS$INCLUDE:DMSCOM.PAR'C HC======================================================================  C!C Define the subprocess variablesC, BYTE FILE_NAME ( DA$I_FILE_NAME_LENGTH )- BYTE RECORD_NAME ( DA$I_RECORD_NAME_LENGTH )( DATA FILE_NAME / 'V','G','E','N',8*' '/ DIMENSION INITREC( SYC$_IRSIZE)C9C Define record as integer for the initialization routineC INTEGER*4 FILE_NUMBER INTEGER*4 RECORD_NUMBER INTEGER*4 ERROR_RETURN ( 2 ) INTEGER*4 SPECIAL ( 5 ) INTEGER*4 ERR_RTN(2)  CCC Associate with system event flags cluster to reference the systemC startup flag (#64).CC+ CALL LU$ASCEFC ( VCSID, EVENT_FLAG_NUMBER,( 2 EVENT_FLAG_CLUSTER_NAME, PROTECTION, 2 PERMENANT, ERROR_RETURN )6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30C@C Set up virtual address space for data accesses by the process ?C Establishes a relationship (via SPECIAL) between this processC and interface buffer. C 0 CALL LU$SETBUF ( VCSID, SPECIAL, ERROR_RETURN )0 IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) GO TO 30C@C Set appropriate initialization flag to indicate initializationC processing is in progress.C> CALL LU$INTFLG ( VCSID, SET_FLAG, SPECIAL(4), ERROR_RETURN )C6 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCRC Read initialization record from the VGEN initialization file (VGEN.DAT) for the 8C processing parameters necessary to start this process.=C This record contains all VGEN information for this process,.C including process specidific data file name.C RECORD_NUMBER = 0 FILE_NUMBER = 0C0 CALL LR$GETREC ( VCSID, FILE_NAME, RECORD_NAME, 2 FILE_NUMBER, RECORD_NUMBER,$ 2 INITREC, SPECIAL, ERROR_RETURN )C5 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCEC Validate record by comparing passed VCS ID and the corresponding IDHC in the initialization record; If the ID's are not equal, the record is7C invalid and an appropriate error return is indicated.C0 IF ( INITREC ( SYC$_VCSIDNM ) .NE. VCSID ) ThenC* ERROR_RETURN ( 1 ) = DMS$_ILL_VCS ERROR_RETURN ( 2 ) = 0 GO TO 30C ENDIFC CJC Set priority to the priority specified in the VGEN initialization recordC+ CALL LU$SETPRI( INITREC( SYC$_PRIOFFSET) )>C Clear initialization flag indicating initialization completeC 20 CONTINUE? CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC@C Wait for system startup flag (event flag #64) to be set before?C continuing to synchronize the startup of all system software.C; CALL LU$WAITFR ( VCSID, EVENT_FLAG_NUMBER, ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC&C Normal return; set up success statusC" ERROR_RETURN ( 1 ) = DMS$_SUCCESS ERROR_RETURN ( 2 ) = 0CC Purge working set pagesC$ CALL LU$PURGWS (VCSID,ERROR_RETURN) GO TO 40C2C Error return insure that the init flag is reset.C<30 CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERR_RTN )C 40 RETURN ENDww`e** M M F S _ T I M E R*CC Needs Options File on Link.C PSECT_ATTR = GBL, PAGEC IMPLICIT NONE< DICTIONARY 'CDD$TOP.USER.X25_REC/LIST' ! X25 Master  Mailbox) RECORD /MBX/ X25 ! X25 Master Mailbox7 DICTIONARY 'CDD$TOP.USER.MMFS_REC/LIST' ! MMFS Mailbox% RECORD /MMFS/ MMFS ! MMFS Mailbox- INCLUDE '($SECDEF)' ! Global Section Defs8 INTEGER*2 ANY_CURRENT_CONTROLS ! # of Current Controls' CHARACTER*13 ASCTIM /'0 00:00:01.00'/* INTEGER*4 BINTIM(2) ! VMS Time Quadword0 INTEGER*2 CTL(1024) ! Ptr to Current Controls1 BYTE CURRENT_CONTROLS(1024) ! Current Controls7 INTEGER*2 CURRENT_CONTROLS_MAX ! Maximum Virtual Crct * PARAMETER (CURRENT_CONTROLS_MAX = 1024) !/ INTEGER*4 FILE_NUM(200) ! VECTOR File Number INTEGER*2 I ! Counter INTEGER*2 J ! Counter. BYTE QUEUE_NAME(12,200) ! VECTOR Queue Name3 INTEGER*4 RECORD_NUM(200) ! VECTOR Record Number( INTEGER*2 TBL_PTR /0/ ! Table Pointer( INTEGER*2 TIMER(200) ! Timeout Values3 INTEGER*2 TRANS_NUMBER(200) ! Transaction Numbers+ INTEGER*2 SEC_CHAN ! Global Section Chnl+ INTEGER*4 SEC_MASK ! Global Section Mask1 INTEGER*4 PASS_ADDR(2) ! Addresses for Section0 INTEGER*4 RET_ADDR(2) ! Addresses for Section$ INTEGER*4 STATUS ! Return Status* INTEGER*4 REQUEST_FLAG /70/ ! Event Flag+ BYTE REQUEST_TYPE(200) ! Request Numbers' INTEGER*4 INFO_FLAG /71/ ! Event FlagCC F u n c t i o n sC. INTEGER*4 SYS$ASCEFC ! Associate Event Flag& INTEGER*4 SYS$BINTIM ! Get the Time" INTEGER*4 SYS$HIBER ! Hibernate, INTEGER*4 SYS$MGBLSC ! Map Global Section) INTEGER*4 SYS$SCHDWK ! Schedule Wakeup' INTEGER*4 SYS$SETEF ! Set Event Flag- INTEGER*4 SYS$WAITFR ! Wait For Event FlagCC C o m m o n B l o c k sC1 COMMON /CHANNEL/ SEC_CHAN ! Global Section ChnlCC G l o b a l C o m m o nC0 COMMON /GBL/ TBL_PTR, ! Array Element Pointer( 2 TRANS_NUMBER, ! Transaction Number 3 QUEUE_NAME, ! Queue Name 4 TIMER, ! How Many Minutes 5 FILE_NUM, ! File Number! 6 RECORD_NUM, ! Record Number" 7 REQUEST_TYPE, ! Request Type 8 X25, ! X25 Mailboxes% 9 CTL,  ! Ptr to Current Controls) 9 CURRENT_CONTROLS, ! Current Controls1 9 ANY_CURRENT_CONTROLS ! # of Current Controls; STATUS = SYS$BINTIM(ASCTIM,BINTIM) ! Get the Current Time? IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Quit if Error.4 STATUS = SYS$ASCEFC(%VAL(REQUEST_FLAG),'CLUSTER',,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)))C STATUS = SYS$WAITFR(%VAL(REQUEST_FLAG))1C IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))6 PASS_ADDR(1) = %LOC(TBL_PTR) ! Get Starting Address? PASS_ADDR(2) = %LOC(ANY_CURRENT_CONTROLS) ! Get Ending Address, SEC_MASK = SEC$M_WRT ! Glbl Section Mask6 STATUS = SYS$MGBLSC( PASS_ADDR, ! Address of Section 2 RET_ADDR, ! Address Mapped 3 , !$ 4 %VAL(SEC_MASK), ! Section Mask& 5 'ACTIVITY_TBL ',,) ! Section Name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))*100 DO WHILE (.TRUE.) !**** L o o p **** I = 0- DO WHILE (I .LE. TBL_PTR)!*** L o o p **** I = I + 1 ! Incr Counter% J = TRANS _NUMBER(I) ! Get Pointer, IF (TIMER(J) .GT. 0) THEN ! If no Timeout/ TIMER(J) = TIMER(J) - 1 ! Decrement Seconds ELSE ! Else,9 TRANS_NUMBER(I) = TRANS_NUMBER(TBL_PTR) ! Get Rid of it+ TBL_PTR = TBL_PTR - 1 ! Decrement Table# TIMER(J) = -1 ! Flag the Entry END IF ! IF (TIMER(J) .GT0 IF (I .GE. TBL_PTR) I = TBL_PTR ! Keep Bounds# END DO !**** E n d l o o p ****7C STATUS = SYS$SETEF(%VAL(INFO_FLAG)) ! Set Event FlagDC IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Signal any Error2 STATUS = SYS$SCHDWK(,BINTIM,) ! Schedule Wakeup> IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Quit if Error$ STATUS = SYS$HIBER() ! Hibernate&198 END DO !**** E n d l o o p **** ENDww)Ǐ PROGRAM PASSADMIN** P A S S A D M I N* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' INCLUDE '($SYIDEF)'CC F U N C T I O N SC* INTEGER*4 SYS$GETSYIW ! Get System Info$ CHARACTER*15 NODENAME ! Node Name/ INTEGER*2 NODENAME_LEN ! Length of Node Name. INTEGER*2 NUMBER_OF_NODES ! Number of Nodes- INTEGER*4 STATUS ! Function Return StatusC$C I / O S t a t u s B l o c k sC+ STRUCTURE /STATUS_BLOCK/ !---------------. INTEGER*2 IOSTAT, MSG_LEN ! IO Status Block INTEGER*4 READER_PID ! END STRUCTURE !1 RECORD /STATUS_BLOCK/ IOSTATUS !--------------- STRUCTURE /IOSBLK/ INTEGER*4 STS, RESERVED END STRUCTURE RECORD /IOSBLK/ IOSBC3C S y s t e m S e r v i c e I t e m L i s t sC STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE RECORD /ITMLST/ GETSYI_LIST(2)C0C G e t C l u s t e r I n f o r m a t i o nC GETSYI_LIST(1).BUFLEN = 15& GETSYI_LIST(1).ITMCOD = SYI$_NODENAME' GETSYI_LIST(1).BUFADR = %LOC(NODENAME)+ GETSYI_LIST(1).RETADR = %LOC(NODENAME_LEN) GETSYI_LIST(2).END_LIST = 0, STATUS = SYS$GETSYIW(,,,GETSYI_LIST,IOSB,,) IF (STATUS) STATUS = IOSB.STS0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" PRINT *, NODENAME(1:NODENAME_LEN)C0C G e t C l u s t e r I n f o r m a t i o nC GETSYI_LIST(1).BUFLEN = 2+ GETSYI_LIST(1).ITMCOD = SYI$_CLUSTER_NODES. GETSYI_LIST(1).BUFADR = %LOC(NUMBER_OF_NODES) GETSYI_LIST(1).RETADR = 0 GETSYI_LIST(2).END_LIST = 0, STATUS = SYS$GETSYIW(,,,GETSYI_LIST,IOSB,,) IF (STATUS) STATUS = IOSB.STS0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))+ PRINT *,'Number of nodes=',NUMBER_OF_NODES ENDww`+lǏ INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB COMMON /RAB / RAB INTEGER*2 CHAN INTEGER*2 IOSB(4) INTEGER*4 STATUS INTEGER*4 SYS$QIOW INTEGER*4 FUNC INTEGER*4 LEN INTEGER*4 RECNUM INTEGER*4 SYS$FLUSH CHARACTER*128 LOG_RECORD(4) EXTERNAL UFO_OPEN FUNC = IO$_READVBLK OPEN ( UNIT = 1, 2 NAME = 'PWLOG.DAT', 2 STATUS = 'NEW', 2 CARRIAGECONTROL = 'FORTRAN', 2 USEROPEN= UFO_OPEN ) DO 10 I=1,365) WRITE ( 1,'(A)') ' This is just a test.' 10 CONTINUE STATUS = SYS$FLUSH(RAB,,) ACCEPT *,I32767 CLOSE ( UNIT = 1) END) INTEGER*4 FUNCTION UFO_OPEN(FAB,RAB,LUN) INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB COMMON /RAB/ RAB INTEGER*2 CHAN INTEGER*4 STATUS INT#EGER*4 SYS$OPEN=C FAB.FAB$L_FOP = FAB.FAB$L_FOP .OR. FAB$M_UFO .OR. FAB$M_DFW/C FAB.FAB$L_FOP = FAB.FAB$L_FOP .AND. FAB$M_DFW STATUS = SYS$OPEN(FAB) UFO_OPEN = STATUS ENDwwٖ%Y** N U M B E R S* PROGRAM NUMBERS IMPLICIT NONE CHARACTER*64 HEX_STR INTEGER*2 I INTEGER*2 J INTEGER*4 LIB$GET_INPUT INTEGER*4 OTS$CVT_L_TZ INTEGER*4 STATUS  STRUCTURE /WORK/ UNION MAP CHARACTER*12 DATA END MAP MAP INTEGER*4 LU(3) END MAP END UNION END STRUCTURE RECORD /WORK/ WORK5 STATUS = LIB$GET_INPUT(WORK.DATA,'Enter 12 Bytes ',) IF (.NOT. STATUS) CALL EXIT DO J = 1, 3: STATUS = OTS$CVT_L_TZ(WORK.LU(J),HEX_STR,%VAL(2),%VAL(4)) DO I = 1,64$ IF (HEX_STR(I:I) .NE. ' ') GOTO 100 END DO1100 PRINT *, WORK.LU(J),' ''',HEX_STR(I:64),'''X' END DO ENDww Nf,C privilege definitions (converted to masks) * Parameter PRV$M_Cmkrnl = '00000001'X) Parameter PRV$M_World = '00010000'X* Parameter PRV$M_Sysprv = '10000000'X c FAB offsets for user open" Parameter FAB$B_ACMODES = 74" Parameter FAB$V_LNM_MODE = 0 c CLI return codes, Parameter CLI$_Defaulted = '0003FD21'Xwwo PROGRAM PASSADMIN** P A S S A D M I N* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($OPCDEF)' INCLUDE '($PSLDEF)' INCLUDE '($SYIDEF)'CC R e c o r d L a y o u t sC) STRUCTURE /PW/ ! Password File Layout UNION ! MAP !$ CHARACTER*31 USERNAME ! Username$ CHARACTER*31 PASSWORD ! Password' INTEGER*4 PRIVILEGE(2) ! Privileges$ BYTE LOGGED_ON ! Logged On Flag1 CHARACTER*20 LOGGED_NODES ! Node Logged In On2 CHARACTER*20 EXCLUDE_NODES ! Nodes Not Allowed4 CHARACTER*20 TEMP_NODES ! Temporary Access Nodes: INTEGER*4 EXPIRATION_DATE(2) ! Password Expiration Date8 INTEGER*2 PASSWORD_LIFE ! # of Days For the Password END MAP ! MAP !' CHARACTER*62 USERPASS ! Key to File# CHARACTER*8 PRIVS ! Privileges END MAP ! MAP !# CHARACTER*31 FILLER ! Username) CHARACTER*4 EMP_NO ! Employee Number END MAP ! MAP !, CHARACTER*256 RECORD ! The Whole Record END MAP ! END UNION ! END STRUCTURE !% RECORD /PW/ PW ! Record Name is PWCC F U N C T I O N SC) INTEGER*4 LIB$ADDX ! Routine For Dates) INTEGER*4 LIB$DATE_TIME ! Current Time( INTEGER*4 LIB$GET_EF ! Get Even t Flag* INTEGER*4 LIB$GET_LUN ! Get Unit Number* INTEGER*4 LIB$FREE_EF ! Free Event Flag) INTEGER*4 LIB$SUBX ! Routine For Dates* INTEGER*4 OTS$CVT_L_TU ! Cvt Int to Str1 INTEGER*4 STR$FIND_FIRST_IN_SET ! String Search* INTEGER*4 SYS$ASSIGN ! Assign a Channel0 INTEGER*4 SYS$BINTIM ! Binary Time Conversion( INTEGER*4 SYS$CREMBX ! Create Mailbox* INTEGER*4 SYS$DASSGN ! Deassign Channel( INTEGER*4 SYS$DELMBX ! Delete Mailbox* INTEGER*4 SYS$GETSYIW ! Get System Info1 INT EGER*4 SYS$GETTIM ! Get Current Binary Time+ INTEGER*4 SYS$PURGWS ! Purge Working Set) INTEGER*4 SYS$QIOW ! Queue I/O Request* INTEGER*4 SYS$SNDOPR ! Send to Operator$ INTEGER*4 SYS$SYNCH ! Synchronize- INTEGER*4 SYS$WAITFR ! Wait For Event Flag' EXTERNAL READ_MBX ! Read the Mailbox CHARACTER* (*) MBX_NAME+ PARAMETER (MBX_NAME = 'PASSWORDADMIN.DAT')) CHARACTER*15 CUSTOMER ! User's Mailbox1 CHARACTER*111 MBX_MESSAGE ! Mailbox Msg Buffer- CHARACTER*23 CURRENT_TIME_S ! Current Time$ CHARACTER*15 NODENAME ! Node Name( CHARACTER*124 LOG_RECORD ! Log Record% CHARACTER*1 MODE ! Execution Mode ! 0 - Other ! 1 - Network ! 2 - Batch ! 3 - Interactive/ CHARACTER*11 LOGINOUT ! Login/Logout Message& CHARACTER*40 TEXT ! Text Work Area* CHARACTER*23 DELTA ! Delta Time String2 CHARACTER*23 PASS_EXPIRES ! Password Expiration/ CHARACTER*256 RECORD_SAVE ! Record Hold Area3 CHARACTER*20 LOGFILE_NAME ! Name of the Log File& CHARACTER*2 CRLF ! Return/Linefeed* INTEGER READ_CODE ! Read Function Bits, INTEGER WRITE_CODE ! Write Function Bits& INTEGER ITS_A_LOGOUT ! Logout Flag' INTEGER*2 MBX_CHAN ! Mailbox Channel* INTEGER*2 CUS_CHAN ! User's MBX Channel/ INTEGER*2 NODENAME_LEN ! Length of Node Name. INTEGER*2 NUMBER_OF_NODES ! Number of Nodes- INTEGER*4 STATUS ! Function Return Status7 INTEGER*4 RANGE(2) /0,'7FFFFFFF'X/ ! Working Set Range, INTEGER*4 MESSA GE_LEN ! Length of Message- INTEGER*4 PASSFILE ! Channel for Passwords. INTEGER*4 ERRFILE ! Channel for Error File, INTEGER*4 LOGFILE ! Channel for Log File& INTEGER*4 ACMODE ! MBX Access Mode INTEGER*4 AST_FLAG ! AST Flag+ INTEGER*4 CURRENT_TIME(2) ! Integer Time0 INTEGER*4 DISPLACEMENT(2) ! Time Displacement& INTEGER*4 ZERO(2) /0,0/ ! Two Zeros* INTEGER*4 MBX_PROT ! Mailbox Protection% INTEGER*4 TODAY ! Days since Base) INTEGER*4 EXPIRE_DAY ! Days since BaseC$C I / O S t a t u s B l o c k sC+ STRUCTURE /STATUS_BLOCK/ !---------------. INTEGER*2 IOSTAT, MSG_LEN ! IO Status Block INTEGER*4 READER_PID ! END STRUCTURE !1 RECORD /STATUS_BLOCK/ IOSTATUS !--------------- STRUCTURE /IOSBLK/ INTEGER*4 STS, RESERVED END STRUCTURE RECORD /IOSBLK/ IOSBC3C S y s t e m S e r v i c e I t e m L i s t sC STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR  INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE RECORD /ITMLST/ GETSYI_LIST(2) STRUCTURE /MESSAGE/ UNION MAP BYTE TYPE ! Request Code% BYTE TARGET(3) ! Who it Goes to% INTEGER*4 RQSTID ! Message Code, CHARACTER*85 TEXT ! Message to Console END MAP ! MAP !+ CHARACTER*99 MESSAGE ! Message Buffer END MAP END UNION END STRUCTURE RECORD /MESSAGE/ OPCC C o m m o n B l o c kC COMMON /MBX_DATA/ MBX_CHAN, 2 MBX_MESSAGE, 2 IOSTAT, 2 MESSAGE_LEN, 2 STATUS, 2 READ_CODE, 2 MSG_LEN, 2 READER_PID, 2 IOSTATUS8 CRLF = CHAR(13) // CHAR(10) ! Carriage Return/Linefeed& ACMODE = PSL$C_USER ! Set User Mode, OP.TYPE = OPC$_RQ_RQST ! Set Request Code5 OP.TARGET(1) = OPC$M_NM_CLUSTER ! Cluster Operators# OP.RQSTID = 1 ! User DeterminedCC G e t N o d e N a m eC GETSYI_LIST(1).BUFLEN = 15& GETSYI_LIST(1).ITMCOD = SYI$_NODENAME' GETSYI_LIST(1).BUFADR = %LOC(NODENAME)+ GETSYI_LIST(1).RETADR = %LOC(NODENAME_LEN) GETSYI_LIST(2).END_LIST = 0, STATUS = SYS$GETSYIW(,,,GETSYI_LIST,IOSB,,) IF (STATUS) STATUS = IOSB.STS0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC C r e a t e M a i l b o xC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox! 2 MBX_CHAN, ! Chnl For Mailbox" 2 %VAL(111), ! Max Message Size 2 ,,ACMODE, ! Access Mode 2 MBX_NAME) ! Logical Name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C S e t M B X P r o t e c t i o nC* READ_CODE = IO$_SETMODE .OR. IO$M_SETPROT9 MBX_PROT = 32768 .OR. 8192 .OR. 4096 ! World: Read Write STATUS = SYS$QIOW(, !" 2 %VAL(MBX_CHAN), ! MBX Channel% 2 %VAL(READ_CODE), ! Set Protection" 2 IOSTATUS,,, ! IO Status Block$ 2 ,MBX_PROT,,,,) ! MBX Protection0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C O p e n P a s s w o r d F i l eC: STATUS = LIB$GET_LUN(PASSFILE) ! Get Logical Unit Number. IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) OPEN ( UNIT = PASSFILE, 2 NAME = 'PASS:PW.IDX', 2 ORGANIZATION = 'INDEXED', 2 RECORDTYPE = 'FIXED', 2 ACCESS = 'KEYED', 2 STATUS = 'OLD', 2 KEY = (1:62), 2 SHARED )CC O p e n L o g F i l eC9 STATUS = LIB$GET_LUN(LOGFILE) ! Get Logical Unit Number. IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) LOGFILE_NAME = 'PASS:PWLOG' //& 2 NODENAME(1:NODENAME_LEN) // '.DAT' OPEN ( UNIT = LOGFILE, 2 NAME = LOGFILE_NAME, 2 RECL = 124, 2 FORM = 'UNFORMATTED', 2 CARRIAGECONTROL = 'FORTRAN', 2 STATUS = 'NEW', 2 SHARED )C C O p e n E r r o r F i l eC:D STATUS = LIB$GET_LUN(ERRFILE) ! Get Logical Unit Number/D IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))D OPEN ( UNIT = ERRFILE,D 2 NAME = 'SYS$ERROR',D 2 STATUS = 'NEW', D 2 SHARED )C C L o o pC100 DO WHILE (.TRUE.)0 LOG_RECORD(1:124) = ' ' ! Clean Up Log Record5 ISTAT = SYS$PURGWS(%REF(RANGE)) ! Purge Working Set, IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))! CALL READ_MBX ! Read Mail Box&D WRITE (ERRFILE,'(1X,A)') MBX_MESSAGE8 IF (MBX_MESSAGE(1:8) .EQ. 'passstop') ! If told to quit 2 THEN ! then" GOTO 900 ! Go close File, etc. END IF. CUSTOMER = MBX_MESSAGE(1:15) ! Who are they?, PW.USERNAME = MBX_MESSAGE(17:47) ! Username, PW.PASSWORD = MBX_MESSAGE(48:78) ! Password, MODE = MBX_MESSAGE(80:80) ! Execution Mode ! 0 - Other ! 1 - Network ! 2 - Batch ! 3 - Interactive0 MBX_MESSAGE(1:4) = PW.EMP_NO ! Employee NumberC"C G e t C u r r e n t T i m eC' STATUS = LIB$DATE_TIME(CURRENT_TIME_S)C C I s I t A L o g o u t ?C ITS_A_LOGOUT = 0+ IF (MBX_MESSAGE(55:65) .EQ. 'Logging Off') 2 THEN ITS_A_LOGOUT = 1 LOGINOUT = 'Logging Out' READ( UNIT = PASSFILE, 2 KEYGE = PW.USERPASS, 2 KEYID = 0, 2 ERR = 350 ) PW/ IF (PW.EMP_NO .NE. MBX_MESSAGE(1:4)) GOTO 1455 STATUS = STR$FIND_FIRST_IN_SET(PW.LOGGED_NODES,' ') IF (STATUS .LE. 1) THEN PW.LOGGED_NODES(1:20) = ' ' IF (PW.LOGGED_ON .LE. 1) THEN PW.LOGGED_ON = 0 ELSE# PW.LOGGED_ON = PW.LOGGED_ON - 1 END IF GOTO 135 END IF IF (PW.LOGGED_ON .LE. 1) THEN PW.LOGGED_ON = 0 ELSE" PW.LOGGED_ON = PW.LOGGED_ON - 1 END IF1 STATUS = STR$FIND_FIRST_IN_SET(PW.LOGGED_NODES, 2 NODENAME(1:NODENAME_LEN)) IF (STATUS .LE. 0) GOTO 135 PW.LOGGED_NODES(STATUS:20) =- 2 PW.LOGGED_NODES(STATUS+NODENAME_LEN+1:20) 2 // ' '" GOTO 135 ! Write Logout Record END IF& IF (MBX_MESSAGE(16:16) .EQ. '*') THEN DELTA(1:23) = ' '* STATUS = OTS$CVT_L_TU( PW.PASSWORD_LIFE, 2 DELTA(1:5), 2 %VAL(1), 2 %VAL(4) )1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))& DELTA = DELTA(1:5) // ' 00:00:00.00') STATUS = SYS$BINTIM(DELTA,DISPLACEMENT)1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))# STATUS = SYS$GETTIM(CURRENT_TIME) STATUS = LIB$SUBX( ZERO, 2 DISPLACEMENT, 2 DISPLACEMENT )1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" STATUS = LIB$ADDX( DISPLACEMENT, 2 CURRENT_TIME, 2 PW.EXPIRATION_DATE)1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) RECORD_SAVE = PW.RECORD* RECORD_SAVE(32:62) = MBX_MESSAGE(81:111)+ WRITE (UNIT=PASSFILE,ERR=370) RECORD_SAVE READ ( UNIT = PASSFILE, 2 KEY = PW.USERPASS, 2 KEYID = 0, 2 ERR = 370 ) PW.RECORD" DELETE( UNIT = PASSFILE,ERR=370) PW.RECORD = RECORD_SAVE END IFC3C G e t # O f N o d e s O n C l u s t e rC130 GETSYI_LIST(1).BUFLEN = 2+ GETSYI_LIST(1).ITMCOD = SYI$_CLUSTER_NODES. GETSYI_LIST(1).BUFADR = %LOC(NUMBER_OF_NODES) GETSYI_LIST(1).RETADR = 0 GETSYI_LIST(2).END_LIST = 0, STATUS = SYS$GETSYIW(,,,GETSYI_LIST,IOSB,,) IF (STATUS) STATUS = IOSB.STS0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C R e a d P a s s w o r d F i l eC LOGINOUT = 'Logging In ' READ ( UNIT = PASSFILE, 2 KEY = PW.USERPASS, 2 KEYID = 0, 2 ERR = 200) PW.RECORD= IF (MBX_MESSAGE(16:16) .EQ. '*') GOTO 132 ! Is it a Change? STATUS = INDEX(2 2 PW.EXCLUDE_NODES(1:20), ! Is this guy allowed- 2 NODENAME(1:NODENAME_LEN)) ! on this node?* IF (STATUS .GT. 0) ! If not allowed on 2 THEN ! this node, then/ MBX_MESSAGE(15:20) = 'DENIED' ! deny access. GOTO 148 END IF" STATUS = SYS$GETTIM(CURRENT_TIME)1 STATUS = LIB$DAY(EXPIRE_DAY,PW.EXPIRATION_DATE,)& STATUS = LIB$DAY(TODAY,CURRENT_TIME,) IF (TODAY .GE. EXPIRE_DAY) THEN MBX_MESSAGE(15:21) = 'EXPIRED' GOTO 148 END IF132 IF (PW.LOGGED_ON .GE. 126) 2 THEN PW.LOGGED_ON = 127 ELSE! PW.LOGGED_ON = PW.LOGGED_ON + 1 END IF4 STATUS = STR$FIND_FIRST_IN_SET(PW.LOGGED_NODES,' ')5 IF (STR$FIND_FIRST_IN_SET(PW.LOGGED_NODES(1:STATUS),$ 2 NODENAME(1:NODENAME_LEN)) .GT. 0) 2 THEN+ OP.TEXT = PW.USERNAME // ' ' ! Username* 2 // PW.EMP_NO // ' ' ! Employee Number+ 2 // CURRENT_TIME_S // ' ' ! Current Time+ 2 // 'Logged On More Than Once' ! Message9 STATUS = SYS$SNDOPR(%DESCR(OP.MESSAGE),)! Tell Operator GOTO 135 ! Skip Node Accntg END IF  IF ((STATUS .GT. 0) .AND.( 2 (STATUS .LT. LEN(PW.LOGGED_NODES)-4)) 2 THEN- PW.LOGGED_NODES(STATUS:STATUS+NODENAME_LEN)% 2 = NODENAME(1:NODENAME_LEN) // '\' END IF135 REWRITE(UNIT = PASSFILE, 2 ERR = 300) PW.RECORD%140 UNLOCK( UNIT = PASSFILE, ERR=145)3145 LOG_RECORD = PW.USERNAME // ' ' // ! Username& 2 PW.EMP_NO // ' ' // ! Emp Number$ 2 CURRENT_TIME_S // ' ' // ! Time* 2 CUSTOMER(4:11) // ' ' // ! Job Number- 2 NODENAME(1:NODENAME_LEN) // ' ' // ! Node 2 LOGINOUT ! In or Out146 WRITE ( UNIT = LOGFILE, 2 IOSTAT = STATUS, 2 ERR = 360) LOG_RECORD147 IF (ITS_A_LOGOUT) 2 THEN GOTO 197 END IF MBX_MESSAGE(5:111) = ' ' 148 MBX_MESSAGE(6:13) = PW.PRIVSC"C S e t u p R e t u r n M B XC,150 STATUS = SYS$ASSIGN(CUSTOMER,CUS_CHAN,,) IF (.NOT. STATUS) GOTO 197CC W r i t e M e s s a g eC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW MESSAGE_LEN = 80' STATUS = SYS$QIOW(, ! Set Event Flag( 2 %VAL(CUS_CHAN), ! Their MBX Channel$ 2 %VAL(WRITE_CODE), ! Write It Now 2 IOSTATUS, ! IO Status Block 2 ,, !$ 2 %REF(MBX_MESSAGE), ! The Message) 2 %VAL(MESSAGE_LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)): STATUS = SYS$DELMBX(%VAL(CUS_CHAN)) ! Delete User Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))8 STATUS = SYS$DASSGN(%VAL(CUS_CHAN)) ! Deassign User MBX'197 UNLOCK( UNIT = PASSFILE, ERR = 198) 198 END DOCC E r r o r O n R e a dC200 MBX_MESSAGE(1:111) = ' ' MBX_MESSAGE = 'No Match' GOTO 150C&C E r r o r L o g g i n g U s e rC.300 OP.TEXT = PW.USERNAME // ' ' ! Username* 2 // PW.EMP_NO // ' ' ! Employee Number+ 2 // CURRENT_TIME_S // ' ' ! Current Time+ 2 // NODENAME(1:NODENAME_LEN) ! Node Name9 STATUS = SYS$SNDOPR(%DESCR(OP.MESSAGE),) ! Tell Operator GOTO 140.350 OP.TEXT = PW.USERNAME // ' ' ! Username* 2 // PW.EMP_NO // ' ' ! Employee Number+ 2 // CURRENT_TIME_S // ' ' ! Current Time+ 2 // NODENAME(1:NODENAME_LEN) ! Node Name9 STATUS = SYS$SNDOPR(%DESCR(OP.MESSAGE),) ! Tell Operator GOTO 140.360 OP.TEXT = PW.USERNAME // ' ' ! Username* 2 // PW.EMP_NO // ' ' ! Employee Number+ 2 // CURRENT_TIME_S // ' ' ! Current Time+ 2 // NODENAME(1:NODENAME_LEN) ! Node Name9 STATUS = SYS$SNDOPR(%DESCR(OP.MESSAGE),) ! Tell Operator GOTO 147.370 OP.TEXT = PW.USERNAME // ' ' ! Username* 2 // PW.EMP_NO // ' ' ! Employee Number+ 2 // CURRENT_TIME_S // ' ' ! Current Time+ 2 // NODENAME(1:NODENAME_LEN) ! Node Name 2 // 'PW NoChange'9 STATUS = SYS$SNDOPR(%DESCR(OP.MESSAGE),) ! Tell Operator GOTO 130CC E n d P r o c e s s i n gC'900 CLOSE (PASSFILE) ! Close PW File% CLOSE (LOGFILE) ! Close Log File6 STATUS = SYS$DELMBX(%VAL(MBX_CHAN)) ! Delete Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) END INTEGER*4 FUNCTION READ_MBX** R E A D _ M B X* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' INTEGER*4 SYS$QIOW INTEGER STATUS INTEGER MESSAGE_LEN INTEGER READ_CODE CHARACTER*111 MBX_MESSAGE INTEGER*2 MBX_CHAN, STRUCTURE /STATUS_BLOCK/ !----------------- INTEGER*2 IOSTAT, MSG_LEN ! IO Status Block INTEGER*4 READER_PID ! END STRUCTURE !2 RECORD /STATUS_BLOCK/ IOSTATUS !---------------- COMMON /MBX_DATA/ MBX_CHAN, 2 MBX_MESSAGE, 2 IOSTAT, 2 MESSAGE_LEN, 2 STATUS, 2 READ_CODE, 2 MSG_LEN, 2 READER_PID, 2 IOSTATUSCC R e a d M B XC READ_CODE = IO$_READVBLK MESSAGE_LEN = 1111 STATUS = SYS$QIOW(,%VAL(MBX_CHAN), ! MBX Channel 2 %VAL(READ_CODE), ! Read Code& 2 %REF(IOSTATUS), ! IO Status Block 2 ,, ! 2 %REF(MBX_MESSAGE), ! Message) 2 %VAL(MESSAGE_LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" IF ((.NOT. IOSTATUS.IOSTAT) .AND.- 2 (IOSTATUS.IOSTAT .NE. SS$_ENDOFFILE)) THEN( CALL LIB$SIGNAL(%VAL(IOSTATUS.IOSTAT)) END IF( READ_MBX = SS$_NORMAL ! Say it's Okay RETURN ENDww~o PROGRAM PASSDELMBX** P A S S D E L M B X* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' CHARACTER* (*) MBX_NAME+ PARAMETER (MBX_NAME = 'PASSWORDADMIN.DAT') INTEGER AST_FLAG PARAMETER (AST_FLAG = 2) INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$CREMBX INTEGER*4 SYS$QIOW INTEGER*4 SYS$DELMBX INTEGER STATUS INTEGER READ_CODE INTEGER*2 MBX_CHAN INTEGER*4 ACMODE ACMODE = PSL$C_USER/ STATUS = SYS$CREMBX(%VAL(1),MBX_CHAN,%VAL(80), 2 ,,ACMODE,MBX_NAME)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))$ STATUS = SYS$DELMBX(%VAL(MBX_CHAN))0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ENDwwo** P A S S L O G O U T* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($JPIDEF)' INCLUDE '($PSLDEF)' CHARACTER* (*) MBX_NAME+ PARAMETER (MBX_NAME = 'PASSWORDADMIN.DAT') INTEGER*4 GET_PRIV INTEGER*4 STR$FIND_FIRST_IN_SET2 INTEGER*4 STR$TRANSLATE ! Translate Str Routine INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$CREMBX INTEGER*4 SYS$DELPRC/ INTEGER*4 SYS$GETJPIW ! Get Job Info Routine INTEGER*4 SYS$QIOW STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 READER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUS INTEGER WRITE_CODE INTEGER*2 MBX_CHAN$ INTEGER*4 STATUS ! Return Status+ INTEGER*4 USERNAME_LEN ! Username Length INTEGER*4 LEN INTEGER*4 ACMODE CHARACTER*31 USERNAME CHARACTER*80 MBX_MESSAGE CHARACTER*8 PROC_ID CHARACTER*15 MY_MBX CHARACTER*4 EMP_NO CHARACTER*64 PRIVS- CHARACTER*1 TRANSL_FR ! Translate From Str+ CHARACTER*1 TRANSL_TO ! Translate To Str, STRUCTURE /ITMLST/ ! Item List for GETJPI UNION ! MAP !$ INTEGER*2 BUFLEN ! Buffer Length INTEGER*2 ITMCOD ! Item Code% INTEGER*4 BUFADR ! Buffer Address% INTEGER*4 RETADR ! Return Address END MAP ! MAP !# INTEGER*4 END_LIST ! End of List END MAP ! END UNION !( END STRUCTURE !____________________4 RECORD /ITMLST/ JPI_LIST(2) ! Record of Item List TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space1 JPI_LIST(1).BUFLEN = 12 ! Username is 12 Lon g8 JPI_LIST(1).ITMCOD = JPI$_USERNAME ! Get Username Code< JPI_LIST(1).BUFADR = %LOC(USERNAME) ! Location of Username; JPI_LIST(1).RETADR = %LOC(USERNAME_LEN) ! Length Returned) JPI_LIST(2).END_LIST = 0 ! End of List8 ISTAT = SYS$GETJPIW(,,,JPI_LIST,,,) ! Get The Username= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check Status; ISTAT = STR$TRANSLATE( USERNAME(1:31), ! Convert Username% 2 USERNAME(1:31), ! changing null) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check Status( CALL GETPID(PROC_ID) ! Get Process ID, ACMODE = PSL$C_USER ! Access Mode for MBX STATUS = GET_PRIV(EMP_NO,PRIVS) IF (.NOT. STATUS) 2 THEN CALL LIB$SIGNAL(%VAL(STATUS)) END IF MBX_MESSAGE(1:80) = ' ' MBX_MESSAGE(4:11) = PROC_ID MBX_MESSAGE(17:47) = USERNAME MBX_MESSAGE(48:52) = EMP_NO# MBX_MESSAGE(55:65) = 'Logging Off'CC C r e a t e M B XC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox) 2 MBX_CHAN, ! Chnl assigned to mailbox% 2 %VAL(80), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MBX_NAME) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC W r i t e T o M B XC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW LEN = 80# STATUS = SYS$QIOW(, ! Event Flag" 2 %VAL(MBX_CHAN), ! MBX Channel" 2 %VAL(WRITE_CODE), ! Write Code 2 IOSTATUS, ! IO Status Block 2 ,, ! AST Routine Params$ 2 %REF(MBX_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ENDww@3o** P A S S S T O P* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($PSLDEF)' INCLUDE '($JPIDEF)' INCLUDE '($PRVDEF)' CHARACTER* (*) MBX_NAME+ PARAMETER (MBX_NAME = 'PASSWORDADMIN.DAT') CHARACTER* (*) PRG_PASSWORD% PARAMETER (PRG_PASSWORD = 'MERCURY') INTEGER LIB$GET_INPUT INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF INTEGER*4 READ_NOECHO INTEGER*4 STR$FIND_FIRST_IN_SET2 INTEGER*4 STR$TRANSLATE ! Translate Str Routine INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$CREMBX INTEGER*4 SYS$DELPRC INTEGER*4 SYS$GETJPIW INTEGER*4 SYS$QIOW INTEGER*4 SYS$SETEF STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 READER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUS STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE RECORD /ITMLST/ JPI_LIST(2) INTEGER WRITE_CODE INTEGER READ_CODE INTEGER*2 MBX_CHAN INTEGER*2 PROT_MASK /16/ INTEGER*2 RES_LEN INTEGER*4 ATTRIBUTES INTEGER*4 MODE INTEGER*4 PASSWORD_LEN( INTEGER*2 IOSB(4) ! I/O Status Block$ INTEGER*4 STATUS ! Return Status+ INTEGER*4 USERNAME_LEN ! Username Length INTEGER*4 LEN INTEGER*4 ACMODE INTEGER*4 MBX_PROT INTEGER*4 AST_FLAG INTEGER*4 SYSPRIVS(2) CHARACTER*80 MBX_MESSAGE CHARACTER*80 RET_MESSAGE CHARACTER*8 PROC_ID CHARACTER*15 MY_MBX CHARACTER*31 RESNAM& CHARACTER*11 TABLNAM /'LNM$PROCESS'/1 CHARACTER*21 PARENTABL /'LNM$PROCESS_DIRECTORY'/" CHARACTER*8 LOGLNAM /'SYS$PRIV'/- CHARACTER*1 TRANSL_FR ! Translate From Str+ CHARACTER*1 TRANSL_TO ! Translate To Str CHARACTER*31 PASSWORD JPI_LIST( 1).BUFLEN = 8# JPI_LIST( 1).ITMCOD = JPI$_CURPRIV% JPI_LIST( 1).BUFADR = %LOC(SYSPRIVS) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).END_LIST = 0% STATUS = SYS$GETJPIW(,,,JPI_LIST,,,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)), IF (SYSPRIVS(1) .AND. PRV$M_CMKRNL) GOTO 20>C10 STATUS = LIB$GET_INPUT(PASSWORD,'Password: ',PASSWORD_LEN)A10 STATUS = READ_NOECHO('Password: ',10,PASSWORD,PASSWORD_LEN,25) IF (.NOT. STATUS) THEN LOGIN_TRIES = LOGIN_TRIES + 1 IF (LOGIN_TRIES .GE. 5) THEN STATUS = SYS$DELPRC(,) ELSE' PRINT *,'User Authorization Failure' GOTO 10 END IF END IF5 IF (PASSWORD(1:PASSWORD_LEN) .NE. PRG_PASSWORD) THEN IF (LOGIN_TRIES .GE. 5) THEN STATUS = SYS$DELPRC(,) ELSE' PRINT *,'User Authorization Failure' LOGIN_TRIES = LOGIN_TRIES + 1 GOTO 10 END IF END IF.20 ACMODE = PSL$C_USER ! Access Mode for MBX  MBX_MESSAGE(1:15) = 'passstop'CC C r e a t e M B XC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox) 2 MBX_CHAN, ! Chnl assigned to mailbox% 2 %VAL(80), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MBX_NAME) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC W r i t e T o M B XC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW LEN = 80# STATUS = SYS$QIOW(, ! Event Flag" 2 %VAL(MBX_CHAN), ! MBX Channel" 2 %VAL(WRITE_CODE), ! Write Code 2 IOSTATUS, ! IO Status Block 2 ,, ! AST Routine Params$ 2 %REF(MBX_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) 32767 ENDww`Ωo** P A S S W O R D*0* Requires (PRMMBX,SYSNAM) privileges to operate* LINK/NOTRACE* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($LNMDEF)' INCLUDE '($JPIDEF)' INCLUDE '($PSLDEF)' CHARACTER* (*) MBX_NAME+ PARAMETER (MBX_NAME = 'PASSWORDADMIN.DAT') INTEGER*4 GET_NEW_PASSWORD INTEGER*4 LIB$GET_INPUT INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF INTEGER*4 LIB$SET_LOGICAL INTEGER*4 READ_NOECHO INTEGER*4 STR$FIND_FIRST_IN_SET2 INTEGER*4 STR$TRANSLATE ! Translate Str Routine INTEGER*4 STR$UPCASE INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$CMEXEC INTEGER*4 SYS$CRELNM INTEGER*4 SYS$CRELNT INTEGER*4 SYS$CREMBX INTEGER*4 SYS$DELMBX INTEGER*4 SYS$DELPRC/ INTEGER*4 SYS$GETJPIW ! Get Job Info Routine INTEGER*4 SYS$QIOW INTEGER*4 SYS$SETEF INTEGER*4 SYS$SYNCH STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 READER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUS INTEGER WRITE_CODE INTEGER READ_CODE INTEGER*2 MBX_CHAN INTEGER*2 MY_MBX_CHAN INTEGER*2 PROT_MASK /16/ INTEGER*2 RES_LEN* INTEGER*2 ITMLST(8) /4, LNM$_STRING, 6*0/ INTEGER*4 ATTRIBUTES INTEGER*4 MODE INTEGER*4 PASSWORD_LEN INTEGER*4 NEW_WORD_LEN INTEGER*4 WAIT /30/( INTEGER*2 IOSB(4) ! I/O Status Block$ INTEGER*4 STATUS ! Return Status INTEGER*4 LOGGED_IN+ INTEGER*4 USERNAME_LEN ! Username Length INTEGER*4 LEN INTEGER*4 ACMODE INTEGER*4 MBX_PROT INTEGER*4 AST_FLAG CHARACTER*111 MBX_MESSAGE CHARACTER*80 RET_MESSAGE CHARACTER*8 PROC_ID CHARACTER*15 MY_MBX CHARACTER*31 RESNAM& CHARACTER*11 TABLNAM /'LNM$PROCESS'/1 CHARACTER*21 PARENTABL /'LNM$PROCESS_DIRECTORY'/" CHARACTER*8 LOGLNAM /'SYS$PRIV'/- CHARACTER*1 TRANSL_FR ! Translate From Str+ CHARACTER*1 TRANSL_TO ! Translate To Str CHARACTER*31 PASSWORD CHARACTER*31 NEW_WORD CHARACTER*31 USERNAME, STRUCTURE /ITMLST/ ! Item List for GETJPI UNION ! MAP !$ INTEGER*2 BUFLEN ! Buffer Length INTEGER*2 ITMCOD ! Item Code% INTEGER*4 BUFADR ! Buffer Address% INTEGER*4 RETADR ! Return Address END MAP ! MAP !# INTEGER*4 END_LIST ! End of List END MAP ! END UNION !( END STRUCTURE !____________________4 RECORD /ITMLST/ JPI_LIST(2) ! Record of Item List TRANSL_FR = CHAR(0) ! Null TRANSL_TO = ' ' ! Space1 JPI_LIST(1).BUFLEN = 12 ! Username is 12 Long8 JPI_L IST(1).ITMCOD = JPI$_USERNAME ! Get Username Code< JPI_LIST(1).BUFADR = %LOC(USERNAME) ! Location of Username; JPI_LIST(1).RETADR = %LOC(USERNAME_LEN) ! Length Returned) JPI_LIST(2).END_LIST = 0 ! End of List8 ISTAT = SYS$GETJPIW(,,,JPI_LIST,,,) ! Get The Username= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check Status; ISTAT = STR$TRANSLATE( USERNAME(1:31), ! Convert Username% 2 USERNAME(1:31), ! changing null) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check Status( CALL GETPID(PROC_ID) ! Get Process ID MY_MBX(1:3) = 'MBX' MY_MBX(4:11) = PROC_ID MY_MBX(12:15) = '.MSG' LOGIN_TRIES = 0>C10 STATUS = LIB$GET_INPUT(PASSWORD,'Password: ',PASSWORD_LEN)C10 STATUS = READ_NOECHO('Password: ',10,PASSWORD,PASSWORD_LEN,WAIT) IF (.NOT. STATUS) THEN LOGIN_TRIES = LOGIN_TRIES + 1 IF (LOGIN_TRIES .GE. 5) THEN STATUS = SYS$DELPRC(,) ELSE' PRINT *,'User Authorization Failure' PRINT *,' ' GOTO 10 END IF END IF; ISTAT = STR$TRANSLATE( PASSWORD(1:31), ! Convert Username% 2 PASSWORD(1:31), ! changing null) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.= IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) ! Check Status' STATUS = STR$UPCASE(PASSWORD,PASSWORD) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 10 END IF, ACMODE = PSL$C_USER ! Access Mode for MBX 0 CALL EXECUTION_MODE(MODE) ! Get Execution Mode MBX_MESSAGE(1:15) = MY_MBX MBX_MESSAGE(16:16) = ' '* MBX_MESSAGE(17:79) = USERNAME // PASSWORD2 MBX_MESSAGE(80:80) = CHAR(MODE) ! Execution ModeCC C r e a t e M B XC420 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox) 2 MBX_CHAN, ! Chnl assigned to mailbox& 2 %VAL(111), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MBX_NAME) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC C r e a t e M y M B XC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox, 2 MY_MBX_CHAN, ! Chnl assigned to mailbox% 2 %VAL(80), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MY_MBX) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C S e t M B X P r o t e c t i o nC* READ_CODE = IO$_SETMODE .OR. IO$M_SETPROT9 MBX_PROT = 32768 .OR. 8192 .OR. 4096 ! World: Read Write STATUS = SYS$QIOW(, !$ 2 %VAL(MY_MBX_CHAN), ! MBX Channel% 2 %VAL(READ_CODE), ! Set Protection" 2 IOSTATUS,,, ! IO Status Block$ 2 ,MBX_PROT,,,,) ! MBX Protection0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC S e t W R T A T T NC* READ_CODE = IO$_SETMODE .OR. IO$M_WRTATTN STATUS = SYS$QIOW(, !$ 2 %VAL(MY_MBX_CHAN), ! MBX Channel" 2 %VAL(READ_CODE), ! Set WRTATTN" 2 IOSTATUS,,, ! IO Status Block 2 ,,,,,) !0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC W r i t e T o M B XC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW LEN = 111# STATUS = SYS$QIOW(, ! Event Flag" 2 %VAL(MBX_CHAN), ! MBX Channel" 2 %VAL(WRITE_CODE), ! Write Code 2 IOSTATUS, ! IO Status Block 2 ,, ! AST Routine Params$ 2 %REF(MBX_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C$C R e a d T h e R e s p o n s eC READ_CODE = IO$_READVBLK LEN = 807 STATUS = SYS$QIOW(,%VAL(MY_MBX_CHAN), ! My MBX Channel 2 %VAL(READ_CODE), ! Read Code 2 IOSTATUS, ! IO Status Block 2 ,, !$ 2 %REF(RET_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" IF ((.NOT. IOSTATUS.IOSTAT) .AND.- 2 (IOSTATUS.IOSTAT .NE. SS$_ENDOFFILE)) THEN( CALL LIB$SIGNAL(%VAL(IOSTATUS.IOSTAT)) END IF< STATUS = SYS$DELMBX(%VAL(MY_MBX_CHAN)) ! Delete the Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))- IF (RET_MESSAGE(1:LEN) .EQ. 'No Match') THEN IF (LOGIN_TRIES .GE. 5) THEN STATUS = SYS$DELPRC(,) ELSE' PRINT *,'User Authorization Failure' PRINT *,' '  LOGIN_TRIES = LOGIN_TRIES + 1 GOTO 10 END IF END IF LOGGED_IN = 1 LOGIN_TRIES = 0+ IF (RET_MESSAGE(15:20) .EQ. 'DENIED') THEN PRINT *,' ') PRINT *,'Access On This Node Is Denied' STATUS = SYS$DELPRC(,) END IF.50 IF (RET_MESSAGE(15:21) .EQ. 'EXPIRED') THEN IF (LOGIN_TRIES .GT. 5) THEN STATUS = SYS$DELPRC(,) ELSE& PRINT *,'Please Enter New Password' PRINT *,' ' LOGIN_TRIES = LOGIN_TRIES + 1 END IF$ STATUS = GET_NEW_PASSWORD(PASSWORD, 2 PASSWORD_LEN, 2 NEW_WORD, 2 NEW_WORD_LEN) IF (.NOT. STATUS) GOTO 50 MBX_MESSAGE(1:15) = MY_MBX MBX_MESSAGE(16:16) = '*'* MBX_MESSAGE(17:79) = USERNAME // PASSWORD MBX_MESSAGE(80:80) = CHAR(MODE) MBX_MESSAGE(81:111)= NEW_WORD GOTO 20 END IF ITMLST(1) = 80 ITMLST(3) = %LOC(RET_MESSAGE) ATTRIBUTES = LNM$M_NO_ALIAS 2 .OR. LNM$M_CONFINE- STATUS = SYS$CRELNM( ! Create Logical Name! 2 %REF(ATTRIBUTES), ! Attribute$ 2 %DESCR(TABLNAM), ! Logical Table# 2 %DESCR(LOGLNAM), ! Logical Name# 2 %REF(PSL$C_EXEC), ! Access Mode 2 %REF(ITMLST)) ! Item List2C STATUS = LIB$SET_LOGICAL( ! Create Logical Name$C 2 %DESCR(LOGLNAM), ! Logical Name(C 2 RET_MESSAGE(1:LEN), ! Logical ValueC 2 , ! Logical Name Table$C 2 %REF(ATTRIBUTES),) ! Attributes  IF (.NOT. STATUS) 2 THEN CALL LIB$SIGNAL(%VAL(STATUS)) END IF ENDww o INTEGER*4 GET_PRIV CHARACTER*4 EMP_NO CHARACTER*64 PRIVS INTEGER*4 STATUS STATUS = GET_PRIV(EMP_NO,PRIVS) IF (.NOT. STATUS) 2 THEN CALL LIB$SIGNAL(%VAL(STATUS)) END IF PRINT *,EMP_NO PRINT *,PRIVS ENDww@f" Integer Function Priv_Close(Unit)Dc Close a system file with privilege. Needed for Files opened with(c privilege in VMS V4.2 (it is rumored)+ Include 'LES:LESTABLE(OPENCLOSEDEF)/LIST' Integer Privilege(2) /0,0/ Integer Unitc Turn on SYSPRV privilege Privilege(1) = Prv$M_Sysprv% Call Sys$Setprv(%Val(1),Privilege,,) c Close file Close( Unit = Unit )c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) Return Endww`Zf/ Integer Function Priv_UserOpen(FAB$B,RAB,Unit)%c open a system file with privilege.8c set bits in the FAB to require EXEC mode logical name8c translation to be used when opening the file and turnc SYSPRV on for the open.+ Include 'LES:LESTABLE(OPENCLOSEDEF)/LIST' Integer Privilege(2) /0,0/ Byte FAB$B(0:119) Integer RAB(30) Integer Sys$Open, Sys$Connect Integer Unit'c set Logical name access to EXEC mode1 FAB$B(FAB$B_ACMODES) = FAB$B(FAB$B_ACMODES) .or.2 1 ( (1) * 2**FAB$V_LNM_MODE) ! require EXEC modec Turn on SYSPRV privilege Privilege(1) = Prv$M_Sysprv% Call Sys$Setprv(%Val(1),Privilege,,) c open file iii = Sys$Open(FAB$B)c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) If ( .not. iii ) Then Priv_UserOpen = iii Return EndIf c connect!! Priv_UserOpen = Sys$Connect(RAB) Return Endww1Ǐ INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB INTEGER*2 CHAN INTEGER*2 IOSB(4) INTEGER*4 STATUS INTEGER*4 SYS$QIOW INTEGER*4 FUNC INTEGER*4 LEN INTEGER*4 RECNUM CHARACTER*128 LOG_RECORD(4) EXTERNAL UFO_OPEN COMMON /CHANNEL/ CHAN FUNC = IO$_READVBLK OPEN ( UNIT = 1, 2 NAME = 'PWLOG.DAT', 2 STATUS = 'OLD', 2 USEROPEN= UFO_OPEN ) LEN = 512 RECNUM = 0 STATUS = SS$_NORMAL" DO WHILE (STATUS .EQ. SS$_NORMAL) RECNUM = RECNUM + 1 STATUS = SYS$QIOW(, 2 %VAL(CHAN), 2 %VAL(FUNC), 2 IOSB,,, 2 %REF(LOG_RECORD), 2 %VAL(LEN), 2 %VAL(RECNUM),,,,)% IF ((STATUS .EQ. SS$_ENDOFFILE) .OR.+ 2 (IOSB(1).EQ. SS$_ENDOFFILE)) GOTO 327670 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) IF (.NOT. IOSB(1)) THEN CALL LIB$SIGNAL(%VAL(IOSB(1))) STATUS = IOSB(1)$ END IF PRINT *,LOG_RECORD END DO32767 CLOSE ( UNIT = 1) END) INTEGER*4 FUNCTION UFO_OPEN(FAB,RAB,LUN) INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB INTEGER*2 CHAN INTEGER*4 STATUS INTEGER*4 SYS$OPEN COMMON /CHANNEL/ CHAN- FAB.FAB$L_FOP = FAB.FAB$L_FOP .OR. FAB$M_UFO STATUS = SYS$OPEN(FAB) CHAN = FAB.FAB$L_STV UFO_OPEN = STATUS ENDww@Ǐ* * Q I O _ D I S K _ A C C E S S*& SUBROUTINE WRITE_TEMP_FILE(DATA,LAST) IMPLICIT NONE INCLUDE '($SYSSRVNAM)' INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INCLUDE '($FIDDEF)' INCLUDE '($ATRDEF)' INTEGER*4 ACP_FUNC INTEGER*4 BLOCK_NUMBER INTEGER*4 BLOCKS_ALLOCATED INTEGER*4 BUFFER INTEGER*4 CHANNEL INTEGER*4 DATA(128)' CHARACTER*12 DEVICE_NAME /'SYS$DISK:'/& INTEGER*2 FAT(16) ! File Attr Area CHARACTER*80 FILENAME_IN LOGICAL FIRST_CALL /.TRUE./ INTEGER*2 IOSB(4) LOGICAL LAST INTEGER*4 QIO_FUNC INTEGER*4 STATUS INTEGER*4 VIRTADDR RECORD /FIBDEF/ FIB RECORD /ATRDEF/ ATR(2) STRUCTURE /DESCR/ INTEGER*2 COUNT INTEGER*2 %FILL INTEGER*4 ADDR END STRUCTURE RECORD /DESCR/ NAME_IN_DESCR RECORD /DESCR/ FIB_DESCR* COMMON /WRTMP/ CHANNEL, FIB, FILENAME_IN,1 2 NAME_IN_DESCR, BLOCK_NUMBER, BLOCKS_ALLOCATED IF (FIRST_CALL) THEN FIRST_CALL = .FALSE., STATUS = SYS$ASSIGN(DEVICE_NAME,CHANNEL,,)9 IF (STATUS .NE. SS$_NORMAL ) CALL LIB$STOP(%VAL(STATUS))5 FIB.FIB$L_ACCTL = FIB$M_WRITE ! Access For Writing9 FIB.FIB$W_EXCTL = FIB$M_EXTEND ! Extend File On Create+ FIB.FIB$L_EXSZ = 10 ! Number of Blocks& ACP_FUNC = IO$_CREATE ! Create and 2 + IO$M_CREATE !$ 2 + IO$M_ACCESS ! Open the File" FILENAME_IN = 'INTERMEDIATE.DAT'0 NAME_IN_DESCR.COUNT = 16 ! Length of Filename> NAME_IN_DESCR.ADDR = %LOC(FILENAME_IN) ! Address of Filename; ATR(1).ATR$W_SIZE = ATR$S_RECATTR ! Descr For Record Attr1 ATR(1).ATR$W_TYPE = ATR$C_RECATTR ! of the File ATR(1).ATR$L_ADDR = %LOC(FAT)# FIB_DESCR.COUNT = 64 ! Full FIB FIB_DESCR.ADDR = %LOC(FIB) STATUS = SYS$QIOW( , 2 %VAL(CHANNEL), 2 %VAL(ACP_FUNC), 2 IOSB,,, 2 FIB_DESCR, 2 NAME_IN_DESCR,,, 2 ATR, )" IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$STOP(%VAL(STATUS))) ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN" CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT END IF1 BLOCKS_ALLOCATED = FIB.FIB$L_EXSZ ! Actual Size BLOCK_NUMBER = 1 ELSE. IF (BLOCK_NUMBER .GT. BLOCKS_ALLOCATED) THEN) FIB.FIB$L_EXVBN = 0 ! Must Alloc More ACP_FUNC = IO$_MODIFY' FIB.FIB$L_EXSZ = 10 ! Blocks To Add STATUS = SYS$QIOW(, 2 %VAL(CHANNEL), 2 %VAL(ACP_FUNC), 2 IOSB,,, 2 FIB_DESCR,,,,,)# IF (STATUS .NE. SS$_NORMAL) THEN! CALL LIB$SIGNAL(%VAL(STATUS)) CALL EXIT* ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN# CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT  END IF% BLOCKS_ALLOCATED = BLOCKS_ALLOCATED 2 + FIB.FIB$L_EXSZ END IF END IF QIO_FUNC = IO$_WRITEVBLK VIRTADDR = BLOCK_NUMBER STATUS = SYS$QIOW( , 2 %VAL(CHANNEL), 2 %VAL(QIO_FUNC), 2 IOSB,,, 2 DATA, 2 %VAL(512), 2 %VAL(VIRTADDR),,,)! IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$STOP(%VAL(STATUS))( ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN! CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT END IF BLOCK_NUMBER = BLOCK_NUMBER + 1+ IF (LAST) THEN  ! If Last Block To Write! ! then, Close File w/trunc. ACP_FUNC = IO$_DEACCESS FIB.FIB$W_EXCTL = FIB$M_TRUNC FIB.FIB$L_EXVBN = BLOCK_NUMBER FIB.FIB$L_EXSZ = 0' FAT(1) = 1 ! FAT$B_RTYPE Sequential* FAT(2) = 512 ! FAT$W_RSIZE Record Size/ FAT(4) = BLOCK_NUMBER ! FAT$L_HIBLK (16 LSB)5 FAT(6) = BLOCK_NUMBER ! FAT$L_EFBLK (16 LSB) (EOF) FAT(9) = 512 ! FAT$W_MAXREC STATUS = SYS$QIOW(, 2 %VAL(CHANNEL), 2 %VAL(ACP_FUNC), 2 IOSB,,, 2 FIB_DESCR,,,, 2 ATR, )" IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$SIGNAL(%VAL(STATUS)) CALL EXIT) ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN" CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT END IF END IF RETURN ENDwwi Ǐ IMPLICIT NONE INCLUDE '($SYSSRVNAM)' INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INCLUDE '($FIDDEF)' INCLUDE '($ATRDEF)' INTEGER*4 BLOCK_NUMBER INTEGER*4 BLOCKS_ALLOCATED INTEGER*4 BUFFER INTEGER*4 CHANNEL INTEGER*4 DATA(128)' CHARACTER*12 DEVICE_NAME /'SYS$DISK:'/& INTEGER*2 FAT(16) ! File Attr Area CHARACTER*80 FILENAME_IN LOGICAL FIRST_CALL /.TRUE./ INTEGER*2 IOSB(4) LOGICAL LAST INTEGER*4 QIO_FUNC INTEGER*4 STATUS INTEGER*4 VIRTADDR RECORD /FIBDEF/ FIB RECORD /ATRDEF/ ATR(2) STRUCTURE /DESCR/ INTEGER*2 COUNT INTEGER*2 %FILL INTEGER*4 ADDR END STRUCTURE RECORD /DESCR/ NAME_IN_DESCR RECORD /DESCR/ FIB_DESCR* COMMON /WRTMP/ CHANNEL, FIB, FILENAME_IN,1 2 NAME_IN_DESCR, BLOCK_NUMBER, BLOCKS_ALLOCATEDC LAST = .TRUE. CALL WRITE_TEMP_FILE(DATA,LAST) PRINT *,'DID THE CREATE' CALL READ_TEMP_FILE(DATA,LAST) PRINT *,'DONE' ENDww naǏ** Q I O _ D I S K _ R E A D*% SUBROUTINE READ_TEMP_FILE(DATA,LAST) IMPLICIT NONE INCLUDE '($SYSSRVNAM)' INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INCLUDE '($FIDDEF)' INCLUDE '($ATRDEF)' INTEGER*4 ACP_FUNC INTEGER*4 BLOCK_NUMBER INTEGER*4 BLOCKS_ALLOCATED INTEGER*4 BUFFER INTEGER*4 CHANNEL INTEGER*4 DATA(128) INTEGER*2 FAT(16) CHARACTER*80 FILENAME_IN LOGICAL FIRST_CALL /.TRUE./ INTEGER*2 IOSB(4) LOGICAL LAST INTEGER*4 QIO_FUNC INTEGER*4 STATUS INTEGER*4 VIRTADDR STRUCTURE /DESCR/ INTEGER*2 COUNT INTEGER*2 %FILL INTEGER*4 ADDR END STRUCTURE RECORD /FIBDEF/ FIB RECORD /ATRDEF/ ATR(2) RECORD /DESCR/ FIB_DESCR RECORD /DESCR/ NAME_IN_DESCR9 COMMON /WRTMP/ CHANNEL, FIB, FILENAME_IN, NAME_IN_DESCR," 2 BLOCK_NUMBER, BLOCKS_ALLOCATED IF (FIRST_CALL) THEN FIRST_CALL = .FALSE.( FIB.FIB$L_ACCTL = 0 ! The File System& FIB.FIB$W_EXCTL = 0 ! Requires That% FIB.FIB$L_EXSZ = 0 ! All of These" FIB.FIB$W_NMCTL = 0 ! Be Set To FIB.FIB$L_EXVBN = 0 ! Zero.% ACP_FUNC = IO$_ACCESS ! Access and$ 2 + IO$M_ACCESS ! Open the File.# ATR(1).ATR$W_SIZE = ATR$S_RECATTR# ATR(1).ATR$W_TYPE = ATR$C_RECATTR ATR(1).ATR$L_ADDR = %LOC(FAT) FIB_DESCR.COUNT = 64 FIB_DESCR.ADDR = %LOC(FIB) STATUS = SYS$QIOW( , 2 %VAL(CHANNEL), 2 %VAL(ACP_FUNC), 2 IOSB,,, 2 FIB_DESCR,,,, 2 ATR, )" IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$SIGNAL(%VAL(STATUS)) CALL EXIT( ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN! CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT END IF BLOCK_NUMBER = 1 END IF QIO_FUNC = IO$_READVBLK VIRTADDR = BLOCK_NUMBER STATUS = SYS$QIOW( , 2 %VAL(CHANNEL), 2 %VAL(QIO_FUNC), 2 IOSB,,, 2 DATA, 2 %VAL(512), 2 %VAL(VIRTADDR),,,)! IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$SIGNAL(%VAL(STATUS)) CALL EXIT' ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN CALL LIB$SIGNAL(%VAL(IOSB(1))) CALL EXIT END IF BLOCK_NUMBER = BLOCK_NUMBER + 1= IF (BLOCK_NUMBER .GE. FAT(6)) THEN ! FAT(6) IS 16 LSB OF EOF ! FAT$L_EFBLK% ACP_FUNC = IO$_DELETE + IO$M_DELETE STATUS = SYS$QIOW( , 2 %VAL(CHANNEL), 2 %VAL(ACP_FUNC), 2 IOSB,,, 2 FIB_DESCR,,,,,)" IF (STATUS .NE. SS$_NORMAL) THEN CALL LIB$STOP(%VAL(STATUS))( ELSE IF (IOSB(1) .NE. SS$_NORMAL) THEN CALL LIB$STOP(%VAL(IOSB(1))) END IF LAST = .TRUE. ELSE LAST = .FALSE. END IF RETURN ENDww#ǏC2C This program uses a $QIOW system service call to1C display a prompt at the terminal, and to acceptC user input without echo.C IMPLICIT INTEGER*4 (A-Z) INTEGER*2 TT_CHAN,IOSB(4)4 CHARACTER IN_STR*20, PROMPT*16 /'Enter your name '/ INCLUDE '($IODEF)'C)C Assign a channel number to the terminalC. STATUS = SYS$ASSIGN ('SYS$COMMAND',TT_CHAN,,)/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)), FUNC_CODE = IO$_READPROMPT .OR. IO$M_NOECHOC C Issue QIOWC8 STATUS = SYS$QIOW(%VAL(1),%VAL(TT_CHAN),%VAL(FUNC_CODE)$ 1 ,IOSB,,,%REF(IN_STR),%VAL(20),,, 1 %REF(PROMPT),%VAL(16))/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))1 IF (.NOT. IOSB(1)) CALL LIB$STOP (%VAL(IOSB(1))) TYPE * TYPE *, 'Hi ',IN_STR ENDww l'ǏC This procedure:C 1. Prompts for a text string4C 2. Prints a message if no input within 10 seconds.C 3. Types the string if input was completed.C IMPLICIT INTEGER*4 (A - Z)" INTEGER*2 TEXT_IOSB(4), TERM_CHAN* CHARACTER TEXT_BUF*80, TERMINAL*2 /'TT'/, 1 PROMPT_MSG*21 1 /'Enter a text string: '/ INCLUDE '($IODEF)' INCLUDE '($SSDEF)'CCC Assign a channel to TERMINAL, STATUS = SYS$ASSIGN (TERMINAL, TERM_CHAN,,)/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))) IO_FUNC = IO$_READPROMPT .OR. IO$M_TIMEDCC Prompt for the text string, STATUS = SYS$QIOW (%VAL(1),%VAL(TERM_CHAN), 1 %VAL(IO_FUNC), 1 TEXT_IOSB,,, 1 %REF(TEXT_BUF), %VAL(80), 1 %VAL(10),," 1 %REF(PROMPT_MSG), %VAL(21))/ IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))CC If I/O time-out, notify user( IF (TEXT_IOSB(1) .EQ. SS$_TIMEOUT) THEN% TYPE *, 'No message in 10 seconds.' ELSE IF (.NOT.TEXT_IOSB(1)) THEN$ CALL LIB$STOP(%VAL(TEXT_IOSB(1))) ELSE TYPE *, TEXT_BUF END IF END IF ENDwwl*Ǐ** Q U O T A _ L I S T* PROGRAM QUOTA_LIST IMPLICIT INTEGER*4 (A-Z) STRUCTURE /FILE_INFO_BLOCK/ UNION MAP BYTE FIB$L_ACCTL(3) BYTE FIB$B_WSIZE BYTE FIB$W_FID(6) BYTE FIB$W_DID(6) INTEGER*4 FIB$L_WCC INTEGER*2 FIB$W_NMCTL INTEGER*2 FIB$W_CNTRLFUNC INTEGER*4 FIB$L_CNTRLVAL INTEGER*4 FIB$L_EXVBN BYTE FIB$B_ALOPTS BYTE FIB$B_ALALIGN BYTE FIB$W_ALLOC(10) INTEGER*2 FIB$W_VERLIMIT INTEGER*2 RESERVED END MAP MAP CHARACTER*48 CHAR_FIB END MAP END UNION END STRUCTURE RECORD /FILE_INFO_BLOCK/ FIB STRUCTURE /QUOTA_BLOCK_DEF/ UNION MAP INTEGER*4 FLAGS INTEGER*2 UIC_MEMBER INTEGER*2 UIC_GROUP INTEGER*4 USAGE INTEGER*4 PERMQUOTA INTEGER*4 OVERDRAFT INTEGER*4 UNUSED(3) END MAP MAP CHARACTER*32 CHAR_QB END MAP END UNION END STRUCTURE% RECORD /QUOTA_BLOCK_DEF/ QUOTA_BLOCK CHARACTER*40 DISK INTEGER*2 CHAN INTEGER*2 IOSB(4) INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($FIBDEF)' INTEGER*4 SYS$QIOW WRITE (6,100)*100 FORMAT (1X,'Enter Disk To Access: ',$) READ (5,200) DISK_LEN, DISK200 FORMAT (Q,A)- STATUS = SYS$ASSIGN(DISK(1:DISK_LEN),CHAN,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))6 FIB.FIB$L_CNTRLVAL = FIB$M_ALL_MEM .OR. FIB$M_ALL_GRP& FIB.FIB$W_CNTRLFUNC = FIB$C_EXA_QUOTA300 STATUS = SYS$QIOW(, 2 %VAL(CHAN), 2 %VAL(IO$_ACPCONTROL), 2 IOSB,,, 2 FIB.CHAR_FIB, 2 QUOTA_BLOCK.CHAR_QB, 2 LEN, 2 QUOTA_BLOCK.CHAR_QB,,). IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)); IF (IOSB(1) .EQ. SS$_NODISKQUOTA) STOP 'END OF QUOTA LIST'0 IF (.NOT. IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))7 WRITE (6,400) ' The UIC is : ', QUOTA_BLOCK.UIC_GROUP, 2 QUOTA_BLOCK.UIC_MEMBER7 WRITE (6,500) ' Current Usage is: ', QUOTA_BLOCK.USAGE; WRITE (6,500) ' Permanent Quota : ', QUOTA_BLOCK.PERMQUOTA; WRITE (6,500) ' Overdraft Quota : ', QUOTA_BLOCK.OVERDRAFT!400 FORMAT (A, '[',O5,',',O5,']')500 FORMAT (A,I8) TYPE * GOTO 300 ENDwwSq-Ǐ2 INTEGER*4 FUNCTION READ_NOECHO(PROMPT,PROMPT_LEN,( 2 INPUT_STRING,INPUT_STRING_LEN,WAIT) IMPLICIT INTEGER*4 (A-Z) INCLUDE '($IODEF)' INTEGER*4 FUNC_CODE INTEGER*4 INPUT_STRING_LEN INTEGER*2 IOSB(4) INTEGER*4 PROMPT_LEN INTEGER*4 STATUS INTEGER*2 TT_CHAN INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$DASSGN INTEGER*4 SYS$QIOW CHARACTER*(*) INPUT_STRING CHARACTER*(*) PROMPT. STATUS = SYS$ASSIGN ('SYS$COMMAND',TT_CHAN,,) IF (.NOT. STATUS) GOTO 32767, FUNC_CODE = IO$_READPROMPT .OR. IO$M_NOECHO IF (WAIT .GT. 0) THEN' FUNC_CODE = FUNC_CODE .OR. IO$M_TIMED END IF% INPUT_STRING_LEN = LEN(INPUT_STRING) STATUS = SYS$QIOW(%VAL(1), 2 %VAL(TT_CHAN), 2 %VAL(FUNC_CODE), 2 IOSB,,, 2 %REF(INPUT_STRING), 2 %VAL(INPUT_STRING_LEN), 2 %VAL(WAIT),, 2 %REF(PROMPT), 2 %VAL(PROMPT_LEN)) IF (.NOT. STATUS) GOTO 32767 IF (.NOT. IOSB(1)) THEN STATUS = IOSB(1) GOTO 32767 END IF INPUT_STRING_LEN = IOSB(2) CALL SYS$DASSGN(%VAL(TT_CHAN)) INSL = INPUT_STRING_LEN + 1& FULL_INPUT_STRING = LEN(INPUT_STRING) DO 500 I=INSL,FULL_INPUT_STRING 500 INPUT_STRING(I:I) = CHAR(32)32767 READ_NOECHO = STATUS RETURN ENDww 1EǏ= INTEGER*4 FUNCTION READ_NUMBER(PROMPT,PROMPT_LEN,INPUT,WAIT) IMPLICIT INTEGER*4 (A-Z) INCLUDE '($IODEF)' INTEGER*4 FUNC_CODE INTEGER*4 INPUT INTEGER*2 IOSB(4) INTEGER*4 PROMPT_LEN INTEGER*4 STATUS INTEGER*2 TT_CHAN INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$DASSGN INTEGER*4 SYS$QIOW CHARACTER*(*) PROMPT. STATUS = SYS$ASSIGN ('SYS$COMMAND',TT_CHAN,,) IF (.NOT. STATUS) GOTO 32767 FUNC_CODE = IO$_READPROMPT IF (WAIT .GT. 0) THEN' FUNC_CODE = FUNC_CODE .OR. IO$M_TIMED END IF STATUS = SYS$QIOW(%VAL(1), 2 %VAL(TT_CHAN), 2 %VAL(FUNC_CODE), 2 IOSB,,, 2 %REF(INPUT), 2 , 2 %VAL(WAIT),, 2 %REF(PROMPT), 2 %VAL(PROMPT_LEN)) IF (.NOT. STATUS) GOTO 32767 IF (.NOT. IOSB(1)) THEN STATUS = IOSB(1) GOTO 32767 END IF$32767 CALL SYS$DASSGN(%VAL(TT_CHAN)) READ_PROMPT = STATUS RETURN ENDwwHǏ2 INTEGER*4 FUNCTION READ_PROMPT(PROMPT,PROMPT_LEN,( 2 INPUT_STRING,INPUT_STRING_LEN,WAIT) IMPLICIT INTEGER*4 (A-Z) INCLUDE '($IODEF)' INTEGER*4 FUNC_CODE INTEGER*4 INPUT_STRING_LEN INTEGER*2 IOSB(4) INTEGER*4 PROMPT_LEN INTEGER*4 STATUS INTEGER*2 TT_CHAN INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$DASSGN INTEGER*4 SYS$QIOW CHARACTER*(*) INPUT_STRING CHARACTER*(*) PROMPT. STATUS = SYS$ASSIGN ('SYS$COMMAND',TT_CHAN,,) IF (.NOT. STATUS) GOTO 32767 FUNC_CODE = IO$_READPROMPT IF (WAIT .GT. 0) THEN' FUNC_CODE = FUNC_CODE .OR. IO$M_TIMED END IF% INP UT_STRING_LEN = LEN(INPUT_STRING) STATUS = SYS$QIOW(%VAL(1), 2 %VAL(TT_CHAN), 2 %VAL(FUNC_CODE), 2 IOSB,,, 2 %REF(INPUT_STRING), 2 %VAL(INPUT_STRING_LEN), 2 %VAL(WAIT),, 2 %REF(PROMPT), 2 %VAL(PROMPT_LEN)) IF (.NOT. STATUS) GOTO 32767 IF (.NOT. IOSB(1)) THEN STATUS = IOSB(1) GOTO 32767 END IF INPUT_STRING_LEN = IOSB(2) CALL SYS$DASSGN(%VAL(TT_CHAN)) INSL = INPUT_STRING_LEN + 1& FULL_INPUT_STRING = LEN(INPUT_STRING) DO 500 I=INSL,FULL_IN PUT_STRING 500 INPUT_STRING(I:I) = CHAR(32)32767 READ_PROMPT = STATUS RETURN ENDww75JǏ PROGRAM REWIND* * R E W I N D* INTEGER SYS$QIOW INTEGER LIB$GET_INPUT INCLUDE '($IODEF)' INTEGER STATUS INTEGER LUN INTEGER*2 IOSTAT INTEGER*4 REWINDTAPE CHARACTER*10 TAPE INTEGER*2 TAPE_LEN5 STATUS = LIB$GET_INPUT(TAPE,'Tape Drive: ',TAPE_LEN)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))+ STATUS = SYS$ASSIGN(TAPE(1:TAPE_LEN),LUN,))  REWINDTAPE = IO$_REWIND .OR. IO$M_NOWAIT STATUS = SYS$QIOW(, 2 %VAL(LUN), 2 %VAL(REWINDTAPE), 2 IOSTAT,,,,,,,,) ENDwwKǏ PROGRAM SEEFILE INTEGER*4 STR$FIND_FIRST_IN_SET INTEGER*4 NAME_LEN INTEGER*4 LUN /1/ CHARACTER *256 FILENAME INTEGER*2 FN_SIZE LOGICAL EXIST LOGICAL OPENED CHARACTER*10 ORGANIZATION CHARACTER*9 RECORDTYPE CHARACTER*255 NAME INTEGER*4 RECL CHARACTER*20 CARRIAGCNTL CHARACTER*10 ACCESS CHARACTER*11 FORM  INTEGER*4 NEXTREC CHARACTER*7 BLANK INTEGER STATUS, LIB$GET_INPUT" STATUS = LIB$GET_INPUT (FILENAME, 2 'File to inquire about ', 2 FN_SIZE)' INQUIRE (FILE = FILENAME (1:FN_SIZE), 2 NAME = NAME, 2 EXIST = EXIST, 2 ORGANIZATION = ORGANIZATION, 2 RECORDTYPE = RECORDTYPE, 2 RECL = RECL, 2 ACCESS = ACCESS, 2 FORM = FORM, 2 NEXTREC = NEXTREC, 2 BLANK = BLANK, 2 OPENED = OPENED,! 2 CARRIAGECONTROL = CARRIAGCNTL)+ NAME_LEN = STR$FIND_FIRST_IN_SET(NAME,'  ')* IF (NAME_LEN .EQ. 0) NAME_LEN = LEN(NAME)$ PRINT *,'Name ',FILENAME(1:FN_SIZE)! PRINT *,'Name ',NAME(1:NAME_LEN) PRINT *,'Exist ',EXIST PRINT *,'Org ',ORGANIZATION PRINT *,'Rectyp ',RECORDTYPE PRINT *,'RECL ',RECL( PRINT *,'CARRIAGE CONTROL ',CARRIAGCNTL PRINT *,'Access ',ACCESS PRINT *,'Form ',FORM PRINT *,'Next Rec ',NEXTREC PRINT *,'Blank ',BLANK PRINT *,'Opened ',OPENED ENDww7Ǐ IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($SYIDEF)'. INTEGER*4 LIB$GET_FOREIGN ! Get Foreign Line INTEGER*4 LIB$SET_SYMBOL/ INTEGER*4 STR$UPCASE ! Translate To Uppercase INTEGER*4 SYS$GETSYIW STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE STRUCTURE /IOSBLK/ INTEGER*4 STS INTEGER*4 RESERVED END STRUCTURE RECORD /ITMLST/ GETSYI_LIST(4) RECORD /IOSBLK/ IOSB CHARACTER*10 COMMAND CHARACTER*15 NODENAME CHARACTER*6 NODESYMBOL INTEGER*4 COMMAND_LEN /0/ INTEGER*4 STATUS INTEGER*4 CSID INTEGER*4 CLUSTER_MEMBER INTEGER*2 DISPLAY INTEGER*2 NODENAME_LEN INTEGER*2 NUMBER_OF_NODES INTEGER*2 I GETSYI_LIST(1).BUFLEN = 15& GETSYI_LIST(1).ITMCOD = SYI$_NODENAME' GETSYI_LIST(1).BUFADR = %LOC(NODENAME)+ GETSYI_LIST(1).RETADR = %LOC(NODENAME_LEN) GETSYI_LIST(2).BUFLEN = 1, GETSYI_LIST(2).ITMCOD = SYI$_CLUSTER_MEMBER- GETSYI_LIST(2).BUFADR = %LOC(CLUSTER_MEMBER) GETSYI_LIST(2).RETADR = 0 GETSYI_LIST(3).BUFLEN = 2+ GETSYI_LIST(3).ITMCOD = SYI$_CLUSTER_NODES. GETSYI_LIST(3).BUFADR = %LOC(NUMBER_OF_NODES) GETSYI_LIST(3).RETADR = 0 GETSYI_LIST(4).END_LIST = 0 DISPLAY = 10 STATUS = LIB$GET_FOREIGN(COMMAND,,COMMAND_LEN,)5 IF ((.NOT. STATUS) .OR. (COMMAND_LEN .EQ. 0)) GOTO 5% STATUS = STR$UPCASE(COMMAND,COMMAND)9 IF (COMMAND(1:COMMAND_LEN) .EQ. 'NODISPLAY') DISPLAY = 0 5 CSID = -1 I = 010 STATUS = SYS$GETSYIW ( , 2  %REF(CSID), 2 , 2 GETSYI_LIST, 2 IOSB, 2 , 2 ) IF (STATUS) STATUS = IOSB.STS% IF (STATUS .EQ. SS$_NOMORENODE) THEN, STATUS = LIB$SET_SYMBOL('NUMBER_OF_NODES', 2 CHAR(NUMBER_OF_NODES+48) ) CALL EXIT END IF IF (.NOT. STATUS) CALL EXIT IF (DISPLAY) THEN" PRINT *,NODENAME(1:NODENAME_LEN). IF (CLUSTER_MEMBER) PRINT *,'Cluster Member' END IF I = I + 1) NODESYMBOL = 'NODE' // CHAR(I+48) // ' '= STATUS = LIB$SET_SYMBOL(NODESYMBOL,NODENAME(1:NODENAME_ LEN)) GOTO 10 ENDww鏐 IMPLICIT NONE INCLUDE '($SYSSRVNAM)' INCLUDE '($SSDEF)' CHARACTER*8 PRCNAM INTEGER*4 STATUS PRCNAM = 'E=MC' 2 // CHAR(178) // CHAR(177) 3 // CHAR(49) STATUS = SYS$SETPRN(PRCNAM) ENDwwMǏ0* Requires (PRMMBX,SYSNAM) privileges to operate* LINK/NOTRACE* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INCLUDE '($LNMDEF)' INCLUDE '($JPIDEF)' INCLUDE '($PSLDEF)' CHARACTER* (*) MBX_NAME PARAMETER (MBX_NAME = 'MAIN') CHARACTER* (*) MY_MBX PARAMETER (MY_MBX = 'SLAVE') INTEGER*4 SYS$CREMBX INTEGER*4 SYS$DELMBX INTEGER*4 SYS$QIOW STRUCTURE /STATUS_BLOCK/ INTEGER*2 IOSTAT, MSG_LEN INTEGER*4 READER_PID END STRUCTURE RECORD /STATUS_BLOCK/ IOSTATUS INTEGER WRITE_CODE INTEGER READ_CODE INTEGER*2 MBX_CHAN INTEGER*2 MY_MBX_CHAN INTEGER*2 PROT_MASK /16/( INTEGER*2 IOSB(4) ! I/O Status Block$ INTEGER*4 STATUS ! Return Status INTEGER*4 LEN INTEGER*4 ACMODE INTEGER*4 MBX_PROT INTEGER*4 AST_FLAG CHARACTER*111 MBX_MESSAGE CHARACTER*80 RET_MESSAGE, ACMODE = PSL$C_USER ! Access Mode for MBX* PRINT *,MBX_NAME,' is the Master Mailbox' PRINT *,MY_MBX,' is my Mailbox'% MBX_MESSAGE(1:15) = 'This is a test'CC C r e a t e M B XC420 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox) 2 MBX_CHAN, ! Chnl assigned to mailbox& 2 %VAL(111), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MBX_NAME) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC C r e a t e M y M B XC2 STATUS = SYS$CREMBX(%VAL(1), ! Permanent Mailbox, 2 MY_MBX_CHAN, ! Chnl assigned to mailbox% 2 %VAL(80), ! Maximum message size 2 ,,ACMODE, ! Access mode 2 MY_MBX) ! Logical name0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C&C S e t M B X P r o t e c t i o nC* READ_CODE = IO$_SETMODE .OR. IO$M_SETPROT9 MBX_PROT = 32768 .OR. 8192 .OR. 4096 ! World: Read Write STATUS = SYS$QIOW(, !$ 2 %VAL(MY_MBX_CHAN), ! MBX Channel% 2 %VAL(READ_CODE), ! Set Protection" 2 IOSTATUS,,, ! IO Status Block$ 2 ,MBX_PROT,,,,) ! MBX Protection0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC S e t W R T A T T NC* READ_CODE = IO$_SETMODE .OR. IO$M_WRTATTN STATUS = SYS$QIOW(, !$ 2 %VAL(MY_MBX_CHAN), ! MBX Channel" 2 %VAL(READ_CODE), ! Set WRTATTN" 2 IOSTATUS,,, ! IO Status Block 2 ,,,,,) !0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))CC W r i t e T o M B XC) WRITE_CODE = IO$_WRITEVBLK .OR. IO$M_NOW LEN = 111# STATUS = SYS$QIOW(, ! Event Flag" 2 %VAL(MBX_CHAN), ! MBX Channel" 2 %VAL(WRITE_CODE), ! Write Code 2 IOSTATUS, ! IO Status Block 2 ,, ! AST Routine Params$ 2 %REF(MBX_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))C$C R e a d T h e R e s p o n s eC READ_CODE = IO$_READVBLK LEN = 807 STATUS = SYS$QIOW(,%VAL(MY_MBX_CHAN), ! My MBX Channel 2 %VAL(READ_CODE), ! Read Code 2 IOSTATUS, ! IO Status Block 2 ,, !$ 2 %REF(RET_MESSAGE), ! The Message" 2 %VAL(LEN),,,,) ! Message Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))" IF ((.NOT. IOSTATUS.IOSTAT) .AND.- 2 (IOSTATUS.IOSTAT .NE. SS$_ENDOFFILE)) THEN( CALL LIB$SIGNAL(%VAL(IOSTATUS.IOSTAT)) END IF< STATUS = SYS$DELMBX(%VAL(MY_MBX_CHAN)) ! Delete the Mailbox0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,RET_MESSAGE ENDwwPǏ PROGRAM SLEEPERCC S L E E P E RCC Written by Les StocktonC May 14, 1987CC IMPLICIT INTEGER*4 (A-Z)) CHARACTER*13 ASCTIMDEF /'0 00:05:00.00'/ CHARACTER*13 ASCTIM# INTEGER*4 RANGE(2) /0,'7FFFFFFF'X/ INTEGER*4 ISTAT INTEGER*4 SYS$PURGWS INTEGER*4 SYS$SCHDWK INTEGER*4 SYS$BINTIM INTEGER*4 SYS$HIBER INTEGER*4 STR$FIND_FIRST_IN_SET INTEGER LIB$GET_INPUT INTEGER*4 BINTIM(2) INTEGER*2 ASCTIM_LEN STATUS = LIB$GET_INPUT (ASCTIM,& 2 'Wait How Long (Ex. 05:00.0) : ', 2 ASCTIM_LEN)2 IF (.NOT. STATUS ) CALL LIB$SIGNAL (%VAL(STATUS)) IF (ASCTIM_LEN .EQ. 0) THEN ASCTIM(1:13) = ASCTIMDEF(1:13) ASCTIM_LEN = 13 END IF:C STATUS = STR$FIND_FIRST_IN_SET(ASCTIM(1:ASCTIM_LEN),':')C IF (STATUS .EQ. 0) THEN.C ASCTIM(ASCTIM_LEN+1,ASCTIM_LEN+5) = ':00.'C END IF" ISTAT = SYS$BINTIM(ASCTIM,BINTIM), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$SCHDWK(,,BINTIM,), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$PURGWS(%REF(RANGE)), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$HIBER() ENDwwZVǏ** S M G B O X* IMPLICIT NONE& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' CHARACTER*1 ANSWER INTEGER*2 I INTEGER*4 READ_PROMPT INTEGER*4 STATUS. INTEGER*4 INPUT_LEN ! Length of Input String CALL BEGIN CALL CRTCL CALL INIT_STRING CALL START_LINE CALL PLACE (1,1) CALL UPPER_LEFT_CORNER CALL HORIZONTAL(78) CALL UPPER_RIGHT_CORNER DO 20 I = 2,22 CALL PLACE(1,I) CALL VERTICAL CALL PLACE(80,I)20 CALL VERTICAL CALL PLACE(1,23) CALL LOWER_LEFT_CORNER CALL HORIZONTAL(78) CALL LOWER_RIGHT_CORNER CALL END_LINE CALL PLACE(10,10) CALL SWRT(14,'This is a test')@C STATUS = READ_PROMPT( ' Is This Correct? ',17,! Prompt, Length"C 2 ANSWER, I, ! Answer, LengthC 2 0 ) ! No Timeout END $ SUBROUTINE UPPER_LEFT_CORNER IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def0 2 %LOC(SMG$K_UPPER_LEFT_CORNER), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag'   GOTO 32767 END IF 32767 RETURN END % SUBROUTINE UPPER_RIGHT_CORNER IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def1 2 %LOC(SMG$K_UPPER_RIGHT_CORN!ER), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRIN"T *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF#% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END  SUBROUTINE START_LINE IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' $ SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def5 2 %LOC(SMG$K_BEGIN_LINE_DRAWING_CHAR),! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not% Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Nul&l arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END  SUBROUTINE END_LINE IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA'& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def3 2 %LOC(SMG$K_END_LINE_DRAWING_CHAR),! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting curso(r sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 !) or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END $ SUBROUTINE HORIZONTAL(COUNT) IMPLICIT NONE INTEGER*2 I INTEGER*2 COUNT INTEG*ER*2 OFFSET CHARACTER*132 LINE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def- 2 %LOC(SMG$K_HORIZONTAL_BAR), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length o+f Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF DO 50 I = 1, COUNT OFFSET = ((I-1) * RET_LEN);50 LINE(OFFSET+1:OFFSET + RET_LEN) = DATA_BUFFER(1:RET_LEN)$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) I,F (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument# 2 %REF(LINE) , ! Buffer to Output* 2 %VAL(RET_LEN*COUNT), ! Bytes To Output 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW :- ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END  SUBROUTINE VERTICAL IMPLICIT NONE INTEGER*2 I INTEGER*2 COUNT INTEGER*2 OFFSET CHARACTER*132 LINE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INC.LUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def+ 2 %LOC(SMG$K_VERTICAL_BAR), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',S/YS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument0) 2 %REF(DATA_BUFFER), ! Buffer to Output% 2 %VAL(RET_LEN), ! Bytes To Output 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END $ SUBROUTINE LOWER_LEFT_CORNER IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEG1ER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def0 2 %LOC(SMG$K_LOWER_LEFT_CORNER), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vecto2r with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel N3umber( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN4 END % SUBROUTINE LOWER_RIGHT_CORNER IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def1 2 %LOC(SMG$K_LOWER_RIGHT_CORNER), ! Request Code 2 20, ! Max bu5ffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' 6 GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG7) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END  SUBROUTINE INIT_STRING IMPLICIT NONE INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %RE8F(TERM_TABLE_ADDR), ! Addr of terminal def* 2 %LOC(SMG$K_INIT_STRING), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS 9= LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- :PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN END $ SUBROUTINE SMG_REQUEST(FUNC) IMPLICIT NONE INTEGER*4 FUNC INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABL;E (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def 2 %LOC(FUNC), ! Request Code 2 20, ! Max buffer length" 2 RET_LEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END< IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buf=fer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN ENDww0鏐 INTEGER*4 ARG_VECTOR(0:2) INTEGER*4 SYS_STATUS INTEGER*4 CHAN INTEGER*4 TERM_TYPE INTEGER*4 TERM_TABLE_ADDR I>NTEGER*4 RET_LEN INTEGER*4 EVENT_FLAG$ EXTERNAL SMG$K_BEGIN_ALTERNATE_CHAR EXTERNAL SMG$K_BEGIN_BLINK EXTERNAL SMG$K_BEGIN_BOLD! EXTERNAL SMG$K_BEGIN_DELETE_MODE! EXTERNAL SMG$K_BEGIN_INSERT_MODE' EXTERNAL SMG$K_BEGIN_LINE_DRAWING_CHAR EXTERNAL SMG$K_BEGIN_REVERSE EXTERNAL SMG$K_BEGIN_UNDERSCORE EXTERNAL SMG$K_BOTTOM_T_CHAR EXTERNAL SMG$K_CLEAR_TAB EXTERNAL SMG$K_CROSS_CHAR EXTERNAL SMG$K_CURSOR_DOWN EXTERNAL SMG$K_CURSOR_LEFT EXTERNAL SMG$K_CURSOR_RIGHT EXTERNA?L SMG$K_CURSOR_UP EXTERNAL SMG$K_DARK_SCREEN EXTERNAL SMG$K_DELETE_CHAR EXTERNAL SMG$K_DELETE_LINE! EXTERNAL SMG$K_DEVICE_ATTRIBUTES" EXTERNAL SMG$K_DOUBLE_HIGH_BOTTOM EXTERNAL SMG$K_DOUBLE_HIGH_TOP EXTERNAL SMG$K_DOUBLE_WIDE EXTERNAL SMG$K_DUPLICATE" EXTERNAL SMG$K_END_ALTERNATE_CHAR EXTERNAL SMG$K_END_BLINK EXTERNAL SMG$K_END_BOLD EXTERNAL SMG$K_END_DELETE_MODE EXTERNAL SMG$K_END_INSERT_MODE% EXTERNAL SMG$K_END_LINE_DRAWING_CHAR EXTERNAL SMG$K_END_REVERSE EXT@ERNAL SMG$K_END_UNDERSCORE$ EXTERNAL SMG$K_ERASE_TO_END_DISPLAY! EXTERNAL SMG$K_ERASE_TO_END_LINE# EXTERNAL SMG$K_ERASE_WHOLE_DISPLAY EXTERNAL SMG$K_ERASE_WHOLE_LINE EXTERNAL SMG$K_HOME EXTERNAL SMG$K_HORIZONTAL_BAR EXTERNAL SMG$K_INIT_STRING EXTERNAL SMG$K_INSERT_CHAR EXTERNAL SMG$K_INSERT_LINE EXTERNAL SMG$K_INSERT_PAD EXTERNAL SMG$K_LEFT_T_CHAR EXTERNAL SMG$K_LIGHT_SCREEN! EXTERNAL SMG$K_LOWER_LEFT_CORNER" EXTERNAL SMG$K_LOWER_RIGHT_CORNER EXTERNAL SMG$K_NAME EXTERANAL SMG$K_NEWLINE_CHAR EXTERNAL SMG$K_PAD_CHAR EXTERNAL SMG$K_RESTORE_CURSOR EXTERNAL SMG$K_RIGHT_T_CHAR EXTERNAL SMG$K_SAVE_CURSOR EXTERNAL SMG$K_SCROLL_FORWARD EXTERNAL SMG$K_SCROLL_REVERSE( EXTERNAL SMG$K_SEL_ERASE_TO_END_DISPLAY% EXTERNAL SMG$K_SEL_ERASE_TO_END_LINE' EXTERNAL SMG$K_SEL_ERASE_WHOLE_DISPLAY$ EXTERNAL SMG$K_SEL_ERASE_WHOLE_LINE& EXTERNAL SMG$K_SET_APPLICATION_KEYPAD& EXTERNAL SMG$K_SET_CHAR_NOT_SEL_ERASE" EXTERNAL SMG$K_SET_CHAR_SEL_ERASE EXTERNAL SMG$K_SET_CUBRSOR_ABS" EXTERNAL SMG$K_SET_NUMERIC_KEYPAD! EXTERNAL SMG$K_SET_SCROLL_REGION EXTERNAL SMG$K_SET_TAB EXTERNAL SMG$K_SINGLE_HIGH EXTERNAL SMG$K_TAB_CHAR EXTERNAL SMG$K_TOP_T_CHAR EXTERNAL SMG$K_UNDERLINE_CHAR! EXTERNAL SMG$K_UPPER_LEFT_CORNER" EXTERNAL SMG$K_UPPER_RIGHT_CORNER EXTERNAL SMG$K_VERTICAL_BAR EXTERNAL SMG$K_WIDTH_NARROW EXTERNAL SMG$K_WIDTH_WIDE& EXTERNAL SMG$K_CURSOR_POSITION_REPORT' EXTERNAL SMG$K_REQUEST_CURSOR_POSITION EXTERNAL SMG$K_CR_GRAPHIC EXTERNAL SMCG$K_FF_GRAPHIC EXTERNAL SMG$K_LF_GRAPHIC EXTERNAL SMG$K_HT_GRAPHIC EXTERNAL SMG$K_VT_GRAPHIC EXTERNAL SMG$K_TRUNCATION_ICON EXTERNAL SMG$K_CURSOR_NEXT_LINE% EXTERNAL SMG$K_CURSOR_PRECEDING_LINE EXTERNAL SMG$K_INDEX EXTERNAL SMG$K_REVERSE_INDEX& EXTERNAL SMG$K_BEGIN_NORMAL_RENDITION# EXTERNAL SMG$K_BEGIN_AUTOWRAP_MODE! EXTERNAL SMG$K_END_AUTOWRAP_MODE% EXTERNAL SMG$K_BEGIN_AUTOREPEAT_MODE# EXTERNAL SMG$K_END_AUTOREPEAT_MODE# EXTERNAL SMG$K_SET_ORIGIN_RELATIVE# EXTERNAL SMDG$K_SET_ORIGIN_ABSOLUTE$ EXTERNAL SMG$K_ERASE_LINE_TO_CURSOR EXTERNAL SMG$K_NEXT_LINE$ EXTERNAL SMG$K_BEGIN_AUTOPRINT_MODE" EXTERNAL SMG$K_END_AUTOPRINT_MODE EXTERNAL SMG$K_PRINT_SCREEN EXTERNAL SMG$K_SET_CURSOR_ON EXTERNAL SMG$K_SET_CURSOR_OFF" EXTERNAL SMG$K_SET_PRINTER_OUTPUT! EXTERNAL SMG$K_SET_SCREEN_OUTPUT' EXTERNAL SMG$K_ERASE_DISPLAY_TO_CURSOR CHARACTER*20 DATA_BUFFER, COMMON /SMGBUF/ DATA_BUFFER,CHAN,TERM_TYPE, 2 TERM_TABLE_ADDRwwdǏ$ SUEBROUTINE SMG_REQUEST(FUNC) IMPLICIT NONE INTEGER*4 FUNC INTEGER*4 SYS$QIOW INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA& INCLUDE 'LES:LESTABLE (SMGBUF)/LIST' INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' SYS_STATUS = SMG$GET_TERM_DATA(1 2 %REF(TERM_TABLE_ADDR), ! Addr of terminal def 2 %LOC(FUNC), ! Request Code 2 20, ! Max buffer length" 2 RET_LFEN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence 2 ) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767 END IFG SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLAG) IF (.NOT. SYS_STAHTUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 RETURN ENDwwhǏ*,* S M G _ T E R M T A B L E _ E X A M P L E*8* This program will set the cursor to row 12, column 1,8* and erase to the bottom of the screen. If the cursor2* positioning or erasing to the end of the screen:* capabilities are not defined, a message will be output.* IMPLICIT NONE INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$DASSGN INTEGER*4 SYS$QIOWI INTEGER*4 LIB$GETDVI INTEGER*4 LIB$GET_EF INTEGER*4 LIB$FREE_EF& INTEGER*4 SMG$INIT_TERM_TABLE_BY_TYPE INTEGER*4 SMG$GET_TERM_DATA INCLUDE '($IODEF)' INCLUDE '($DVIDEF)' INCLUDE '($SMGDEF)' INTEGER*4 SMG$K_SET_CURSOR_ABS' PARAMETER (SMG$K_SET_CURSOR_ABS = 570)& INTEGER*4 SMG$K_ERASE_TO_END_DISPLAY- PARAMETER (SMG$K_ERASE_TO_END_DISPLAY = 472) INTEGER*4 ARG_VECTOR(0:2) INTEGER*4 SYS_STATUS INTEGER*4 CHAN INTEGER*4 TERM_TYPE INTEGER*4 TERM_TABLE_ADDR INTJEGER*4 RET_LEN INTEGER*4 EVENT_FLAG CHARACTER*20 DATA_BUFFER COMMON /BUF/ DATA_BUFFER. SYS_STATUS = SYS$ASSIGN('SYS$OUTPUT',CHAN,,,) IF (.NOT. SYS_STATUS) 2 THEN/ PRINT *,'Error from SYS$ASSIGN : ',SYS_STATUS GOTO 32767 END IF: SYS_STATUS = LIB$GETDVI(DVI$_DEVTYPE, ! Request item code 2 CHAN, ! Channel assigned 2 , ! Omit Device Name& 2 TERM_TYPE) ! Place to return Type IF (.NOT. SYS_STATUS) 2 THEN/ PRINT *,'Error from LIB$GETDVI : ',SYS_STATUS KGOTO 32767 END IFD SYS_STATUS = SMG$INIT_TERM_TABLE_BY_TYPE(TERM_TYPE,TERM_TABLE_ADDR) IF (.NOT. SYS_STATUS) 2 THEN; PRINT *,'Error getting terminal definition : ',SYS_STATUS GOTO 32767 END IF/ ARG_VECTOR(0) = 2 ! Number of args to follow" ARG_VECTOR(1) = 12 ! Row number$ ARG_VECTOR(2) = 1 ! Column number SYS_STATUS = SMG$GET_TERM_DATA, 2 (TERM_TABLE_ADDR, ! Addr of terminal def( 2 SMG$K_SET_CURSOR_ABS, ! Request Code 2 20, ! Max buffer length" 2 RET_LELN, ! Length of Sequence0 2 %REF(DATA_BUFFER), ! Buffer to hold Sequence* 2 ARG_VECTOR(0)) ! Optional vector with ! row and column numbers IF (.NOT. SYS_STATUS) 2 THEN7 PRINT *,'Error getting cursor sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN) PRINT *,'Cursor Sequence Not Available' GOTO 32767 END IF$ SYS_STATUS = LIB$GET_EF(EVENT_FLAG) IF (.NOT. SYS_STATUS) 2 THEN, PRINT *,'Unable to allocate an event flag' GOTO 32767M END IF SYS_STATUS = SYS$QIOW() 2 %VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel Number( 2 %VAL(IO$_WRITEVBLK), ! Function Code 2 ,,, ! No IOSB, 2 ! or AST routine, 2 ! or AST argument) 2 %REF(DATA_BUFFER), ! Buffer to Output$ 2 %VAL(RET_LEN), ! Bytes Returned 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN- PRINT *,'Error from SYS$QIOW : ',SYS_STATUS GOTO 32767 END IF SYS_STATUS = SMG$GET_TERM_DATA, 2 (TERM_TABLEN_ADDR, ! Addr of Terminal Def- 2 SMG$K_ERASE_TO_END_DISPLAY, ! Request Code 2 20, ! Max Buffer Length 2 RET_LEN, ! Bytes Returned, 2 %REF(DATA_BUFFER)) ! Buffer for Sequence IF (.NOT. SYS_STATUS) 2 THEN6 PRINT *,'Error getting erase sequence : ',SYS_STATUS GOTO 32767 END IF IF (RET_LEN .EQ. 0) 2 THEN( PRINT *,'Erase sequence not available' GOTO 32767 END IF SYS_STATUS = SYS$QIOW* 2 (%VAL(EVENT_FLAG), ! Event Flag Number! 2 %VAL(CHAN), ! Channel numOber( 2 %VAL(IO$_WRITEVBLK), ! Function code 2 ,,, ! No IOSB, 2 ! no AST, and no AST arg) 2 %REF(DATA_BUFFER), ! Buffer to output% 2 %VAL(RET_LEN), ! Bytes in buffer 2 ,,,) ! Null arguments IF (.NOT. SYS_STATUS) 2 THEN) PRINT *,'Error from QIOW : ',SYS_STATUS GOTO 32767 END IF$ SYS_STATUS = SYS$DASSGN(%VAL(CHAN)) IF (.NOT. SYS_STATUS) 2 THEN/ PRINT *,'Error from SYS$DASSGN : ',SYS_STATUS GOTO 32767 END IF% SYS_STATUS = LIB$FREE_EF(EVENT_FLPAG) IF (.NOT. SYS_STATUS) 2 THEN+ PRINT *,'Unable to deallocate event flag' GOTO 32767 END IF 32767 ENDwwg+tǏ PROGRAM SYSLOG** S Y S L O G* INTEGER*4 SYS$GETJPIW INTEGER*4 LIB$GET_LUN INTEGER*4 LIB$DATE_TIME INTEGER*4 STR$TRANSLATE INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' INTEGER*4 CONTEXT INTEGER*4 ISTAT INTEGER*4 IMGST CHARACTER*23 DATETIME CHARACTER*13 JOB_TYPE INTEGER LUN CHARACTER*1 TRANSL_FR CHARACTER*1 TRANSL_TOQ& CHARACTER ASCTIM*13 /'0 00:05:00.00'/ INTEGER*4 BINTIM(2)# INTEGER*4 RANGE(2) /0,'7FFFFFFF'X/ INTEGER*4 SYS$SCHDWK INTEGER*4 SYS$PURGWS INTEGER*4 SYS$BINTIM INTEGER*4 SYS$HIBER STRUCTURE /ITMLST/ UNION MAP INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAP MAP INTEGER*4 END_LIST END MAP END UNION END STRUCTURE STRUCTURE /IOSBLK/ INTEGER*4 STATUS, ZEROED END STRUCTURE RECORD /ITMLST/ JPI_LIST(12R) RECORD /IOSBLK/ IOSB INTEGER*4 PID CHARACTER*8 PROCID CHARACTER*15 PRCNAM INTEGER*4 PRCNAM_LEN CHARACTER*55 IMAGNAME INTEGER*4 IMAGNAME_LEN INTEGER*4 LOGINTIM(2) CHARACTER*39 LOGINTIME INTEGER*4 MASTER_PID CHARACTER*8 MASTER_PROCID INTEGER*4 MODE INTEGER*4 PAGEFLTS INTEGER*4 STATE CHARACTER*7 TERMINAL INTEGER*4 TERMINAL_LEN CHARACTER*12 USERNAME INTEGER*4 USERNAME_LEN INTEGER*4 PRIORITY TRANSL_FR = CHAR(0) TRANSL_TO = ' ' JPI_LIST( 1).BUSFLEN = 8 JPI_LIST( 1).ITMCOD = JPI$_PID JPI_LIST( 1).BUFADR = %LOC(PID) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).BUFLEN = 15" JPI_LIST( 2).ITMCOD = JPI$_PRCNAM# JPI_LIST( 2).BUFADR = %LOC(PRCNAM)' JPI_LIST( 2).RETADR = %LOC(PRCNAM_LEN) JPI_LIST( 3).BUFLEN = 8& JPI_LIST( 3).ITMCOD = JPI$_MASTER_PID' JPI_LIST( 3).BUFADR = %LOC(MASTER_PID) JPI_LIST( 3).RETADR = 0 JPI_LIST( 4).BUFLEN = 55$ JPI_LIST( 4).ITMCOD = JPI$_IMAGNAME% JPI_LIST( 4).BUFADR = %LOC(IMAGNAME)) JPI_LIST( 4).RETATDR = %LOC(IMAGNAME_LEN) JPI_LIST( 5).BUFLEN = 8$ JPI_LIST( 5).ITMCOD = JPI$_LOGINTIM( JPI_LIST( 5).BUFADR = %LOC(LOGINTIM(1)) JPI_LIST( 5).RETADR = 0 JPI_LIST( 6).BUFLEN = 4 JPI_LIST( 6).ITMCOD = JPI$_MODE! JPI_LIST( 6).BUFADR = %LOC(MODE) JPI_LIST( 6).RETADR = 0 JPI_LIST( 7).BUFLEN = 4$ JPI_LIST( 7).ITMCOD = JPI$_PAGEFLTS% JPI_LIST( 7).BUFADR = %LOC(PAGEFLTS) JPI_LIST( 7).RETADR = 0 JPI_LIST( 8).BUFLEN = 4! JPI_LIST( 8).ITMCOD = JPI$_STATE" JPI_LIST( 8).BUFADR = %LOC(STATE)U JPI_LIST( 8).RETADR = 0 JPI_LIST( 9).BUFLEN = 7$ JPI_LIST( 9).ITMCOD = JPI$_TERMINAL% JPI_LIST( 9).BUFADR = %LOC(TERMINAL)) JPI_LIST( 9).RETADR = %LOC(TERMINAL_LEN) JPI_LIST(10).BUFLEN = 12$ JPI_LIST(10).ITMCOD = JPI$_USERNAME% JPI_LIST(10).BUFADR = %LOC(USERNAME)) JPI_LIST(10).RETADR = %LOC(USERNAME_LEN) JPI_LIST(11).BUFLEN = 4 JPI_LIST(11).ITMCOD = JPI$_PRI% JPI_LIST(11).BUFADR = %LOC(PRIORITY) JPI_LIST(11).RETADR = 0 JPI_LIST(12).END_LIST = 0 ISTAT = LIB$GET_LUN(LUNV). IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) OPEN ( UNIT = LUN, 2 FILE = 'SYSLOG.FIL', 2 RECL = 255, 2 STATUS = 'UNKNOWN', 2 FORM = 'FORMATTED') DO WHILE (.TRUE.) CONTEXT = -1 DO WHILE (.TRUE.)+ ISTAT = SYS$GETJPIW(,CONTEXT,,JPI_LIST,,,)( IF (ISTAT .EQ. SS$_NOMOREPROC) GOTO 777/C IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT))& CALL OTS$CVT_L_TZ(PID,PROCID,%VAL(8))4 CALL OTS$CVT_L_TZ(MASTER_PID,MASTER_PROCID,%VAL(8))& CALL SYS$ASCTIM(,LOGINTIME,LOGINTIM,)( IWF (LOGINTIM(1) .EQ. 0) LOGINTIME = ' ' CALL LIB$DATE_TIME(DATETIME)$ IF (MODE .EQ. 0) JOB_TYPE = 'Other'& IF (MODE .EQ. 1) JOB_TYPE = 'Network'$ IF (MODE .EQ. 2) JOB_TYPE = 'Batch'* IF (MODE .EQ. 3) JOB_TYPE = 'Interactive'1 ISTAT = STR$TRANSLATE( USERNAME(1:USERNAME_LEN), 2 USERNAME(1:USERNAME_LEN), 2 TRANSL_TO, TRANSL_FR ). IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)) WRITE (UNIT=LUN, FMT= 800) 2 DATETIME, 2 PROCID, 2 MASTER_PROCID, 2 TERMINAL(1:TERMINAL_LEN),X 2 USERNAME(1:USERNAME_LEN), 2 PRCNAM(1:PRCNAM_LEN), 2 IMAGNAME(1:IMAGNAME_LEN), 2 PAGEFLTS, 2 PRIORITY END DO%777 ISTAT = SYS$BINTIM(ASCTIM,BINTIM), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$SCHDWK(,,BINTIM,), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$PURGWS(%REF(RANGE)), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$HIBER() ENDDO4800 FORMAT(A23,TR1,A8,TR1,A8,TR1,A7,TR1,A12,TR1,A15, 2 TR1,A55,TR1,I10,TR1,I2 )+888 PRINT *, 'ERYROR WRITING TO OUTPUT FILE'900 CLOSE (LUN) ENDww`A PROGRAM SYSTAT** S Y S T A T*1* Uses EXTERNAL declarations from in STATEDEF.MAR* IMPLICIT NONE INTEGER*4 SYS$GETJPIW INTEGER*4 LIB$GET_FOREIGN INTEGER*4 LIB$GET_LUN INTEGER*4 LIB$DATE_TIME INTEGER*4 STR$TRANSLATE INTEGER*4 STR$UPCASE INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER*80 BLANKS INTEGER*4 CONTEXT CHARACTER*23 DATETIME INTEGER*4 GPGCNT INTEGER*2 I CHARACTERZ`**4* F I N G E RI*G PROGRAM FINGERG IMPLICIT NONE INCLUDE '($FORIOSDEF)' INCLUDE '($JPIDEF)'R INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)'SC_)C E x t e r n a l D e f i n i t i o n s4CDC Module: STATEDEFCT EXTERNAL SCH$C_CEFA EXTERNAL SCH$C_COLPGG EXTERNAL SCH$C_COMG EXTERNAL SCH$C_COMO EXTERNAL SCH$C_CURP EXTERNAL SCH$C_FPG4 EXTERNAL SCH$C_HIBR EXTERNAL SCH$C_HIBO EXTERNAL SCH$C_LEFA EXTERNAL SCH$C_LEFO EXTERNAL SCH$C_MWAIT E[XTERNAL SCH$C_PFWA EXTERNAL SCH$C_SUSP EXTERNAL SCH$C_SUSPOA+ INTEGER*2 ACCOUNT_LEN ! Length of AccountS) CHARACTER*80 BLANKS ! String of Blanks ' INTEGER*4 CONTEXT ! Proc ID Wildcard( CHARACTER*11 CPUTIM ! CPU Time String. CHARACTER*23 DATETIME ! Data and Time String. CHARACTER*45 ERR_MESSAGE ! I/O Error Message) CHARACTER*23 EXPIRES ! Expiration Date/ INTEGER*2 FIRST_TIME ! Just a Flag for GETJPIR( INTEGER*2 FLGLEN ! Login Flags Length- CHARACTER*40 FOREIGN_COMMAND ! \ Foreign LineR1 INTEGER*4 FOR$ERROR_MESSAGE ! Get I/O Error TextN' INTEGER*4 GET_LFLGS ! Get Login Flags , INTEGER*4 GET_PRIMEDAYS ! Get Primary Days/ INTEGER*4 GET_PRIVILEGES ! Get VMS Privileges ' INTEGER*4 GPGCNT ! Global Page CountS" INTEGER*2 I ! Loop Counter, etc& CHARACTER*55 IMAGNAME ! Program Name. INTEGER*4 IMAGNAME_LEN ! Program Name Length! INTEGER*4 ISTAT ! Error Status= INTEGER*2 J ! Just Like I% CHARACTER*13 JOB_TYPE ! Type of JobJ+ CHARACTER*255 L_FLAGS ! T ]ext Login Flags.1 INTEGER*4 LIB$DATE_TIME ! Date and Time Routine2. INTEGER*4 LIB$GET_FOREIGN ! Get Foreign Line- INTEGER*4 LIB$GET_INPUT ! Get Input RoutineM1 INTEGER*4 LIB$GET_LUN ! Get Logical Unit NumberC' INTEGER*4 LIB$SYS_FAO ! Format OutputR0 CHARACTER*23 LOGIN_I ! Last Interactive Login, CHARACTER*23 LOGIN_N ! Last Network Login- INTEGER*4 LOGINTIM(2) ! Login Time QuadwordM, CHARACTER*39 LOGINTIME ! Login Time String. INTEGER*2 MAIL_FILE ! Mail File Logical Unit+ INTEGER ^*2 MAIL_NEWMES ! New Mail Messages=& BYTE MAIL_REC(272) ! VMSMAIL Record* INTEGER*4 MASTER_PID ! Master Process Id6 CHARACTER*8 MASTER_PROCID ! Master Process Id String INTEGER*4 MODE ! Process Mode& CHARACTER*8 NULLS ! Null Characters" INTEGER*4 PAGEFLTS ! Page Faults INTEGER*4 PID ! Process Id(% CHARACTER*15 PRCNAM ! Process Name4, INTEGER*4 PRCNAM_LEN ! Process Name Length% CHARACTER*27 PRIMEDAYS ! Prime Days8# INTEGER*4 PRIORITY ! Job Priority7. EXTERNAL PRIV_USEROPE _N ! Privileged Useropen( INTEGER*2 PRIVLEN ! Privileges Length, CHARACTER*255 PRIVSTR ! Privileges String) CHARACTER*8 PROCID ! Process Id String_. CHARACTER*23 PWDCHNG ! Password Change Date+ CHARACTER*23 PWDLIFE ! Password Lifetime* CHARACTER*8 QUAD_TIME ! Quad Time String" CHARACTER*15 S_UIC ! UIC String% INTEGER*2 SCREEN ! SYS$OUTPUT UnitR) CHARACTER*27 SECONDARY ! Secondary Days2 INTEGER*4 SIZE ! Job Size" INTEGER*4 STATE ! Process State. CHARACTER*5 STATE_STR `! Process State String# INTEGER*4 STATUS ! Return StatusI- INTEGER*4 STR$TRANSLATE ! Translate Routine.- INTEGER*4 STR$UPCASE ! Convert To UppercaseE( INTEGER*4 SYS$ASCTIM ! Time Conversion5 INTEGER*4 SYS$GETJPIW ! Get Job Process Information , INTEGER*4 SYS$GETUAI ! Get UAF Information" CHARACTER*23 TEMP ! Misc String! CHARACTER*7 TERMINAL ! TerminalE* INTEGER*4 TERMINAL_LEN ! Terminal Length0 CHARACTER*33 TRANSL_FR ! Translate From String2 CHARACTER*1 TRANSL_TO /' '/ ! Translaate To String" CHARACTER*12 USERNAME ! Username* INTEGER*4 USERNAME_LEN ! Username Length- CHARACTER*12 USRNAM ! Username From GETJPI ) INTEGER*4 USRNAM_LEN ! Length of USRNAM  INTEGER*2 X ! Used Like I( EQUIVALENCE (MAIL_NEWMES, MAIL_REC(34))*P* U A F R E C O R DN*0 STRUCTURE /UAFREC/  UNION MAP CHARACTER*12 USERNAME  INTEGER*4 UIC  CHARACTER*12 ACCOUNT CHARACTER*32 OWNER CHARACTER*16 DEVICE  CHARACTER*64 DIRECTORY CHARACTER*256 COM_FILE CHARACTEbR*40 CLI CHARACTER*32 TABLES  INTEGER*4 PASSWORD(2)= CHARACTER*8 PASSWORD2I INTEGER*4 LGIFAILS INTEGER*2 SALT BYTE B_ENCRYPTF BYTE B_ENCRYPT2 INTEGER*4 PWD_LENGTH INTEGER*4 Q_EXPIRATION(2)O INTEGER*4 Q_PWD_LIFETIME(2)Z INTEGER*4 Q_PWD_DATE(2)V CHARACTER*8 Q_PWD2_DATEO INTEGER*4 Q_LASTLOGIN_I(2) INTEGER*4 Q_LASTLOGIN_N(2) INTEGER*4 PRIV(2)( INTEGER*4 DEF_PRIV(2)E CHARACTER*20 MIN_CLASS CHARACTER*20 MAX_CLASS INTEGER*4 LOGIN_FLAGSE INTEGER*4 cNETWORK_ACCESS_P INTEGER*4 NETWORK_ACCESS_S INTEGER*4 BATCH_ACCESS_P INTEGER*4 BATCH_ACCESS_S INTEGER*4 LOCAL_ACCESS_P INTEGER*4 LOCAL_ACCESS_S INTEGER*4 DIALUP_ACCESS_P INTEGER*4 DIALUP_ACCESS_S  INTEGER*4 REMOTE_ACCESS_P) INTEGER*4 REMOTE_ACCESS_S INTEGER*4 PRIMEDAYSO INTEGER*4 PRIE INTEGER*4 QUEPRI INTEGER*4 MAXJOBS  INTEGER*4 MAXACCTJOBSN INTEGER*4 MAXDETACH INTEGER*4 PRCCNT INTEGER*4 BIOLMH INTEGER*4 DIOLMF INTEGER*4 TQCNTT INTEGER*4 dASTLMI INTEGER*4 ENQLMT INTEGER*4 FILLMF INTEGER*4 SHRFILLM INTEGER*4 WSQUOTAT INTEGER*4 DFWSCNT  INTEGER*4 WSEXTENT INTEGER*4 PGFLQUOTA_ INTEGER*4 CPUTIM INTEGER*4 BYTLM( INTEGER*4 PBYTLM INTEGER*4 JTQUOTA INTEGER*2 W_PROXY_LIM( INTEGER*2 W_PROXIEST INTEGER*2 W_ACCOUNT_LIMF INTEGER*2 W_ACCOUNTS CHARACTER*8 S_CPUTIM END MAP MAP CHARACTER*12 %FILL INTEGER*2 UIC_MEMT INTEGER*2 UIC_GRPS END MAP MAP CHARACTER*16 %FILL BYTE ACCOUNT_LEeNS CHARACTER*11 %FILL BYTE OWNER_LENS CHARACTER*31 %FILL BYTE DEVICE_LEN CHARACTER*15 %FILL BYTE DIRECTORY_LEN CHARACTER*63 %FILL BYTE COM_FILE_LEN CHARACTER*255 %FILLE BYTE CLI_LEN/ CHARACTER*39 %FILL BYTE TABLES_LEN END MAP END UNION END STRUCTURE RECORD /UAFREC/ UAF* * W O R K A R E A SM*A STRUCTURE /LOGMAP/1 UNION MAP INTEGER*4 LAST_DATE INTEGER*4 LAST_TIME) END MAP MAP CHARACTER*8 LASTLOGIN  END MAP END UNION END STRUCTURE RECORD /LOGMAP/ LOG STRUCTURE /ITMLST/ UNION MAPO INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAPU MAP_ INTEGER*4 END_LIST END MAPE END UNION END STRUCTURE STRUCTURE /IOSBLK/S INTEGER*4 STATUS, ZEROED END STRUCTURE RECORD /ITMLST/ ITEM_LIST(53) RECORD /ITMLST/ JPI_LIST(14)M RECORD /IOSBLK/ IOSB ITEM_LIST( 1).BUFLEN = 9$ ITEM_LIST( 1).ITMCOD = UAI$_ACCOUNT) ITEM_LIST( 1).BUFADR = %LOC(UAFg,A7,TR1,A12,TR1,A15,! 2 TR1,A15,TR1,A5TR1,I10,TR1,I2 )&801 FORMAT( A8,TR1,A7,TR1,A12,TR1,A15,! 2 TR1,A15,TR1,A5TR1,A10,TR1,A2 ) 32767 ENDww໕wǏ INCLUDE '($IODEF)' INCLUDE '($TTDEF)' INCLUDE '($TT2DEF)' INTEGER*4 STATUS INTEGER*2 INPUT_CHAN STRUCTURE /IOSTAT_BLOCK/ INTEGER*2 IOSTAT BYTE TRANSMIT BYTE RECEIVE BYTE CRFILL BYTE LFFILL BYTE PARITY BYTE ZERO END STRUCTURE RECORD /IOSTAT_BLOCK/ IOSB STRUCTURE /CHARACTERISTIChS/ BYTE CLASS BYTE TYPE INTEGER*2 WIDTH UNION MAP INTEGER*4 BASIC END MAP MAP BYTE LENGTH(4) END MAP END UNION INTEGER*4 EXTENDED END STRUCTURE! RECORD /CHARACTERISTICS/ CHARBUF INTEGER*4 SYS$ASSIGN INTEGER*4 SYS$QIOW/ STATUS = SYS$ASSIGN('SYS$INPUT', INPUT_CHAN,,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = SYS$QIOW(, 2 %VAL(INPUT_CHAN), 2 %VAL(IO$_SENSEMODE), 2 IOSB,,, 2 CHARBUF, ! Buffer! 2 %ViAL(12),,,,) ! Buffer Size0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,CHARBUF.CLASS PRINT *,CHARBUF.TYPE ENDww 0#鏐&C T I M D E F - Tim$* Data DefinitionsC>C The Tim$* constants, types, and variables are defined here.C C DESCRIPTION=C The Tim$* constants, types, and variables are defined here%C for inclusion in FORTRAN programs.C C REFERENCES C TIM$DATA0 EXTERNAL TIM$DATA ! to reference the BLOCK DATA STRUCTURE /TIM$R_TIME/j INTEGER*4 Lower INTEGER*4 Upper END STRUCTURE CHARACTER*9 TIM$C_DAY_NAME (7), COMMON /TIM$DAY_NAME$COMMON/ TIM$C_DAY_NAME" CHARACTER*9 TIM$C_MONTH_NAME (12)0 COMMON /TIM$MONTH_NAME$COMMON/ TIM$C_MONTH_NAME RECORD /TIM$R_TIME/ 1 TIM$C_ZERO, 1 TIM$C_ONE_100NS, 1 TIM$C_ONE_US, 1 TIM$C_ONE_10US, 1 TIM$C_ONE_100US, 1 TIM$C_ONE_MS, 1 TIM$C_ONE_HUNDREDTH, 1 TIM$C_ONE_TENTH, 1 TIM$C_ONE_SECOND, 1 TIM$C_ONE_MINUTE, 1 TIM$C_ONE_HOUR, 1 TIM$C_ONE_DAY, 1 TkIM$C_ONE_WEEK, 1 TIM$C_ONE_MONTH, 1 TIM$C_ONE_YEAR COMMON /TIM$TIME$COMMON/ 1 TIM$C_ZERO, 1 TIM$C_ONE_100NS, 1 TIM$C_ONE_US, 1 TIM$C_ONE_10US, 1 TIM$C_ONE_100US, 1 TIM$C_ONE_MS, 1 TIM$C_ONE_HUNDREDTH, 1 TIM$C_ONE_TENTH, 1 TIM$C_ONE_SECOND, 1 TIM$C_ONE_MINUTE, 1 TIM$C_ONE_HOUR, 1 TIM$C_ONE_DAY, 1 TIM$C_ONE_WEEK, 1 TIM$C_ONE_MONTH, 1 TIM$C_ONE_YEAR INTEGER 1 TIM$C_MONDAY, 1 TIM$C_TUESDAY, 1 TIM$C_WEDNESDAY, 1 TIM$C_THURSDAY, 1 TIM$C_FRIDAY,l 1 TIM$C_SATURDAY, 1 TIM$C_SUNDAY PARAMETER ( 1 TIM$C_MONDAY = 1, 1 TIM$C_TUESDAY = 2, 1 TIM$C_WEDNESDAY = 3, 1 TIM$C_THURSDAY = 4, 1 TIM$C_FRIDAY = 5, 1 TIM$C_SATURDAY = 6, 1 TIM$C_SUNDAY = 7 1 ) INTEGER 1 TIM$C_JANUARY, 1 TIM$C_FEBRUARY, 1 TIM$C_MARCH, 1 TIM$C_APRIL, 1 TIM$C_MAY, 1 TIM$C_JUNE, 1 TIM$C_JULY, 1 TIM$C_AUGUST, 1 TIM$C_SEPTEMBER, 1 TIM$C_OCTOBER, 1 TIM$C_NOVEMBER, 1 TIM$C_DECEMBER PARAMETER ( 1 TIM$C_JANUARY = 1, 1 TmIM$C_FEBRUARY = 2, 1 TIM$C_MARCH = 3, 1 TIM$C_APRIL = 4, 1 TIM$C_MAY = 5, 1 TIM$C_JUNE = 6, 1 TIM$C_JULY = 7, 1 TIM$C_AUGUST = 8, 1 TIM$C_SEPTEMBER = 9, 1 TIM$C_OCTOBER = 10, 1 TIM$C_NOVEMBER = 11, 1 TIM$C_DECEMBER = 12 1 )C END ! TimDefww R}ǏC TIMEOUT.FORC0C This program illustrates the use of a USEROPEN1C procedure to initialize the I/O time-out period4C for a terminal. It also illustrates the use of the2C IOSTAT I/O statement parametern to obtain the I/O0C status code. This program must be linked with C TIMEOUTUO.MAR.C IMPLICIT INTEGER*4 (A - Z) EXTERNAL TIMEOUT_OPEN INCLUDE '($RMSDEF)' INCLUDE '($FORIOSDEF)'C#C Open file with USEROPEN procedure. OPEN (UNIT=1, FILE='SYS$INPUT', STATUS='OLD', 1 USEROPEN=TIMEOUT_OPEN) C Accept input until end-of-file C Prompt 1 TYPE 10!10 FORMAT ('$Enter an integer: ')CC Get input with time-out' READ (1,20, END=1000, IOSTAT=STATUS) I20 FORMAT (I5)Co%C Display input and check for errors IF (STATUS .EQ. 0) THEN TYPE 30, I 30 FORMAT (' You entered ', I5)- ELSE IF (STATUS .EQ. FOR$IOS_INPCONERR) THEN TYPE *, 'Bad input value.'- ELSE IF (STATUS .EQ. FOR$IOS_ERRDURREA) THEN# CALL ERRSNS (,RMS_STS, RMS_STV,,)! IF (RMS_STS .EQ. RMS$_TMO) THEN# TYPE *, 'No response in 10 sec.' ELSE" CALL LIB$SIGNAL (%VAL(RMS_STS), 1 %VAL(RMS_STV)) ENDIF ENDIFCC Loop GOTO 11000 ENDww0qǏ** Tp I M E _ E X A M P L E* INTEGER*4 CURRENT_TIME(2) INTEGER*4 TIME_DIFFERENCE(2) INTEGER*4 NEW_TIME(2) INTEGER*4 ZERO(2) /0,0/ INTEGER*4 DISPLACEMENT(2) /0,0/ INTEGER*4 STATUS INTEGER*4 X CHARACTER*23 DELTA CHARACTER*11 TIME_DIFFERENCE_F INTEGER*4 LIB$ADDX INTEGER*4 LIB$DAY INTEGER*4 SYS$GETTIM INTEGER*4 LIB$GET_INPUT INTEGER*4 SYS$BINTIM INTEGER*4 LIB$SUBX INTEGER*4 SYS$ASCTIM" STATUS = SYS$GETTIM(CURRENT_TIME)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAqL(STATUS))/ STATUS = LIB$GET_INPUT(DELTA,'Delta Date: ',X)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) IF (X .GT. 5) GOTO 100% DELTA = DELTA(1:X) // ' 00:00:00.00',100 STATUS = SYS$BINTIM(DELTA, DISPLACEMENT)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = LIB$SUBX( ZERO, 2 DISPLACEMENT, 2 DISPLACEMENT )! STATUS = LIB$ADDX( DISPLACEMENT, 2 CURRENT_TIME, 2 NEW_TIME )0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))) STATUS = SYS$ASCTIM(, TIMrE_DIFFERENCE_F, 2 NEW_TIME,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,TIME_DIFFERENCE_F ENDww@{Ǐ** T I M E _ E X A M P L E* INTEGER*4 CURRENT_TIME(2) INTEGER*4 PAST_TIME(2) INTEGER*4 TIME_DIFFERENCE(2) INTEGER*4 NEW_TIME(2) INTEGER*4 ZERO(2) /0,0/ INTEGER*4 DISPLACEMENT(2) /0,0/ INTEGER*4 DAY_OF_WEEK INTEGER*4 STATUS INTEGER*4 ADAYS INTEGER*4 BDAYS INTEGER*4 CDAYS INTEGER*4 X CHARACTER*23 DELTA CHARACTER*23 CURRsENT_TIME_F CHARACTER*23 PAST_TIME_F CHARACTER*11 TIME_DIFFERENCE_F4 CHARACTER*9 DAY(7) /'Monday','Tuesday','Wednesday',. 2 'Thursday','Friday','Saturday','Sunday'/ INTEGER*4 LIB$ADDX INTEGER*4 LIB$DAY INTEGER*4 LIB$DAY_OF_WEEK INTEGER*4 SYS$GETTIM INTEGER*4 LIB$GET_INPUT INTEGER*4 SYS$BINTIM INTEGER*4 LIB$SUBX INTEGER*4 SYS$ASCTIM: STATUS = LIB$GET_INPUT(CURRENT_TIME_F,'Current Time: ',X)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) IF (X .LE. 0) THEN tPRINT *,'Using Current Time'# STATUS = SYS$GETTIM(CURRENT_TIME)1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ELSE2 STATUS = SYS$BINTIM(CURRENT_TIME_F,CURRENT_TIME) END IF3 STATUS = LIB$DAY_OF_WEEK(CURRENT_TIME,DAY_OF_WEEK)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))% PRINT *,'Today is ',DAY(DAY_OF_WEEK)? STATUS = LIB$GET_INPUT(PAST_TIME_F,'Past time (absolute): ',X)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) IF (X .LE. 0) THEN PRINT *,'Using Current Time' u STATUS = SYS$GETTIM(PAST_TIME)1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ELSE, STATUS = SYS$BINTIM(PAST_TIME_F,PAST_TIME)1 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) END IF0 STATUS = LIB$DAY_OF_WEEK(PAST_TIME,DAY_OF_WEEK)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))# PRINT *,'Day is ',DAY(DAY_OF_WEEK)! STATUS = LIB$SUBX( CURRENT_TIME, 2 PAST_TIME, 2 TIME_DIFFERENCE )0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))/ IF (.NOT. (BTEST(TIME_DIFFERENCE(v2),31))) THEN STATUS = LIB$SUBX( ZERO, 2 TIME_DIFFERENCE, 2 TIME_DIFFERENCE ) END IF) STATUS = SYS$ASCTIM(, TIME_DIFFERENCE_F, 2 TIME_DIFFERENCE,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))/ PRINT *,'Time Difference = ',TIME_DIFFERENCE_F& STATUS = LIB$DAY(ADAYS,CURRENT_TIME,)# STATUS = LIB$DAY(BDAYS,PAST_TIME,) CDAYS = ADAYS - BDAYS PRINT *,'Difference = ',CDAYS/ STATUS = LIB$GET_INPUT(DELTA,'Delta Date: ',X)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STwATUS)) IF (X .GT. 5) GOTO 100% DELTA = DELTA(1:X) // ' 00:00:00.00',100 STATUS = SYS$BINTIM(DELTA, DISPLACEMENT)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) STATUS = LIB$SUBX( ZERO, 2 DISPLACEMENT, 2 DISPLACEMENT )! STATUS = LIB$ADDX( DISPLACEMENT, 2 CURRENT_TIME, 2 NEW_TIME )0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS))) STATUS = SYS$ASCTIM(, TIME_DIFFERENCE_F, 2 NEW_TIME,)0 IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) PRINT *,TIME_DIFFER xENCE_F ENDww Ǐ** U F O _ C R E A T E*+ INTEGER*4 FUNCTION UFO_CREATE(FAB,RAB,LUN)CC Needs Options File on Link.C PSECT_ATTR = DATA, PAGEC INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB INTEGER*4 LUN INTEGER*4 CHAN INTEGER*4 STATUS INTEGER*4 SYS$CREATE COMMON /UFO/ CHAN- FAB.FAB$L_FOP = FAB.FAB$L_FOP .OR. FAB$M_UFO STATUS = SYS$CREATE(FAB) CHAN = FAB.FAB$L_STV UFO_CREATE = STAT"yUS ENDww Ǐ) INTEGER*4 FUNCTION UFO_OPEN(FAB,RAB,LUN) INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB INTEGER*2 CHAN INTEGER*4 STATUS INTEGER*4 SYS$OPEN COMMON /UFO/ CHAN- FAB.FAB$L_FOP = FAB.FAB$L_FOP .OR. FAB$M_UFO STATUS = SYS$OPEN(FAB) CHAN = FAB.FAB$L_STV UFO_OPEN = STATUS ENDww@9Ǐ INCLUDE '($FABDEF)' INCLUDE '($XABDEF)' INTEGER SIZE_N_RDATE INTEGER*4 SIZE INTEGERz*4 RDT(2) EXTERNAL SIZE_N_RDATE RECORD /FABDEF/ FABC COMMON /FABDEF/ FAB RECORD /XABDEF/ XABC COMMON /XABDEF/ XAB COMMON /WORK/ SIZE, RDT OPEN (UNIT = 1, 2 FILE = 'USEROPEN.FOR', 2 STATUS = 'OLD', 2 USEROPEN = SIZE_N_RDATE) PRINT *,SIZE PRINT *,RDT CLOSE (1) END# INTEGER FUNCTION SIZE_N_RDATE(FAB) INCLUDE '($FABDEF)' INCLUDE '($XABDEF)' INTEGER*4 SIZE INTEGER*4 RDT(2) RECORD /FABDEF/ FABC COMMON /FABDEF/ FAB RECORD /XABDEF/ XABC COMMON /#{XABDEF/ XAB COMMON /WORK/ SIZE, RDT INTEGER STATUS INTEGER SYS$OPEN STATUS = SYS$OPEN(FAB) SIZE = FAB.FAB$L_ALQ RDT(1) = XAB.XAB$Q_RDT(1) RDT(2) = XAB.XAB$Q_RDT(2) SIZE_N_RDATE = STATUS ENDww@Ǐ PROGRAM PASSWORD** P A S S W O R D* INTEGER*4 SYS$WAKE INCLUDE '($SSDEF)' INTEGER*4 ISTAT ISTAT = SYS$WAKE(,'PASSADMIN'), IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ENDwwPǏ PROGRAM WHAT IMPLICIT NONE| INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)'C Internal variables INTEGER*4 I, FLG, LOUT4 INTEGER*4 LIB$GETJPI, LIB$WAIT, ISTAT, ST, ND, ITMP- INTEGER*4 SYS$SETPRI, SYS$FORCEX, SYS$DELPRCC INTEGER*4 R_PID INTEGER*4 MAX_PID / 16384 / REAL*4 WAIT / 10.0 / INTEGER*4 CPU_PER / 0 / INTEGER*4 FIRST / 0 / CHARACTER*1 TYP;C--------------Returned Details of the Process------------- INTEGER*4 PID INTEGER*4 GROUP INTEGER*4 PROC_COUNT INTEGER*4 MAST_PID INTEGER*4} CPU_TIME INTEGER*4 BASE_PRIO INTEGER*4 MODE CHARACTER*39 IMAGE CHARACTER*7 TERM CHARACTER*15 PROC_NAME CHARACTER*12 USERNAME( INTEGER*4 L_CPU(16384) / 16384 * 0 /( INTEGER*4 L_FLT(16384) / 16384 * 0 / INTEGER*4 FLT INTEGER*4 FLT_PER INTEGER*4 WORK LOUT = 6100 R_PID = -1 PRINT *, ' ' PRINT *, ' ' PRINT *, ' ' WRITE(LOUT,101,ERR=9999)9101 FORMAT(' Username Process PID Image', 1 ' Term Pri Cpu% Ws Flts' )~ WRITE(LOUT,102,ERR=9999)=102 FORMAT('-----------------------------------------------', 1 '--------------------' )1200 ISTAT = LIB$GETJPI( JPI$_PID, R_PID, ,PID, ,)$ IF(ISTAT .NE. SS$_NORMAL) GOTO 1000+ ISTAT = LIB$GETJPI(JPI$_GRP,PID,,GROUP, ,)$ IF(ISTAT .NE. SS$_NORMAL) GOTO 1000: ISTAT = LIB$GETJPI(JPI$_JOBPRCCNT, PID,, PROC_COUNT, ,)8 ISTAT = LIB$GETJPI(JPI$_MASTER_PID, PID,, MAST_PID, ,)8 ISTAT = LIB$GETJPI(JPI$_CPUTIM, PID,, CPU_TIME, ,)9 ISTAT = LIB$GETJPI(JPI$ _PRIB, PID,, BASE_PRIO, ,)4 ISTAT = LIB$GETJPI(JPI$_MODE, PID,, MODE, ,)4 ISTAT = LIB$GETJPI(JPI$_PPGCNT, PID,, WORK, ,)3 ISTAT = LIB$GETJPI(JPI$_PAGEFLTS, PID,, FLT, ,)3 ISTAT = LIB$GETJPI(JPI$_IMAGNAME, PID,, ,IMAGE,)2 ISTAT = LIB$GETJPI(JPI$_TERMINAL, PID,, ,TERM,)7 ISTAT = LIB$GETJPI(JPI$_PRCNAM, PID,, ,PROC_NAME,)6 ISTAT = LIB$GETJPI(JPI$_USERNAME, PID,, ,USERNAME,)# IF(ISTAT .NE. SS$_NORMAL) GOTO 200& IF (PROC_NAME(1:1) .EQ. '<') GOTO 200 IF (MAST_PID .EQ. 0) GOTO 200 TYP = ' ' IF (MODE .EQ. 0) THEN GOTO 200 ELSE IF (MODE .EQ. 2) THEN TYP = 'B' ELSE IF (MODE .EQ. 1) THEN TYP = 'N' END IF! IF (MAST_PID .NE. PID) TYP = 'S' IF ( L_CPU(PID) .NE. 0 ) THEN CPU_PER = IFIX( 100.0 *2 1 FLOAT( (CPU_TIME-L_CPU(PID)) ) / (WAIT * 100) ) ELSE CPU_PER = 0 END IF L_CPU(PID) = CPU_TIME IF ( L_FLT(PID) .NE. 0 ) THEN FLT_PER = FLT - L_FLT(PID) ELSE FLT_PER = 0 END IF L_FLT(PID) = FLTCC  Print Report On ProcessC FLG = 0 DO I = 39, 1, -1 ITMP = ICHAR(IMAGE(I:I))- IF ((ITMP .GT. 32) .AND. (FLG .EQ. 0)) THEN FLG = 1 ND = 1 END IF IF (IMAGE(I:I) .EQ. ']') THEN ST = I + 1 GOTO 300 END IF END DO IMAGE = ' ' ST = 1 ND = 1 GOTO 400300 DO I = ST, ND< IF ((IMAGE(I:I) .EQ. ';') .OR. (IMAGE(I:I) .EQ. '.')) THEN ND = I - 1 IF (ND .LT. ST) ND = ST GOTO 400 END IF END DO'400 IF ((ND - ST) .GT. 16) ND = ST + 16 WRITE(LOUT,402,ERR=9999)* 1 USERNAME, PROC_NAME, PID, IMAGE(ST:ND),0 1 TERM, BASE_PRIO, CPU_PER, WORK, FLT_PER, TYP=402 FORMAT( ' ',A10,1X,A12,Z5,1X,A13,1X,A5,1X,I2,1X,I3,1X,I4, 1 1X,I4,1X,A1)(1000 IF (ISTAT .EQ. SS$_NOMOREPROC) THEN ISTAT = LIB$WAIT(WAIT) GOTO 100 ELSE GOTO 200 END IF*9999 PRINT *,'Error writing to SYS$OUTPUT' ENDww@C** W P L _ D A K S I M* PROGRAM DA$KSIM IMPLICIT INTEGER (A - Z) INCLUDE '($SSDEF)'$ INCLUDE 'SYS$INCLUDE:DPQENTRY.PAR'" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'" INCLUDE 'SYS$INCLUDE:ANALOG.PAR'" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'! BYTE PRCNAM(12) ! Process Name' 2 /'D','A','$','K','S','I','M',5*' '/$ CHARACTER*12 RECORD_ID ! Record ID, CHARACTER*12 PREVIOUS ! Previous Record ID& CHARACTER*12 QUEUE_NAME ! Queue Name0 CHARACTER*15 OPTION ! Integer, Hex, or Binary- CHARACTER*12 P_QUEUE ! Previous Queue Name4 INTEGER*4 P_QUEUE_LEN ! Previous Queue Name Length' INTEGER*4 P _LEN ! Length of PREVIOUS1 INTEGER*4 ERROR_RETURN(2) ! Error Return Status1 INTEGER*4 GET_RECORD_ID ! Routine To Get Rec ID, INTEGER*4 GET_VALUE ! Routine To Get Value/ INTEGER*4 PUT_TO_QUEUE ! Routine To Put Queue0 INTEGER*4 LIB$GET_INPUT ! Screen Input Routine. INTEGER*4 INPUT_LEN ! Length of Input String1 INTEGER*4 QUEUE_NAME_LEN ! Length of Queue Name0 INTEGER*4 SPECIAL(5) ! Special Fields (VECTOR)1 INTEGER*4 STAT_WORD ! Status Word For LQ$PUTQUE# INTEGER*4 STATUS ! Return Status, INTEGER*4 VALUE ! Integer Value For Queue* INTEGER*4 VCSID /762/ ! Vector System ID& INTEGER*4 X ! Horizontal Coordinate$ INTEGER*4 Y ! Vertical Coordinate& STRUCTURE /WORK/ ! Define Work Area UNION ! MAP ! CHARACTER*255 STRING ! CHARACTER*32 BINARY_STRING ! END MAP ! MAP ! BYTE ARRAY(255) !! CHARACTER*1 BINARY_ARRAY(32) ! END MAP ! END UNION ! END STRUCTURE !- RECORD /WORK/ WORK ! Work Area Is a Record( COMMON /WORK/ WORK ! Common Work Area COMMON /JUNK/ RECORD_ID, 2 SPECIAL CALL BEGIN ! Crt Setup! CALL CRTCL ! Clear CRT Screen& X = 5 ! X Coord for GET_RECORD_ID' Y = 10 ! Y Coord for GET_RECORD_ID7 CALL DA$SIMINT( VCSID, ! Initialization using VCSID, 2 PRCNAM, ! Process Name, 2 SPECIAL, ! Special Fields,) 2 ERROR_RETURN ) ! Error Return StatusJ100 DO WHILE (GET_RECORD_ID(RECORD_ID,PREVIOUS,P_LEN,X,Y) .EQ. SS$_NORMAL), IF (P_QUEUE(1:12) .NE. ' ') THEN CALL PLACE(X+12,12) CALL SWRT(P_QUEUE_LEN,P_QUEUE) END IF CALL PLACE(X,12)$ STATUS = LIB$GET_INPUT( QUEUE_NAME, 2 'Queue Name? ', 2 QUEUE_NAME_LEN) IF ((.NOT. STATUS)) GOTO 32767 IF (QUEUE_NAME_LEN .EQ. 0) THEN QUEUE_NAME = P_QUEUE QUEUE_NAME_LEN = P_QUEUE_LEN END IF P_QUEUE_LEN = QUEUE_NAME_LEN P_QUEUE = QUEUE_NAME120 CALL PLACE(X,14) STATUS = LIB$GET_INPUT( OPTION, 2 'I,H, or B? ', 2 INPUT_LEN)7 IF ((.NOT. STATUS) .OR. (INPUT_LEN .EQ. 0)) GOTO 32767. IF (INDEX('IHB',OPTION(1:1)) .EQ. 0) GOTO 120! STATUS = GET_VALUE( OPTION(1:1), 2 VALUE ) IF (.NOT. STATUS) GOTO 32767 STAT_WORD = 00 QUEUE_NAME(QUEUE_NAME_LEN+1:8) = ' '8 STATUS = PUT_TO_QUEUE(VCSID,QUEUE_NAME,VALUE,STAT_WORD) IF (.NOT. STATUS) GOTO 32767 198 END DO32767 CALL CRTCL END ** G e t _ R e c o r d _ I d*- INTEGER*4 FUNCTION GET_RECORD_ID( RECORD_ID, 2 PREVIOUS, 2 P_LEN, 2 X,Y ) IMPLICIT NONE$ INCLUDE 'SYS$INCLUDE:DPQENTRY.PAR'" INCLUDE 'SYS$INCLUDE:ANALOG.PAR' CHARACTER*12 RECORD_ID CHARACTER*12 PREVIOUS INTEGER*4 P_LEN INTEGER*4 LIB$GET_INPUT INTEGER*4 INPUT_LEN INTEGER*4 STATUS INTEGER*4 X INTEGER*4 Y( 5 IF ((X .GT. 0) .AND. (Y .GT. 0)) THEN. IF (PREVIOUS(1:12) .NE. ' ') THEN CALL PLACE(X+11,Y) CALL SWRT(P_LEN,PREVIOUS) END IF CALL PLACE(X,Y) END IF<10 STATUS = LIB$GET_INPUT(RECORD_ID,'Record Id? ',INPUT_LEN) IF (.NOT. STATUS) GOTO 327671 IF (INPUT_LEN .GT. DPQ$_RECORD_ID_LENGTH) GOTO 5 IF (INPUT_LEN .EQ. 0) THEN RECORD_ID = PREVIOUS INPUT_LEN = P_LEN END IF P_LEN = INPUT_LEN PREVIOUS = RECORD_ID32767 GET_RECORD_ID = STATUS RETURN END ** G e t _ V a l u e*+ INTEGER*4 FUNCTION GET_VALUE(OPTION,VALUE) IMPLICIT NONE CHARACTER*1 OPTION INTEGER*4 VALUE INTEGER*4 STATUS INTEGER*4 ENTER_INTEGER INTEGER*4 ENTER_HEXVALU INTEGER*4 ENTER_BITVALU CALL CRTCL3 IF (OPTION .EQ. 'I') STATUS = ENTER_INTEGER(VALUE)3 IF (OPTION .EQ. 'H') STATUS = ENTER_HEXVALU(VALUE)3 IF (OPTION .EQ. 'B') STATUS = ENTER_BITVALU(VALUE) IF (.NOT. STATUS) GOTO 32767 CALL CRTCL32767 GET_VALUE = STATUS RETURN END ** E n t e r _ I n t e g e r*( INTEGER*4 FUNCTION ENTER_INTEGER(VALUE) CHARACTER*5 YES INTEGER*4 VALUE INTEGER*4 STATUS INTEGER*4 DISPLAY_BITS INTEGER*4 STR$UPCASE INTEGER*4 READ_PROMPT CALL PLACE(10,10)  CALL SWRT(16,'Integer Value: ') ACCEPT *,VALUE CALL CRTCL STATUS = DISPLAY_BITS(VALUE) CALL PLACE (1,24)? STATUS = READ_PROMPT( 'Is This Correct? ',17, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF+ IF( YES(1:1) .NE. 'Y') STATUS = -1032767 ENTER_INTEGER = STATUS RETURN END ** E n t e r _ H e x v a l u*( INTEGER*4 FUNCTION ENTER_HEXVALU(VALUE) CHARACTER*5 YES CHARACTER*10 HEXVAL INTEGER*4 VALUE INTEGER*4 STATUS INTEGER*4 INPUT_LEN INTEGER*4 LIB$GET_INPUT INTEGER*4 OTS$CVT_TZ_L INTEGER*4 STR$UPCASE INTEGER*4 READ_PROMPT INTEGER*4 DISPLAY_BITS CALL PLACE(10,10) STATUS = LIB$GET_INPUT( HEXVAL, 2 'Hex Value: ', 2 INPUT_LEN ) IF (.NOT. STATUS) GOTO 327679 STATUS = OTS$CVT_TZ_L( HEXVAL(1:INPUT_LEN), ! Hex String 2 VALUE, ! Integer Value 2 %VAL(4), ! Integer Size 2 %VAL(1) ) ! Blanks = Zero IF (.NOT. STATUS) GOTO 32767 CALL CRTCL10 STATUS = DISPLAY_BITS(VALUE) CALL PLACE (1,24)? STATUS = READ_PROMPT( 'Is This Correct? ',17, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF+ IF( YES(1:1) .NE. 'Y') STATUS = -1032767 ENTER_HEXVALU = STATUS RETURN END ** E n t e r _ B i t v a l u*( INTEGER*4 FUNCTION ENTER_BITVALU(VALUE) INTEGER*4 VALUE INTEGER*4 NO INTEGER*4 STATUS INTEGER*4 READ_PROMPT INTEGER*4 STR$UPCASE INTEGER*4 OTS$CVT_TI_L INTEGER*4 OTS$CVT_TB_L INTEGER*4 STR$TRANSLATE INTEGER*4 X CHARACTER*1 TRANSL_FR CHARACTER*1 TRANSL_TO CHARACTER*5 YES& STRUCTURE /WORK/ ! Define Work Area UNION ! MAP ! CHARACTER*255 STRING ! CHARACTER*32 BINARY_STRING ! END MAP ! MAP ! BYTE ARRAY(255) !! CHARACTER*1 BINARY_ARRAY(32) ! END MAP ! END UNION ! END STRUCTURE !- RECORD /WORK/ WORK ! Work Area Is a Record( COMMON /WORK/ WORK ! Common Work Area VALUE = 010 STATUS = DISPLAY_BITS(VALUE)380 CALL PLACE( 1,19)$ CALL SWRT(19,'Enter Bit To Toggle') CALL PLACE ( 1,20)/ CALL SWRT(30,'Exit With a Return Only ') CALL PLACE ( 1,21)< CALL SWRT(43,'Or "A" For All Bits Or "N" For No Bits ') YES(1:3) = ' ' CALL PLACE (40,21)1 STATUS = READ_PROMPT( '? ',2, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES)$381 IF( YES(1:1) .EQ. ' ') GO TO 335! IF( YES(1:1) .NE. 'A') GO TO 360 VALUE = -1 GO TO 10$360 IF( YES(1:1) .NE. 'N') GO TO 361 VALUE = 0 GO TO 10361 STATUS = OTS$CVT_TI_L( YES, 2 X, 2 %VAL(4), 2 %VAL(1) )' IF( X .LT. 0 .OR. X .GT. 31) GO TO 380 X = X + 1 NO = 33 - X$ IF (WORK.BINARY_ARRAY(NO) .EQ. 'Y') 2 THEN WORK.BINARY_ARRAY(NO) = ' ' ELSE WORK.BINARY_ARRAY(NO) = 'Y' END IF J = IFIX(FLOAT((X+15)/16)) I = X - ((J*16)-16) CALL PLACE( 62-I*3,14-J*3)% CALL SWRT ( 1,WORK.BINARY_ARRAY(NO)) GO TO 380 335 CONTINUE CALL PLACE (1,24)? STATUS = READ_PROMPT( 'Is This Correct? ',17, ! Prompt, Length 2 YES, I, ! Answer, Length 2 0 ) ! No Timeout STATUS = STR$UPCASE(YES,YES) IF (.NOT. STATUS) THEN CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 32767 END IF# IF( YES(1:1) .NE. 'Y') THEN STATUS = -10 GOTO 32767 END IF TRANSL_FR = ' ' ! Space TRANSL_TO = '0' ! Zero STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string/ 2 WORK.BINARY_STRING(1:32), ! changing blanks) 2 TRANSL_TO, TRANSL_FR ) ! to zeroes.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status TRANSL_FR = 'Y' ! Y TRANSL_TO = '1' ! One STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string+ 2 WORK.BINARY_STRING(1:32), ! changing Ys' 2 TRANSL_TO, TRANSL_FR ) ! to Ones.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status1 STATUS = OTS$CVT_TB_L( WORK.BINARY_STRING(1:32), 2 VALUE, 2 %VAL(4), )32767 ENTER_BITVALU = STATUS RETURN END ** D i s p l a y B i t s*' INTEGER*4 FUNCTION DISPLAY_BITS(VALUE) INCLUDE '($SSDEF)' CHARACTER*1 TRANSL_FR CHARACTER*1 TRANSL_TO INTEGER*4 NO INTEGER*4 OTS$CVT_L_TB INTEGER*4 STR$TRANSLATE INTEGER*4 STATUS INTEGER*4 VALUE INTEGER*2 X& STRUCTURE /WORK/ ! Define Work Area UNION ! MAP ! CHARACTER*255 STRING ! CHARACTER*32 BINARY_STRING ! END MAP ! MAP ! BYTE ARRAY(255) !! CHARACTER*1 BINARY_ARRAY(32) ! END MAP ! END UNION ! END STRUCTURE !- RECORD /WORK/ WORK ! Work Area Is a Record( COMMON /WORK/ WORK ! Common Work Area CALL PLACE(13, 7)2 CALL SWRT(33,'31 30 29 28 27 26 25 24 23 22 21 ') CALL SWRT(14,'20 19 18 17 16') CALL PLACE ( 13,10)2 CALL SWRT(33,'15 14 13 12 11 10 9 8 7 6 5 ') CALL SWRT(14,' 4 3 2 1 0') 10 STATUS = OTS$CVT_L_TB( VALUE,& 2 %DESCR(WORK.BINARY_STRING(1:32)), 2 %VAL(32), 2 %VAL(4) ) TRANSL_FR = '0' TRANSL_TO = ' ' ! Space STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string/ 2 WORK.BINARY_STRING(1:32), ! changing zeroes) 2 TRANSL_TO, TRANSL_FR ) ! to blanks.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status TRANSL_FR = '1' TRANSL_TO = 'Y' STATUS = STR$TRANSLATE( !. 2 WORK.BINARY_STRING(1:32), ! Convert string- 2 WORK.BINARY_STRING(1:32), ! changing ones% 2 TRANSL_TO, TRANSL_FR ) ! to Ys.? IF (.NOT. STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) ! Check Status DO 355 X = 1, 32 J = IFIX(FLOAT(X+15) / 16) I = X - ((J*16) - 16) CALL PLACE(62-I*3,14-J*3) NO = 33 - X&355 CALL SWRT(1,WORK.BINARY_ARRAY(NO))32767 DISPLAY_BITS = SS$_NORMAL RETURN END **  P u t _ T o _ Q u e u e*= INTEGER*4 FUNCTION PUT_TO_QUEUE(VCSID,QUEUE,VALUE,STAT_WORD) IMPLICIT INTEGER*2 (A - Z)$ INCLUDE 'SYS$INCLUDE:DPQENTRY.PAR'" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'" INCLUDE 'SYS$INCLUDE:CONCOM.PAR'" INCLUDE 'SYS$INCLUDE:ANALOG.PAR'" INCLUDE 'SYS$INCLUDE:CTLQUE.PAR' CHARACTER*12 RECORD_ID CHARACTER*12 QUEUE INTEGER*4 VCSID INTEGER*4 STATUS INTEGER*4 VALUE INTEGER*4 STAT_WORD INTEGER*4 SPECIAL(5) INTEGER*4 ERROR_RETURN(2) INTEGER*4 QUEUE!_NUMBER INTEGER*4 BUFLEN0 INTEGER*4 SYS$GETTIM ! Get Current Binary Time COMMON /JUNK/ RECORD_ID, 2 SPECIAL STRUCTURE /WORK/ UNION MAP CHARACTER*12 QUEUE_NAME END MAP MAP BYTE QUEUE(12) END MAP END UNION END STRUCTURE RECORD /WORK/ WORK STRUCTURE /BUFFER/ UNION MAP BYTE BUFFER(28) END MAP MAP CHARACTER*12 RID INTEGER*4 CURRENT_TIME(2) INTEGER*4 SWORD INTEGER*4 VALUE END MAP END UNION END STRUCTURE RECORD /BUFFER/ BUF WORK.QUEUE_NAME = QUEUE QUEUE_NUMBER = 09 STATUS = SYS$GETTIM(BUF.CURRENT_TIME) ! Get Current Time BUF.RID = RECORD_ID BUF.SWORD = STAT_WORD BUF.VALUE = VALUE BUFLEN = 281 CALL LQ$PUTQUE( VCSID, ! Vector System ID Code 2 WORK.QUEUE, ! Queue Name) 2 BUF.BUFFER, ! Buffer To Put To Queue$ 2 BUFLEN, ! Length of the Buffer( 2 QUEUE_NUMBER, ! Number of the Queue 2 SPECIAL, ! Special Junk# 2 ERROR_RETURN ) ! Return Status, IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) THEN STATUS = 0 GOTO 32767 END IF32767 PUT_TO_QUEUE = STATUS RETURN END + SUBROUTINE DA$SIMINT( VCSID, RECORD_NAME,  2 SPECIAL, ERROR_RETURN ) IMPLICIT INTEGER (A-Z)CIC Sysint.par contains the paramters and definitions with the syc$_ prefixC" INCLUDE 'SYS$INCLUDE:SYSINT.PAR'CIC Syserr.par contains the parameters and definitions of the error returnsC" INCLUDE 'SYS$INCLUDE:SYSERR.PAR'CJC Dainit.par contains the parameters and definitions with the da$i_ prefixC" INCLUDE 'SYS$INCLUDE:DAINIT.PAR'CJC Dmscom.par contains the parameters and definitions with the dms$_ prefixC" INCLUDE 'SYS$INCLUDE:DMSCOM.PAR'C HC======================================================================  C!C Define the subprocess variablesC, BYTE FILE_NAME ( DA$I_FILE_NAME_LENGTH )- BYTE RECORD_NAME ( DA$I_RECORD_NAME_LENGTH )( DATA FILE_NAME / 'V','G','E','N',8*' '/ DIMENSION INITREC( SYC$_IRSIZE)C9C Define record as integer for the initialization routineC INTEGER*4 FILE_NUMBER INTEGER*4 RECORD_NUMBER INTEGER*4 ERROR_RETURN ( 2 ) INTEGER*4 SPECIAL ( 5 ) INTEGER*4 ERR_RTN(2)  CCC Associate with system event flags cluster to reference the systemC startup flag (#64).CC+ CALL LU$ASCEFC ( VCSID, EVENT_FLAG_NUMBER,( 2 EVENT_FLAG_CLUSTER_NAME, PROTECTION, 2 PERMENANT, ERROR_RETURN )6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30C@C Set up virtual address space for data accesses by the process ?C Establishes a relationship (via SPECIAL) between this processC and interface buffer. C 0 CALL LU$SETBUF ( VCSID, SPECIAL, ERROR_RETURN )0 IF (ERROR_RETURN(1) .NE. DMS$_SUCCESS) GO TO 30C@C Set appropriate initialization flag to indicate initializationC processing is in progress.C> CALL LU$INTFLG ( VCSID, SET_FLAG, SPECIAL(4), ERROR_RETURN )C6 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCRC Read initialization record from the VGEN initialization file (VGEN.DAT) for the 8C processing parameters necessary to start this process.=C This record contains all VGEN information for this process,.C including process specidific data file name.C RECORD_NUMBER = 0 FILE_NUMBER = 0C0 CALL LR$GETREC ( VCSID, FILE_NAME, RECORD_NAME, 2 FILE_NUMBER, RECORD_NUMBER,$ 2 INITREC, SPECIAL, ERROR_RETURN )C5 IF ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CCEC Validate record by comparing passed VCS ID and the corresponding IDHC in the initialization record; If the ID's are not equal, the record is7C invalid and an appropriate error return is indicated.C0 IF ( INITREC ( SYC$_VCSIDNM ) .NE. VCSID ) ThenC* ERROR_RETURN ( 1 ) = DMS$_ILL_VCS ERROR_RETURN ( 2 ) = 0 GO TO 30C ENDIFC CJC Set priority to the priority specified in the VGEN initialization recordC+ CALL LU$SETPRI( INITREC( SYC$_PRIOFFSET) )>C Clear initialization flag indicating initialization completeC 20 CONTINUE? CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC@C Wait for system startup flag (event flag #64) to be set before?C continuing to synchronize the startup of all system software.C; CALL LU$WAITFR ( VCSID, EVENT_FLAG_NUMBER, ERROR_RETURN )C6 If ( ERROR_RETURN ( 1 ) .NE. DMS$_SUCCESS ) GO TO 30CC&C Normal return; set up success statusC" ERROR_RETURN ( 1 ) = DMS$_SUCCESS ERROR_RETURN ( 2 ) = 0CC Purge working set pagesC$ CALL LU$PURGWS (VCSID,ERROR_RETURN) GO TO 40C2C Error return insure that the init flag is reset.C<30 CALL LU$INTFLG ( VCSID, CLEAR_FLAG, SPECIAL(4), ERR_RTN )C 40 RETURN ENDww*r縷 INTEGER*4 ERROR INTEGER*4 FLAGS /1/G INTEGER*4 LIB$SIGNALT CHARACTER*80 MESSAGEE INTEGER*4 MESSAGE_LEN BYTE OUTARR(0:3) INTEGER*4 STATUS/ TYPE 100#100 FORMAT('$Enter Error Number: ')s ACCEPT *,ERRORm"C STATUS = LIB$SIGNAL(%VAL(ERROR))@ STATUS = LIB$SYS_GETMSG(ERROR,MESSAGE_LEN,MESSAGE,FLAGS,OUTARR) PRINT *,MESSAGE(1:MESSAGE_LEN)E ENDwwDEF)' INTEGER*4 FLAGS /1/ INTEGER*4 IER CHARACTER*(*) MESSAGE INTEGER*4 STATUS MESSAGE = ' ' CALL * PROGRAM SYSTATE*G* S Y S T A T*A1* Uses EXTERNAL declarations from in STATEDEF.MAR*  IMPLICIT NONE INTEGER*4 SYS$GETJPIW INTEGER*4 LIB$GET_FOREIGN INTEGER*4 LIB$GET_LUN INTEGER*4 LIB$DATE_TIME INTEGER*4 STR$TRANSLATE INTEGER*4 STR$UPCASE INCLUDE '($JPIDEF)'R INCLUDE '($SSDEF)' CHARACTER*80 BLANKS INTEGER*4 CONTEXT CHARACTER*23 DATETIME INTEGER*4 GPGCNTR INTEGER*2 I CHARACTER*55 IMAGNAME INTEGER*4 IMAGNAME_LENM INTEGER*4 IMGST INTEGER*4 ISTAT CHARACTER*13 JOB_TYPE INTEGER*4 LOGINTIM(2) CHARACTER*39 LOGINTIMEM INTEGER LUN INTEGER*4 MASTER_PIDI CHARACTER*8 MASTER_PROCID INTEGER*4 MODEG BYTE OPTIONf INTEGER*4 PAGEFLTS CHARACTER*50 PARAMI INTEGER*2 PARAM_LEN INTEGER*4 PID CHARACTER*15 PRCNAM INTEGER*4 PRCNAM_LENI INTEGER*4 PRIORITYU CHARACTER*8 PROCIDS INTEGER*4 SIZEf INTEGER*4 STATE CHARACTER*5 STATE_STR INTEGER*4 STATUSO CHARACTER*7 TERMINALE INTEGER*4 TERMINAL_LEN  CHARACTER*1 TRANSL_FR CHARACTER*1 TRANSL_TO CHARACTER*12 USERNAME INTEGER*4 USERNAME_LEN CN)C E x t e r n a l D e f i n i t i o n s)CEC Module: STATEDEFC- EXTERNAL SCH$C_CEF  EXTERNAL SCH$C_COLPG( EXTERNAL SCH$C_COMr EXTERNAL SCH$C_COMO EXTERNAL SCH$C_CURr EXTERNAL SCH$C_FPG$ EXTERNAL SCH$C_HIB EXTERNAL SCH$C_HIBO EXTERNAL SCH$C_LEF EXTERNAL SCH$C_LEFO EXTERNAL SCH$C_MWAITD EXTERNAL SCH$C_PFWG EXTERNAL SCH$C_SUSP EXTERNAL SCH$C_SUSPO STRUCTURE /ITMLST/  UNION MAPT INTEGER*2 BUFLEN INTEGER*2 ITMCOD INTEGER*4 BUFADR INTEGER*4 RETADR END MAPO MAPL INTEGER*4 END_LIST END MAPr END UNION END STRUCTURE STRUCTURE /IOSBLK/O INTEGER*4 STATUS, ZEROED END STRUCTURE RECORD /ITMLST/ JPI_LIST(14)O RECORD /IOSBLK/ IOSBE TRANSL_FR = CHAR(0) TRANSL_TO = ' ' JPI_LIST( 1).BUFLEN = 8 JPI_LIST( 1).ITMCOD = JPI$_PIDl JPI_LIST( 1).BUFADR = %LOC(PID) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).BUFLEN = 15 " JPI_LIST( 2).ITMCOD = JPI$_PRCNAM# JPI_LIST( 2).BUFADR = %LOC(PRCNAM)O' JPI_LIST( 2).RETADR = %LOC(PRCNAM_LEN)e JPI_LIST( 3).BUFLEN = 8& JPI_LIST( 3).ITMCOD = JPI$_MASTER_PID' JPI_LIST( 3).BUFADR = %LOC(MASTER_PID)U JPI_LIST( 3).RETADR = 0 JPI_LIST( 4).BUFLEN = 55$ JPI_LIST( 4).ITMCOD = JPI$_IMAGNAME% JPI_LIST( 4).BUFADR = %LOC(IMAGNAME)Q) JPI_LIST( 4).RETADR = %LOC(IMAGNAME_LEN)t JPI_LIST( 5).BUFLEN = 8$ JPI_LIST( 5).ITMCOD = JPI$_LOGINTIM( JPI_LIST( 5).BUFADR = %LOC(LOGINTIM(1)) JPI_LIST( 5).RETADR = 0 JPI_LIST( 6).BUFLEN = 4 JPI_LIST( 6).ITMCOD = JPI$_MODE! JPI_LIST( 6).BUFADR = %LOC(MODE)r JPI_LIST( 6).RETADR = 0 JPI_LIST( 7).BUFLEN = 4$ JPI_LIST( 7).ITMCOD = JPI$_PAGEFLTS% JPI_LIST( 7).BUFADR = %LOC(PAGEFLTS). JPI_LIST( 7).RETADR = 0 JPI_LIST( 8).BUFLEN = 4! JPI_LIST( 8).ITMCOD = JPI$_STATE" JPI_LIST( 8).BUFADR = %LOC(STATE) JPI_LIST( 8).RETADR = 0 JPI_LIST( 9).BUFLEN = 7$ JPI_LIST( 9).ITMCOD = JPI$_TERMINAL% JPI_LIST( 9).BUFADR = %LOC(TERMINAL)h) JPI_LIST( 9).RETADR = %LOC(TERMINAL_LEN)  JPI_LIST(10).BUFLEN = 12 $ JPI_LIST(10).ITMCOD = JPI$_USERNAME% JPI_LIST(10).BUFADR = %LOC(USERNAME) ) JPI_LIST(10).RETADR = %LOC(USERNAME_LEN)n JPI_LIST(11).BUFLEN = 4 JPI_LIST(11).ITMCOD = JPI$_PRI$% JPI_LIST(11).BUFADR = %LOC(PRIORITY)o JPI_LIST(11).RETADR = 0 JPI_LIST(12).BUFLEN = 4" JPI_LIST(12).ITMCOD = JPI$_PPGCNT! JPI_LIST(12).BUFADR = %LOC(SIZE)P JPI_LIST(12).RETADR = 0 JPI_LIST(13).BUFLEN = 4" JPI_LIST(13).ITMCOD = JPI$_GPGCNT# JPI_LIST(13).BUFADR = %LOC(GPGCNT)U JPI_LIST(13).RETADR = 0 JPI_LIST(14).END_LIST = 0 CONTEXT = -1l OPTION = 1o7 BLANKS = ' ' //.. 2 ' ', STATUS = LIB$GET_FOREIGN(PARAM,,PARAM_LEN,)4 IF ((.NOT. STATUS) .OR. (PARAM_LEN .EQ. 0)) GOTO 50; STATUS = STR$UPCASE(PARAM(1:PARAM_LEN),PARAM(1:PARAM_LEN)) % IF (PARAM(1:2) .EQ. 'PF') OPTION = 2E50 IF (OPTION .EQ. 1) THEN PRINT 801, 2 ' JOB ID ', 2 'TERM ',_) 2 'USERNAME ',c& 2 'PROC NAME ',1 2 'PROGRAM NAME ',u 2 'STATE', 2 ' SIZE ', 2 'PR' ELSE IF (OPTION .EQ. 2) THEN PRINT 801, 2 ' JOB ID ', 2 'TERM ',I) 2 'USERNAME ',D& 2 'PROC NAME ',1 2 'PROGRAM NAME ',r 2 'STATE', 2 'PAGE FLTS ', 2 'PR' END IFN DO WHILE (.TRUE.)+ ISTAT = SYS$GETJPIW(,CONTEXT,,JPI_LIST,,,)_* IF (ISTAT .EQ. SS$_NOMOREPROC) GOTO 32767/C IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)).& CALL OTS$CVT_L_TZ(PID,PROCID,%VAL(8))4 CALL OTS$CVT_L_TZ(MASTER_PID,MASTER_PROCID,%VAL(8))& CALL SYS$ASCTIM(,LOGINTIME,LOGINTIM,)( IF (LOGINTIM(1) .EQ. 0) LOGINTIME = ' ' CALL LIB$DATE_TIME(DATETIME)$$ IF (MODE .EQ. 0) JOB_TYPE = 'Other'& IF (MODE .EQ. 1) JOB_TYPE = 'Network'$ IF (MODE .EQ. 2) JOB_TYPE = 'Batch'* IF (MODE .EQ. 3) JOB_TYPE = 'Interactive' STATE_STR = ' '% IF (STATE .EQ. %LOC(SCH$C_CEF)) THENS STATE_STR = 'CEF'o, ELSE IF (STATE .EQ. %LOC(SCH$C_COLPG)) THEN STATE_STR = 'COLPG'* ELSE IF (STATE .EQ. %LOC(SCH$C_COM)) THEN STATE_STR = 'COM'I+ ELSE IF (STATE .EQ. %LOC(SCH$C_COMO)) THEN  STATE_STR = 'COMO'* ELSE IF (STATE .EQ. %LOC(SCH$C_CUR)) THEN STATE_STR = 'CUR'O* ELSE IF (STATE .EQ. %LOC(SCH$C_FPG)) THEN STATE_STR = 'FPG'a* ELSE IF (STATE .EQ. %LOC(SCH$C_HIB)) THEN STATE_STR = 'HIB'h+ ELSE IF (STATE .EQ. %LOC(SCH$C_HIBO)) THENb STATE_STR = 'HIBO'* ELSE IF (STATE .EQ. %LOC(SCH$C_LEF)) THEN STATE_STR = 'LEF'N+ ELSE IF (STATE .EQ. %LOC(SCH$C_LEFO)) THENN STATE_STR = 'LEFO', ELSE IF (STATE .EQ. %LOC(SCH$C_MWAIT)) THEN STATE_STR = 'MWAIT'H* ELSE IF (STATE .EQ. %LOC(SCH$C_PFW)) THEN STATE_STR = 'PFW'R+ ELSE IF (STATE .EQ. %LOC(SCH$C_SUSP)) THENt STATE_STR = 'SUSP', ELSE IF (STATE .EQ. %LOC(SCH$C_SUSPO)) THEN STATE_STR = 'SUSPO'S END IFo1 ISTAT = STR$TRANSLATE( USERNAME(1:USERNAME_LEN),  2 USERNAME(1:USERNAME_LEN), 2 TRANSL_TO, TRANSL_FR ) . IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)). IMAGNAME = IMAGNAME(1:IMAGNAME_LEN) // BLANKS( PRCNAM = PRCNAM(1:PRCNAM_LEN) // BLANKS0100 STATUS = INDEX(IMAGNAME(1:IMAGNAME_LEN),']') IF (STATUS .GT. 0) THEN, IMAGNAME = IMAGNAME(STATUS+1:55) // BLANKS GOTO 100 END IFd, I = INDEX(IMAGNAME,'.') ! Find Extension# IF (I .GT. 1) THEN ! Remove the7 IMAGNAME = IMAGNAME(1:I-1) // BLANKS ! File Extension END IF  ! IF (OPTION .EQ. 1) THEN PRINT 800, 2 PROCID,o 2 TERMINAL(1:TERMINAL_LEN), 2 USERNAME(1:USERNAME_LEN),_ 2 PRCNAM,E 2 IMAGNAME,  2 STATE_STR, 2 SIZE+GPGCNT, 2 PRIORITY ELSE IF (OPTION .EQ. 2) THENL PRINT 800, 2 PROCID,s 2 TERMINAL(1:TERMINAL_LEN),y 2 USERNAME(1:USERNAME_LEN),R 2 PRCNAM,_ 2 IMAGNAME, 2 STATE_STR, 2 PAGEFLTS,w 2 PRIORITY END IFE END DOI)800 FORMAT( 1X,A8,TR1,A7,TR1,A12,TR1,A15, ! 2 TR1,A14,TR1,A5TR1,I10,TR1,I2 )t)801 FORMAT( 1X,A8,TR1,A7,TR1,A12,TR1,A15,Q! 2 TR1,A14,TR1,A5TR1,A10,TR1,A2 )G 32767 ENDawwrray dimension error' RETURN END IF! STATUS = 2 ! Didn't Do the Job FOR$ERROR_MESSAGE = STATUS RETURN ENDww argument to math library' RETURN END IF" IF (IER .EQ. FOR$IOS_UNDEXP) THEN& MESSAGE = 'undefined exponentiation' RETURN END IF% IF (IER .EQ. FOR$IOS_LOGZERNEG) THEN1 MESSAGE = 'logarithm of zero or negative value' RETURN END IF% IF (IER .EQ. FOR$IOS_SQUROONEG) THEN+ MESSAGE = 'square root of negative value' RETURN END IF% IF (IER .EQ. FOR$IOS_SIGLOSMAT) THEN/ MESSAGE = 'significance lost in math library' RETURN END IF% IF (IER .EQ. FOR$IOS_FLOOVEMAT) THEN/ MESSAGE = 'floating overflow in math library' RETURN END IF% IF (IER .EQ. FOR$IOS_FLOUNDMAT) THEN0 MESSAGE = 'floating underflow in math library' RETURN END IF% IF (IER .EQ. FOR$IOS_ADJARRDIM) THEN. MESSAGE = 'adjustable array dimension error' RETURN END IF! STATUS = 2 ! Didn't Do the Job FOR$ERROR_MESSAGE = STATUS RETURN ENDww.ACCOUNT)) ITEM_LIST( 1).RETADR = %LOC(ACCOUNT_LEN) ITEM_LIST( 2).BUFLEN = 4" ITEM_LIST( 2).ITMCOD = UAI$_ASTLM' ITEM_LIST( 2).BUFADR = %LOC(UAF.ASTLM) ITEM_LIST( 2).RETADR = 0 ITEM_LIST( 3).BUFLEN = 4+ ITEM_LIST( 3).ITMCOD = UAI$_BATCH_ACCESS_P0 ITEM_LIST( 3).BUFADR = %LOC(UAF.BATCH_ACCESS_P) ITEM_LIST( 3).RETADR = 0 ITEM_LIST( 4).BUFLEN = 4+ ITEM_LIST( 4).ITMCOD = UAI$_BATCH_ACCESS_S0 ITEM_LIST( 4).BUFADR = %LOC(UAF.BATCH_ACCESS_S) ITEM_LIST( 4).RETADR = 0 ITEM_LIST( 5).BUFLEN = 4" ITEM_LIST( 5).ITMCOD = UAI$_BIOLM' ITEM_LIST( 5).BUFADR = %LOC(UAF.BIOLM) ITEM_LIST( 5).RETADR = 0 ITEM_LIST( 6).BUFLEN = 4" ITEM_LIST( 6).ITMCOD = UAI$_BYTLM' ITEM_LIST( 6).BUFADR = %LOC(UAF.BYTLM) ITEM_LIST( 6).RETADR = 0 ITEM_LIST( 7).BUFLEN = 32& ITEM_LIST( 7).ITMCOD = UAI$_CLITABLES( ITEM_LIST( 7).BUFADR = %LOC(UAF.TABLES) ITEM_LIST( 7).RETADR = 0 ITEM_LIST( 8).BUFLEN = 4# ITEM_LIST( 8).ITMCOD = UAI$_CPUTIM( ITEM_LIST( 8).BUFADR = %LOC(UAF.CPUTIM) ITEM_LIST( 8).RETADR = 0 ITEM_LIST( 9).BUFLEN = 40# ITEM_LIST( 9).ITMCOD = UAI$_DEFCLI% ITEM_LIST( 9).BUFADR = %LOC(UAF.CLI) ITEM_LIST( 9).RETADR = 0 ITEM_LIST(10).BUFLEN = 16# ITEM_LIST(10).ITMCOD = UAI$_DEFDEV( ITEM_LIST(10).BUFADR = %LOC(UAF.DEVICE) ITEM_LIST(10).RETADR = 0 ITEM_LIST(11).BUFLEN = 64# ITEM_LIST(11).ITMCOD = UAI$_DEFDIR+ ITEM_LIST(11).BUFADR = %LOC(UAF.DIRECTORY) ITEM_LIST(11).RETADR = 0 ITEM_LIST(12).BUFLEN = 8% ITEM_LIST(12).ITMCOD = UAI$_DEF_PRIV* ITEM_LIST(12).BUFADR = %LOC(UAF.DEF_PRIV) ITEM_LIST(12).RETADR = 0 ITEM_LIST(13).BUFLEN = 4$ ITEM_LIST(13).ITMCOD = UAI$_DFWSCNT) ITEM_LIST(13).BUFADR = %LOC(UAF.DFWSCNT) ITEM_LIST(13).RETADR = 0 ITEM_LIST(14).BUFLEN = 4" ITEM_LIST(14).ITMCOD = UAI$_DIOLM' ITEM_LIST(14).BUFADR = %LOC(UAF.DIOLM) ITEM_LIST(14).RETADR = 0 ITEM_LIST(15).BUFLEN = 4, ITEM_LIST(15).ITMCOD = UAI$_DIALUP_ACCESS_P1 ITEM_LIST(15).BUFADR = %LOC(UAF.DIALUP_ACCESS_P) ITEM_LIST(15).RETADR = 0 ITEM_LIST(16).BUFLEN = 4, ITEM_LIST(16).ITMCOD = UAI$_DIALUP_ACCESS_S1 ITEM_LIST(16).BUFADR = %LOC(UAF.DIALUP_ACCESS_S) ITEM_LIST(16).RETADR = 0 ITEM_LIST(17).BUFLEN = 4" ITEM_LIST(17).ITMCOD = UAI$_ENQLM' ITEM_LIST(17).BUFADR = %LOC(UAF.ENQLM) ITEM_LIST(17).RETADR = 0 ITEM_LIST(18).BUFLEN = 8' ITEM_LIST(18).ITMCOD = UAI$_EXPIRATION. ITEM_LIST(18).BUFADR = %LOC(UAF.Q_EXPIRATION) ITEM_LIST(18).RETADR = 0 ITEM_LIST(19).BUFLEN = 4" ITEM_LIST(19).ITMCOD = UAI$_FILLM' ITEM_LIST(19).BUFADR = %LOC(UAF.FILLM) ITEM_LIST(19).RETADR = 0 ITEM_LIST(20).BUFLEN = 4" ITEM_LIST(20).ITMCOD = UAI$_FLAGS- ITEM_LIST(20).BUFADR = %LOC(UAF.LOGIN_FLAGS) ITEM_LIST(20).RETADR = 0 ITEM_LIST(21).BUFLEN = 4$ ITEM_LIST(21).ITMCOD = UAI$_JTQUOTA) ITEM_LIST(21).BUFADR = %LOC(UAF.JTQUOTA) ITEM_LIST(21).RETADR = 0 ITEM_LIST(22).BUFLEN = 8( ITEM_LIST(22).ITMCOD = UAI$_LASTLOGIN_I/ ITEM_LIST(22).BUFADR = %LOC(UAF.Q_LASTLOGIN_I) ITEM_LIST(22).RETADR = 0 ITEM_LIST(23).BUFLEN = 8( ITEM_LIST(23).ITMCOD = UAI$_LASTLOGIN_N/ ITEM_LIST(23).BUFADR = %LOC(UAF.Q_LASTLOGIN_N) ITEM_LIST(23).RETADR = 0 ITEM_LIST(24).BUFLEN = 256# ITEM_LIST(24).ITMCOD = UAI$_LGICMD* ITEM_LIST(24).BUFADR = %LOC(UAF.COM_FILE) ITEM_LIST(24).RETADR = 0 ITEM_LIST(25).BUFLEN = 4+ ITEM_LIST(25).ITMCOD = UAI$_LOCAL_ACCESS_P0 ITEM_LIST(25).BUFADR = %LOC(UAF.LOCAL_ACCESS_P) ITEM_LIST(25).RETADR = 0 ITEM_LIST(26).BUFLEN = 4+ ITEM_LIST(26).ITMCOD = UAI$_LOCAL_ACCESS_S0 ITEM_LIST(26).BUFADR = %LOC(UAF.LOCAL_ACCESS_S) ITEM_LIST(26).RETADR = 0 ITEM_LIST(27).BUFLEN = 4% ITEM_LIST(27).ITMCOD = UAI$_LOGFAILS* ITEM_LIST(27).BUFADR = %LOC(UAF.LGIFAILS) ITEM_LIST(27).RETADR = 0 ITEM_LIST(28).BUFLEN = 4( ITEM_LIST(28).ITMCOD = UAI$_MAXACCTJOBS- ITEM_LIST(28).BUFADR = %LOC(UAF.MAXACCTJOBS) ITEM_LIST(28).RETADR = 0 ITEM_LIST(29).BUFLEN = 4& ITEM_LIST(29).ITMCOD = UAI$_MAXDETACH+ ITEM_LIST(29).BUFADR = %LOC(UAF.MAXDETACH) ITEM_LIST(29).RETADR = 0 ITEM_LIST(30).BUFLEN = 4$ ITEM_LIST(30).ITMCOD = UAI$_MAXJOBS) ITEM_LIST(30).BUFADR = %LOC(UAF.MAXJOBS) ITEM_LIST(30).RETADR = 0 ITEM_LIST(31).BUFLEN = 4- ITEM_LIST(31).ITMCOD = UAI$_NETWORK_ACCESS_P2 ITEM_LIST(31).BUFADR = %LOC(UAF.NETWORK_ACCESS_P) ITEM_LIST(31).RETADR = 0 ITEM_LIST(32).BUFLEN = 4- ITEM_LIST(32).ITMCOD = UAI$_NETWORK_ACCESS_S2 ITEM_LIST(32).BUFADR = %LOC(UAF.NETWORK_ACCESS_S) ITEM_LIST(32).RETADR = 0 ITEM_LIST(33).BUFLEN = 32" ITEM_LIST(33).ITMCOD = UAI$_OWNER' ITEM_LIST(33).BUFADR = %LOC(UAF.OWNER) ITEM_LIST(33).RETADR = 0 ITEM_LIST(34).BUFLEN = 4# ITEM_LIST(34).ITMCOD = UAI$_PBYTLM( ITEM_LIST(34).BUFADR = %LOC(UAF.PBYTLM) ITEM_LIST(34).RETADR = 0 ITEM_LIST(35).BUFLEN = 4& ITEM_LIST(35).ITMCOD = UAI$_PGFLQUOTA+ ITEM_LIST(35).BUFADR = %LOC(UAF.PGFLQUOTA) ITEM_LIST(35).RETADR = 0 ITEM_LIST(36).BUFLEN = 4# ITEM_LIST(36).ITMCOD = UAI$_PRCCNT( ITEM_LIST(36).BUFADR = %LOC(UAF.PRCCNT) ITEM_LIST(36).RETADR = 0 ITEM_LIST(37).BUFLEN = 4 ITEM_LIST(37).ITMCOD = UAI$_PRI% ITEM_LIST(37).BUFADR = %LOC(UAF.PRI) ITEM_LIST(37).RETADR = 0 ITEM_LIST(38).BUFLEN = 4& ITEM_LIST(38).ITMCOD = UAI$_PRIMEDAYS+ ITEM_LIST(38).BUFADR = %LOC(UAF.PRIMEDAYS) ITEM_LIST(38).RETADR = 0 ITEM_LIST(39).BUFLEN = 8! ITEM_LIST(39).ITMCOD = UAI$_PRIV& ITEM_LIST(39).BUFADR = %LOC(UAF.PRIV) ITEM_LIST(39).RETADR = 0 ITEM_LIST(40).BUFLEN = 8 ITEM_LIST(40).ITMCOD = UAI$_PWD* ITEM_LIST(40).BUFADR = %LOC(UAF.PASSWORD) ITEM_LIST(40).RETADR = 0 ITEM_LIST(41).BUFLEN = 8% ITEM_LIST(41).ITMCOD = UAI$_PWD_DATE, ITEM_LIST(41).BUFADR = %LOC(UAF.Q_PWD_DATE) ITEM_LIST(41).RETADR = 0 ITEM_LIST(42).BUFLEN = 4' ITEM_LIST(42).ITMCOD = UAI$_PWD_LENGTH, ITEM_LIST(42).BUFADR = %LOC(UAF.PWD_LENGTH) ITEM_LIST(42).RETADR = 0 ITEM_LIST(43).BUFLEN = 8) ITEM_LIST(43).ITMCOD = UAI$_PWD_LIFETIME0 ITEM_LIST(43).BUFADR = %LOC(UAF.Q_PWD_LIFETIME) ITEM_LIST(43).RETADR = 0 ITEM_LIST(44).BUFLEN = 4# ITEM_LIST(44).ITMCOD = UAI$_QUEPRI( ITEM_LIST(44).BUFADR = %LOC(UAF.QUEPRI) ITEM_LIST(44).RETADR = 0 ITEM_LIST(45).BUFLEN = 4, ITEM_LIST(45).ITMCOD = UAI$_REMOTE_ACCESS_P1 ITEM_LIST(45).BUFADR = %LOC(UAF.REMOTE_ACCESS_P) ITEM_LIST(45).RETADR = 0 ITEM_LIST(46).BUFLEN = 4, ITEM_LIST(46).ITMCOD = UAI$_REMOTE_ACCESS_S1 ITEM_LIST(46).BUFADR = %LOC(UAF.REMOTE_ACCESS_S) ITEM_LIST(46).RETADR = 0 ITEM_LIST(47).BUFLEN = 4% ITEM_LIST(47).ITMCOD = UAI$_SHRFILLM* ITEM_LIST(47).BUFADR = %LOC(UAF.SHRFILLM) ITEM_LIST(47).RETADR = 0 ITEM_LIST(48).BUFLEN = 4" ITEM_LIST(48).ITMCOD = UAI$_TQCNT' ITEM_LIST(48).BUFADR = %LOC(UAF.TQCNT) ITEM_LIST(48).RETADR = 0 ITEM_LIST(49).BUFLEN = 4 ITEM_LIST(49).ITMCOD = UAI$_UIC% ITEM_LIST(49).BUFADR = %LOC(UAF.UIC) ITEM_LIST(49).RETADR = 0 ITEM_LIST(50).BUFLEN = 12% ITEM_LIST(50).ITMCOD = UAI$_USERNAME* ITEM_LIST(50).BUFADR = %LOC(UAF.USERNAME)* ITEM_LIST(50).RETADR = %LOC(USERNAME_LEN) ITEM_LIST(51).BUFLEN = 4% ITEM_LIST(51).ITMCOD = UAI$_WSEXTENT* ITEM_LIST(51).BUFADR = %LOC(UAF.WSEXTENT) ITEM_LIST(51).RETADR = 0 ITEM_LIST(52).BUFLEN = 4$ ITEM_LIST(52).ITMCOD = UAI$_WSQUOTA) ITEM_LIST(52).BUFADR = %LOC(UAF.WSQUOTA) ITEM_LIST(52).RETADR = 0 ITEM_LIST(53).END_LIST = 0 JPI_LIST( 1).BUFLEN = 8 JPI_LIST( 1).ITMCOD = JPI$_PID JPI_LIST( 1).BUFADR = %LOC(PID) JPI_LIST( 1).RETADR = 0 JPI_LIST( 2).BUFLEN = 15" JPI_LIST( 2).ITMCOD = JPI$_PRCNAM# JPI_LIST( 2).BUFADR = %LOC(PRCNAM)' JPI_LIST( 2).RETADR = %LOC(PRCNAM_LEN) JPI_LIST( 3).BUFLEN = 8& JPI_LIST( 3).ITMCOD = JPI$_MASTER_PID' JPI_LIST( 3).BUFADR = %LOC(MASTER_PID) JPI_LIST( 3).RETADR = 0 JPI_LIST( 4).BUFLEN = 55$ JPI_LIST( 4).ITMCOD = JPI$_IMAGNAME% JPI_LIST( 4).BUFADR = %LOC(IMAGNAME)) JPI_LIST( 4).RETADR = %LOC(IMAGNAME_LEN) JPI_LIST( 5).BUFLEN = 8$ JPI_LIST( 5).ITMCOD = JPI$_LOGINTIM( JPI_LIST( 5).BUFADR = %LOC(LOGINTIM(1)) JPI_LIST( 5).RETADR = 0 JPI_LIST( 6).BUFLEN = 4 JPI_LIST( 6).ITMCOD = JPI$_MODE! JPI_LIST( 6).BUFADR = %LOC(MODE) JPI_LIST( 6).RETADR = 0 JPI_LIST( 7).BUFLEN = 4$ JPI_LIST( 7).ITMCOD = JPI$_PAGEFLTS% JPI_LIST( 7).BUFADR = %LOC(PAGEFLTS) JPI_LIST( 7).RETADR = 0 JPI_LIST( 8).BUFLEN = 4! JPI_LIST( 8).ITMCOD = JPI$_STATE" JPI_LIST( 8).BUFADR = %LOC(STATE) JPI_LIST( 8).RETADR = 0 JPI_LIST( 9).BUFLEN = 7$ JPI_LIST( 9).ITMCOD = JPI$_TERMINAL% JPI_LIST( 9).BUFADR = %LOC(TERMINAL)) JPI_LIST( 9).RETADR = %LOC(TERMINAL_LEN) JPI_LIST(10).BUFLEN = 12$ JPI_LIST(10).ITMCOD = JPI$_USERNAME# JPI_LIST(10).BUFADR = %LOC(USRNAM)' JPI_LIST(10).RETADR = %LOC(USRNAM_LEN) JPI_LIST(11).BUFLEN = 4 JPI_LIST(11).ITMCOD = JPI$_PRI% JPI_LIST(11).BUFADR = %LOC(PRIORITY) JPI_LIST(11).RETADR = 0 JPI_LIST(12).BUFLEN = 4" JPI_LIST(12).ITMCOD = JPI$_PPGCNT! JPI_LIST(12).BUFADR = %LOC(SIZE) JPI_LIST(12).RETADR = 0 JPI_LIST(13).BUFLEN = 4" JPI_LIST(13).ITMCOD = JPI$_GPGCNT# JPI_LIST(13).BUFADR = %LOC(GPGCNT) JPI_LIST(13).RETADR = 0 JPI_LIST(14).END_LIST = 0& DO 10 I = 1,31 ! Setup the Compare310 TRANSL_FR(I:I) = CHAR(I) ! String For Matching1 TRANSL_FR(32:32) = CHAR(127) ! and Translation TRANSL_FR(33:33) = CHAR(0) ! TRANSL_TO = CHAR(32) DO 20 I = 1,820 NULLS(I:I) = CHAR(0)C"C O p e n O u t p u t F i l eC30 ISTAT = LIB$GET_LUN(SCREEN) OPEN ( UNIT = SCREEN, 2 RECL = 510, 2 STATUS = 'NEW', 2 FORM = 'FORMATTED', 2 FILE = 'SYS$OUTPUT' )1 ISTAT = LIB$GET_FOREIGN(USERNAME,,USERNAME_LEN,)7 IF ((.NOT. ISTAT) .OR. (USERNAME_LEN .EQ. 0)) GOTO 100" USERNAME(USERNAME_LEN+1:12) = ' ' GOTO 110$100 ISTAT = LIB$GET_INPUT( USERNAME, 2 'Username ', 2 USERNAME_LEN )" IF (USERNAME_LEN .EQ. 0) GOTO 900" USERNAME(USERNAME_LEN+1:12) = ' '9110 ISTAT = STR$TRANSLATE( USERNAME, ! Translate Username$ 2 USERNAME, ! From Inputed String 2 TRANSL_TO, ! Making Spaces 2 TRANSL_FR ) ! From Garbage( STATUS = SYS$GETUAI( , ! Null Argument 2 , ! Null Argument 2 USERNAME, ! Username 2 ITEM_LIST,,, ) ! Item List IF (.NOT. STATUS) THEN PRINT *,'User Not On File' CALL EXIT END IF* STATUS = LIB$SYS_FAO( '[!OB,!OB]',,S_UIC, 2 %VAL(UAF.UIC_GRP), 2 %VAL(UAF.UIC_MEM)) ISTAT = SYS$ASCTIM( , 2 LOGIN_I, 2 %REF(UAF.Q_LASTLOGIN_I), 2 , )( IF ((UAF.Q_LASTLOGIN_I(1) .EQ. 0) .AND.( 2 (UAF.Q_LASTLOGIN_I(2) .EQ. 0)) THEN LOGIN_I = ' ' END IF ISTAT = SYS$ASCTIM( , 2 LOGIN_N, 2 %REF(UAF.Q_LASTLOGIN_N), 2 , )( IF ((UAF.Q_LASTLOGIN_N(1) .EQ. 0) .AND.( 2 (UA F.Q_LASTLOGIN_N(2) .EQ. 0)) THEN LOGIN_N = ' ' END IF5 ISTAT = SYS$ASCTIM(,EXPIRES,%REF(UAF.Q_EXPIRATION),)' IF ((UAF.Q_EXPIRATION(1) .EQ. 0) .AND.' 2 (UAF.Q_EXPIRATION(2) .EQ. 0)) THEN EXPIRES = ' (None)' END IF7 ISTAT = SYS$ASCTIM(,PWDLIFE,%REF(UAF.Q_PWD_LIFETIME),)3 ISTAT = SYS$ASCTIM(,PWDCHNG,%REF(UAF.Q_PWD_DATE),)4 CALL LIB$EMUL(-100000,UAF.CPUTIM,0,%REF(QUAD_TIME))5 ISTAT = SYS$ASCTIM(,CPUTIM,%REF(QUAD_TIME),%VAL(1) )F ISTAT = GET_LFLGS(UAF.LOGIN_FLAGS,L_FLAGS,FLGLEN)! Decode Login Flags9 ISTAT = GET_PRIMEDAYS(UAF.PRIMEDAYS,PRIMEDAYS,SECONDARY)1 ISTAT = GET_PRIVILEGES(UAF.PRIV,PRIVSTR,PRIVLEN) WRITE ( SCREEN, FMT='(A)' ) ' '( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'Username: ', 2 USERNAME, 2 'Owner: ', 2 UAF.OWNER(2:UAF.OWNER_LEN+1)( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'Account: ', 2 UAF.ACCOUNT(1:ACCOUNT_LEN), 2 'UIC: ', 2 S_UIC( WRITE ( SCREEN, FMT='(1X,A,A,T45,A,A)') 2 'CLI: ', 2 UAF.CLI(2:UAF.CLI_LEN+1), 2 'Tables: '," 2 UAF.TABLES(2:UAF.TABLES_LEN+1)" WRITE ( SCREEN, FMT='(1X,A,A,A)') 2 'Default: ',# 2 UAF.DEVICE(2:UAF.DEVICE_LEN+1),( 2 UAF.DIRECTORY(2:UAF.DIRECTORY_LEN+1) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'LGICMD: ',& 2 UAF.COM_FILE(2:UAF.COM_FILE_LEN+1) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Login flags: ', 2 L_FLAGS(1:FLGLEN) WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Primary days: ', 2 PRIMEDAYS WRITE ( SCREEN, FMT='(1X,A,A)') 2 'Secondary days: ', 2 SECONDARY) WRITE ( SCREEN, FMT='(1X,A,A,T33,A,I2)') 2 'Expiration: ', 2 EXPIRES, 2 'Pwdminimum: ', 2 UAF.PWD_LENGTH WRITE ( SCREEN, FMT='(1X,A,I)')( 2 'Login Failures Since Last Login: ', 2 UAF.LGIFAILS WRITE ( SCREEN, FMT='(1X,A,A)')" 2 'Last Interactive Login ', 2 LOGIN_I WRITE ( SCREEN, FMT='(1X,A,A)')" 2 'Last Non-Interactive Login ', 2 LOGIN_N( WRITE ( SCREEN, FMT='(1X,A,A,T43,A,A)') 2 'Pwdlifetime: ', 2 PWDLIFE, 2 'Pwdchange: ', 2 PWDCHNG3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Maxjobs: ',UAF.MAXJOBS, 2 'Fillm: ',UAF.FILLM, 2 'Bytlm: ',UAF.BYTLM3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)')# 2 'Maxacctjobs:',UAF.MAXACCTJOBS, 2 'Shrfillm: ',UAF.SHRFILLM, 2 'Pbytlm: ',UAF.PBYTLM3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)')! 2 'Maxdetach: ',UAF.MAXDETACH, 2 'Biolm: ',UAF.BIOLM, 2 'Jtquota: ',UAF.JTQUOTA3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Prclm: ',UAF.PRCCNT, 2 'Diolm: ',UAF.DIOLM, 2 'Wsdef: ',UAF.DFWSCNT3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Prio: ',UAF.PRI, 2 'Astlm: ',UAF.ASTLM, 2 'Wsquo: ',UAF.WSQUOTA3 WRITE ( SCREEN, FMT='(1X,A,I6,T21,A,I6,T41,A,I6)') 2 'Queprio: ',UAF.QUEPRI, 2 'Tqelm: ',UAF.TQCNT, 2 'Wsextent: ',UAF.WSEXTENT2 WRITE ( SCREEN, FMT='(1X,A,A,T21,A,I6,T41,A,I7)') 2 'CPU: ',CPUTIM, 2 'Enqlm: ',UAF.ENQLM, 2 'Pgflquo: ',UAF.PGFLQUOTA7 WRITE ( SCREEN, FMT='(1X,A)') 'Authorized Privileges:'" I = INDEX(PRIVSTR(1:255),CHAR(9))$ IF (PRIVSTR(1:5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(1:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 180 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) J = I + 1& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 1804 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:PRIVLEN)7180 WRITE ( SCREEN, FMT='(1X,A)') 'Default Privileges:'5 ISTAT = GET_PRIVILEGES(UAF.DEF_PRIV,PRIVSTR,PRIVLEN)" I = INDEX(PRIVSTR(1:255),CHAR(9))$ IF (PRIVSTR(1:5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(1:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) PRIVSTR(I:I) = ' ' J = I + 1" I = INDEX(PRIVSTR(1:255),CHAR(9))& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 700 IF (I .EQ. 0) I = PRIVLEN0 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:I-1) J = I + 1& IF (PRIVSTR(J:J+5) .EQ. ' ') GOTO 7004 WRITE ( SCREEN, FMT='(1X,T4,A)') PRIVSTR(J:PRIVLEN)700 CONTEXT = -17 BLANKS = ' ' //. 2 ' ' FIRST_TIME = 1710 DO WHILE (.TRUE.)+ ISTAT = SYS$GETJPIW(,CONTEXT,,JPI_LIST,,,)( IF (ISTAT .EQ. SS$_NOMOREPROC) GOTO 800# IF (USRNAM .NE. USERNAME) GOTO 710 IF (.NOT. FIRST_TIME) GOTO 715 PRINT *,' ' PRINT 791, 2 ' Job Id ', 2 'Term ',% 2 'Proc Name ',0 2 'Program Name ', 2 'State', 2 ' Ph.Mem ', 2 'Pr' FIRST_TIME = 0)715 CALL OTS$CVT_L_TZ(PID,PROCID,%VAL(8))4 CALL OTS$CVT_L_TZ(MASTER_PID,MASTER_PROCID,%VAL(8))& CALL SYS$ASCTIM(,LOGINTIME,LOGINTIM,)( IF (LOGINTIM(1) .EQ. 0) LOGINTIME = ' ' CALL LIB$DATE_TIME(DATETIME)$ IF (MODE .EQ. 0) JOB_TYPE = 'Other'& IF (MODE .EQ. 1) JOB_TYPE = 'Network'$ IF (MODE .EQ. 2) JOB_TYPE = 'Batch'* IF (MODE .EQ. 3) JOB_TYPE = 'Interactive' STATE_STR = ' '% IF (STATE .EQ. %LOC(SCH$C_CEF)) THEN STATE_STR = 'CEF', ELSE IF (STATE .EQ. %LOC(SCH$C_COLPG)) THEN STATE_STR = 'COLPG'* ELSE IF (STATE .EQ. %LOC(SCH$C_COM)) THEN STATE_STR = 'COM'+ ELSE IF (STATE .EQ. %LOC(SCH$C_COMO)) THEN STATE_STR = 'COMO'* ELSE IF (STATE .EQ. %LOC(SCH$C_CUR)) THEN STATE_STR = 'CUR'* ELSE IF (STATE .EQ. %LOC(SCH$C_FPG)) THEN STATE_STR = 'FPG'* ELSE IF (STATE .EQ. %LOC(SCH$C_HIB)) THEN STATE_STR = 'HIB'+ ELSE IF (STATE .EQ. %LOC(SCH$C_HIBO)) THEN STATE_STR = 'HIBO'* ELSE IF (STATE .EQ. %LOC(SCH$C_LEF)) THEN STATE_STR = 'LEF'+ ELSE IF (STATE .EQ. %LOC(SCH$C_LEFO)) THEN STATE_STR = 'LEFO', ELSE IF (STATE .EQ. %LOC(SCH$C_MWAIT)) THEN STATE_STR = 'MWAIT'* ELSE IF (STATE .EQ. %LOC(SCH$C_PFW)) THEN STATE_STR = 'PFW'+ ELSE IF (STATE .EQ. %LOC(SCH$C_SUSP)) THEN STATE_STR = 'SUSP', ELSE IF (STATE .EQ. %LOC(SCH$C_SUSPO)) THEN STATE_STR = 'SUSPO' END IF1 ISTAT = STR$TRANSLATE( USERNAME(1:USERNAME_LEN), 2 USERNAME(1:USERNAME_LEN), 2 TRANSL_TO, TRANSL_FR ). IF (.NOT. ISTAT) CALL LIB$SIGNAL(%VAL(ISTAT)). IMAGNAME = IMAGNAME(1:IMAGNAME_LEN) // BLANKS( PRCNAM = PRCNAM(1:PRCNAM_LEN) // BLANKS0720 STATUS = INDEX(IMAGNAME(1:IMAGNAME_LEN),']') IF (STATUS .GT. 0) THEN, IMAGNAME = IMAGNAME(STATUS+1:55) // BLANKS GOTO 720 END IF, I = INDEX(IMAGNAME,'.') ! Find Extension# IF (I .GT. 1) THEN ! Remove the7 IMAGNAME = IMAGNAME(1:I-1) // BLANKS ! File Extension END IF ! PRINT 790, 2 PROCID, 2 TERMINAL(1:TERMINAL_LEN), 2 PRCNAM, 2 IMAGNAME, 2 STATE_STR, 2 SIZE+GPGCNT, 2 PRIORITY END DO!790 FORMAT( 1X,A8,TR1,A7,TR1,A15,! 2 TR1,A14,TR1,A5TR1,I10,TR1,I2 )!791 FORMAT( 1X,A8,TR1,A7,TR1,A15,! 2 TR1,A14,TR1,A5TR1,A10,TR1,A2 )CC O p e n M a i l F i l eC"800 ISTAT = LIB$GET_LUN(MAIL_FILE) OPEN ( UNIT = MAIL_FILE, 1 FILE = 'VMSMAIL',$ 2 DEFAULT FILE = 'SYS$SYSTEM:.DAT', 3 USER OPEN = PRIV_USEROPEN, 4 STATUS = 'OLD', 5 ORGANIZATION = 'INDEXED', 6 ACCESS = 'KEYED', 7 RECORD TYPE = 'VARIABLE', 8 FORM = 'UNFORMATTED', 9 IOSTAT = STATUS, 9 ERR = 900, 9 READ ONLY, SHARED )  READ ( UNIT = MAIL_FILE, 1 KEYEQ = USERNAME, 2 KEYID = 0, 3 IOSTAT = STATUS ) MAIL_REC IF (STATUS .NE. 0) THEN- IF (STATUS .EQ. FOR$IOS_INPSTAREQ) GOTO 810 GOTO 900 END IF 810 IF (MAIL_NEWMES .GT. 0) THEN TEMP = ' '& WRITE (SCREEN,FMT='(1X,A)') 'Mail: ' IF (MAIL_NEWMES .EQ. 1) THEN/ WRITE (SCREEN,FMT='(1X,A)') ' 1 New Message' ELSE IF (MAIL_NEWMES .GT. 1$ 2 .AND. MAIL_NEWMES .LT. 10 ) THEN WRITE (TEMP,FMT='(I1,A)') 2 MAIL_NEWMES,' New Messages'# WRITE (SCREEN,FMT='(1X,A)') TEMP% ELSE IF (MAIL_NEWMES .GE. 10 ) THEN WRITE (TEMP,FMT='(I3,A)') 2 MAIL_NEWMES,' New Messages'# WRITE (SCREEN,FMT='(1X,A)') TEMP END IF ELSE4 WRITE (SCREEN,FMT='(1X,A)') 'No New Mail Messages' END IF2890 CALL PRIV_CLOSE(MAIL_FILE) ! Close Mail FileCC C l o s e F i l eC*900 CLOSE (SCREEN) ! Close Output File998 CALL EXIT ! Quit' GOTO 32767 ! Should Never Get Here 32767 END 9 INTEGER*4 FUNCTION GET_LFLGS(LOGIN_FLAGS,L_FLAGS,LENGTH)CC L o g i n F l a g sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)' CHARACTER*(*) L_FLAGS INTEGER*4 LOGIN_FLAGS INTEGER*2 LENGTH LENGTH = 07 IF (BTEST(LOGIN_FLAGS,UAI$V_DISCTLY) .EQ. .TRUE.) THEN L_FLAGS = 'Disctly ' LENGTH = 8 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_DEFCLI) .EQ. .TRUE.) THEN* L_FLAGS = L_FLAGS(1:LENGTH) // 'Defcli ' LENGTH = LENGTH + 7 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_LOCKPWD) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Lockpwd ' LENGTH = LENGTH + 8 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_CAPTIVE) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Captive ' LENGTH = LENGTH + 8 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_DISACNT) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Disuser ' LENGTH = LENGTH + 8 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_DISWELCOM) .EQ. .TRUE.) THEN. L_FLAGS = L_FLAGS(1:LENGTH) // 'Diswelcome ' LENGTH = LENGTH + 11 END IF7 IF (BTEST(LOGIN_FLAGS,UAI$V_DISMAIL) .EQ. .TRUE.) THEN. L_FLAGS = L_FLAGS(1:LENGTH) // 'Disnewmail ' LENGTH = LENGTH + 11 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_NOMAIL) .EQ. .TRUE.) THEN+ L_FLAGS = L_FLAGS(1:LENGTH) // 'Dismail ' LENGTH = LENGTH + 8 END IF6 IF (BTEST(LOGIN_FLAGS,UAI$V_GENPWD) .EQ. .TRUE.) THEN* L_FLAGS = L_FLAGS(1:LENGTH) // 'Genpwd ' LENGTH = LENGTH + 7 END IF; IF (BTEST(LOGIN_FLAGS,UAI$V_PWD_EXPIRED) .EQ. .TRUE.) THEN/ L_FLAGS = L_FLAGS(1:LENGTH) // 'Pwd_Expired ' LENGTH = LENGTH + 12 END IF< IF (BTEST(LOGIN_FLAGS,UAI$V_PWD2_EXPIRED) .EQ. .TRUE.) THEN0 L_FLAGS = L_FLAGS(1:LENGTH) // 'Pwd2_Expired ' LENGTH = LENGTH + 13 END IF5 IF (BTEST(LOGIN_FLAGS,UAI$V_AUDIT) .EQ. .TRUE.) THEN) L_FLAGS = L_FLAGS(1:LENGTH) // 'Audit ' LENGTH = LENGTH + 6 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_DISREPORT) .EQ. .TRUE.) THEN- L_FLAGS = L_FLAGS(1:LENGTH) // 'Disreport ' LENGTH = LENGTH + 10 END IF< IF (BTEST(LOGIN_FLAGS,UAI$V_DISRECONNECT) .EQ. .TRUE.) THEN0 L_FLAGS = L_FLAGS(1:LENGTH) // 'Disreconnect ' LENGTH = LENGTH + 13 END IF9 IF (BTEST(LOGIN_FLAGS,UAI$V_AUTOLOGIN) .EQ. .TRUE.) THEN- L_FLAGS = L_FLAGS(1:LENGTH) // 'Autologin ' LENGTH = LENGTH + 10 END IF32767 GET_LFLGS = SS$_NORMAL RETURN END ; INTEGER*4 FUNCTION GET_PRIMEDAYS(DAYS,PRIMEDAYS,SECONDARY)CC G e t _ P r i m e d a y sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($UAIDEF)'# INTEGER*4 DAYS ! Primedays Value0 INTEGER*2 LENGTH ! Length of Primedays String CHARACTER*(*) PRIMEDAYS CHARACTER*(*) SECONDARY STRUCTURE /WORK/ UNION MAP% CHARACTER*27 PRIMEDAYS ! Prime Days BYTE %FILL) CHARACTER*27 SECONDARY ! Secondary Days END MAP MAP CHARACTER*4 PRIME_DAY(7) CHARACTER*4 SCNDY_DAY(7) END MAP END UNION END STRUCTURE RECORD /WORK/ W W.PRIMEDAYS(1:27) = ' ' W.SECONDARY(1:27) = ' '0 IF (BTEST(DAYS,UAI$V_MONDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(1) = 'Mon ' W.SCNDY_DAY(1) = ' ' ELSE W.SCNDY_DAY(1) = 'Mon ' W.PRIME_DAY(1) = ' ' END IF1 IF (BTEST(DAYS,UAI$V_TUESDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(2) = 'Tue ' W.SCNDY_DAY(2) = ' ' ELSE W.SCNDY_DAY(2) = 'Tue ' W.PRIME_DAY(2) = ' ' END IF3 IF (BTEST(DAYS,UAI$V_WEDNESDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(3) = 'Wed ' W.SCNDY_DAY(3) = ' ' ELSE W.SCNDY_DAY(3) = 'Wed ' W.PRIME_DAY(3) = ' ' END IF2 IF (BTEST(DAYS,UAI$V_THURSDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(4) = 'Thu ' W.SCNDY_DAY(4) = ' ' ELSE W.SCNDY_DAY(4) = 'Thu ' W.PRIME_DAY(4) = ' ' END IF0 IF (BTEST(DAYS,UAI$V_FRIDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(5) = 'Fri ' W.SCNDY_DAY(5) = ' ' ELSE W.SCNDY_DAY(5) = 'Fri ' W.PRIME_DAY(5) = ' ' END IF2 IF (BTEST(DAYS,UAI$V_SATURDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(6) = 'Sat ' W.SCNDY_DAY(6) = ' ' ELSE W.SCNDY_DAY(6) = 'Sat ' W.PRIME_DAY(6) = ' ' END IF0 IF (BTEST(DAYS,UAI$V_SUNDAY) .EQ. .FALSE.) THEN W.PRIME_DAY(7) = 'Sun ' W.SCNDY_DAY(7) = ' ' ELSE W.SCNDY_DAY(7) = 'Sun ' W.PRIME_DAY(7) = ' ' END IF PRIMEDAYS = W.PRIMEDAYS SECONDARY = W.SECONDARY 32767 GET_PRIMEDAYS = SS$_NORMAL RETURN END 8 INTEGER*4 FUNCTION GET_PRIVILEGES(PRIVS,PRIVSTR,LENGTH)CC G e t _ P r i v i l e g e sC IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($PRVDEF)' INCLUDE '($UAIDEF)' INTEGER*2 I INTEGER*2 LENGTH CHARACTER*(*) PRIVSTR INTEGER*4 PRIVS(2) LENGTH = 0 I = 03 IF (BTEST(PRIVS(1),PRV$V_CMKRNL) .EQ. .TRUE.) THEN PRIVSTR = 'CMKRNL ' LENGTH = 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_CMEXEC) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'CMEXEC ' LENGTH = LENGTH + 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSNAM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSNAM ' LENGTH = LENGTH + 7 END IF3 IF (BTEST(PRIVS(1),PRV$V_GRPNAM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'GRPNAM ' LENGTH = LENGTH + 7 END IF5 IF (BTEST(PRIVS(1),PRV$V_ALLSPOOL) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'ALLSPOOL ' LENGTH = LENGTH + 9 END IF I = LENGTH3 IF (BTEST(PRIVS(1),PRV$V_DETACH) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'DETACH ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF5 IF (BTEST(PRIVS(1),PRV$V_DIAGNOSE) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'DIAGNOSE ' LENGTH = LENGTH + 9 I = I + 9 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_LOG_IO) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'LOG_IO ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_GROUP) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'GROUP ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_NOACNT) .EQ. .TRUE.) THEN( PRIVSTR = PRIVSTR(1:LENGTH) // 'ACNT ' LENGTH = LENGTH + 5 I = I + 5 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMCEB) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMCEB ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PSWAPM) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PSWAPM ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SETPRI) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SETPRI ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SETPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SETPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_TMPMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'TMPMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_WORLD) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'WORLD ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_MOUNT) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'MOUNT ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF1 IF (BTEST(PRIVS(1),PRV$V_OPER) .EQ. .TRUE.) THEN( PRIVSTR = PRIVSTR(1:LENGTH) // 'OPER ' LENGTH = LENGTH + 5 I = I + 5 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_EXQUOTA) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'EXQUOTA ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_NETMBX) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'NETMBX ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_VOLPRO) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'VOLPRO ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_BUGCHK) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'BUGCHK ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PRMGBL) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PRMGBL ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSGBL) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSGBL ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_PFNMAP) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'PFNMAP ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_SHMEM) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'SHMEM ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_BYPASS) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'BYPASS ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_SYSLCK) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'SYSLCK ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF2 IF (BTEST(PRIVS(1),PRV$V_SHARE) .EQ. .TRUE.) THEN) PRIVSTR = PRIVSTR(1:LENGTH) // 'SHARE ' LENGTH = LENGTH + 6 I = I + 6 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_UPGRADE) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'UPGRADE ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF6 IF (BTEST(PRIVS(1),PRV$V_DOWNGRADE) .EQ. .TRUE.) THEN- PRIVSTR = PRIVSTR(1:LENGTH) // 'DOWNGRADE ' LENGTH = LENGTH + 10 I = I + 10 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF3 IF (BTEST(PRIVS(1),PRV$V_GRPPRV) .EQ. .TRUE.) THEN* PRIVSTR = PRIVSTR(1:LENGTH) // 'GRPPRV ' LENGTH = LENGTH + 7 I = I + 7 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF4 IF (BTEST(PRIVS(1),PRV$V_READALL) .EQ. .TRUE.) THEN+ PRIVSTR = PRIVSTR(1:LENGTH) // 'READALL ' LENGTH = LENGTH + 8 I = I + 8 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF5 IF (BTEST(PRIVS(1),PRV$V_SECURITY) .EQ. .TRUE.) THEN, PRIVSTR = PRIVSTR(1:LENGTH) // 'SECURITY ' LENGTH = LENGTH + 9 I = I + 9 IF (I .GE. 54) THEN# PRIVSTR(LENGTH:LENGTH) = CHAR(9) I = 0 END IF END IF!32767 GET_PRIVILEGES = SS$_NORMAL RETURN ENDww