q[VAX-11 Librarian V02.00#5&È@ a&ÈV  |CTRANSDIBDEFPRCDDISKIOPRCERRMESPRC"GCMLPIPRCf GETJPIPRCGETPNAMI1MACHIFERRKMZIOPACKdJPIDEFcHLCMEMFdLOGTRANS6SGBITSxSGBITSSYMJOBTAPEIOWAITIOPACKNSLOGTRANSR1MACHWAIT&PEEVEEBPPQLDEFBg:PROCSUBrQDIVQUADMATHvR1MACHdJPIDEFcHLCMEMFLCMEMMNSdLOGTRANS @5&È% INTEGER*4 FUNCTION NBLANK(LINE) CHARACTER*(*) LINE DO 10 I = LEN(LINE),1,-1 NBLANK = I# IF(LINE(I:I).NE.' ')RETURN10 CONTINUE NBLANK = 1 RETURN END SUBROUTINE CUPPER(LINE) CHARACTER*(*) LINE BYTE J DO 10 I = 1 , LEN(LINE)$ IF(LINE(I:I).LT.'a')GOTO 10$ IF(LINE(I:I).GT.'z')GOTO 10 J = ICHAR(LINE(I:I)) J = J - '40'O LINE(I:I) = CHAR(J)10 CONTINUE RETURN END SUBROUTINE CLOWER(LINE) CHARACTER*(*) LINE BYTE J DO 10 I = 1 , LEN(LINE)$ IF(LINE(I:I).LT.'A')GOTO 10$ IF(LINE(I:I).GT.'Z')GOTO 10 J = ICHAR(LINE(I:I)) J = J + '40'O LINE(I:I) = CHAR(J)10 CONTINUE RETURN ENDww 5&È9 SUBROUTINE GET_JPI(DETACH,LIST,LMPRIV,LMPRIB,DEBUG)C.C The purpose of this routine is to set up2C a quota list for  use by creprc in creating aC sub- or detached process.6C DETACH is TRUE iff it is for a detached process.>C LIST contains the address of the quota list constructed.>C LMPRIV will be set to the privileges of current process.*C LMPRIB will be set to base priority.C<C Warning !!! Setting the proper formulae for allocatingCC quotas (deductible in particular) to sub-processes is tricky.=C The following is a list of all known uses of CREPRC for:C subprocesses which should be verified to work before7C any permanent changes are made in these formulae:C4C Interactive Graphics (especially [CLOUD]ANAL2)AC RJE images REMOTE and RJEREC where they set up /BATCH jobs)C IMPLICIT INTEGER*4 (A-Z) INTEGER*2 LST2(86) INTEGER*4 LST4(43) INTEGER*4 LMPRIV(2) LOGICAL DETACH,DEBUG common/quota/# . astlm,astval,biolm,bioval, . bytlm,bytval,# . cpulm,cpuval,diolm,dioval,$ . fillm,filval,pgflqu,pgfval," . prclm,prcval,tqelm,tqval,% . wsdefa,wsdval,wsquot,wsqval, . endval( byte astlm,biolm,bytlm,cpulm,diolm* byte fillm,pgflqu,prclm,tqelm,wsdefa byte wsquot,endval$ external pql$_astlm,pql$_biolm3 external pql$_bytlm,pql$_fillm,pql$_pgflquota$ external pql$_cpulm,pql$_diolm1 external pql$_prclm,pql$_tqelm,pql$_listend* external pql$_wsdefault,pql$_wsquota EXTERNAL JPI$_CURPRIV EXTERNAL JPI$_PRIB/ EXTERNAL JPI$_ASTLM,JPI$_BIOLM,JPI$_BYTLM1 EXTERNAL JPI$_CPULIM,JPI$_CPUTIM,JPI$_DIOLM( EXTERNAL JPI$_FILLM,JPI$_PGFLQUOTA# EXTERNAL JPI$_PRCLM,JPI$_TQLM' EXTERNAL JPI$_WSQUOTA,JPI$_WSAUTH EQUIVALENCE (LST2,LST4) astlm = %loc(pql$_astlm) biolm = %loc(pql$_biolm) bytlm = %loc(pql$_bytlm) cpulm = %loc(pql$_cpulm) diolm = %loc(pql$_diolm) fillm = %loc(pql$_fillm)# pgflqu = %loc(pql$_pgflquota) prclm = %loc(pql$_prclm) tqelm = %loc(pql$_tqelm)" wsdlm = %loc(pql$_wsdefault) wsqlm = %loc(pql$_wsquota)! endval = %loc(pql$_listend) LST2(1) = 8" LST2(2) = %LOC(JPI$_CURPRIV) LST4(2) = %LOC(LMPRIV) LST4(3) = 0 LST2(7) = 4 LST2(8) = %LOC(JPI$_PRIB) LST4(5) = %LOC(LMPRIB) LST4(6) = 0 LST2(13) = 4! LST2(14) = %LOC(JPI$_ASTLM) LST4(8) = %LOC(ASTVAL) LST4(9) = 0 LST2(19) = 4! LST2(20) = %LOC(JPI$_BIOLM) LST4(11) = %LOC(BIOVAL) LST4(12) = 0 LST2(25) = 4! LST2(26) = %LOC(JPI$_BYTLM) LST4(14) = %LOC(BYTVAL) LST4(15) = 0 LST2(31) = 4" LST2(32) = %LOC(JPI$_CPULIM) LST4(17) = %LOC(CPUVAL) LST4(18) = 0 LST2(37) = 4" LST2(38) = %LOC(JPI$_CPUTIM) LST4(20) = %LOC(JCPUVAL) LST4(21) = 0 LST2(43) = 4! LST2(44) = %LOC(JPI$_DIOLM) LST4(23) = %LOC(DIOVAL) LST4(24) = 0 LST2(49) = 4! LST2(50) = %LOC(JPI$_FILLM) LST4(26) = %LOC(FILVAL) LST4(27) = 0 LST2(55) = 4% LST2(56) = %LOC(JPI$_PGFLQUOTA) LST4(29) = %LOC(PGFVAL) LST4(30) = 0 LST2(61) = 4! LST2(62) = %LOC(JPI$_PRCLM) LST4(32) = %LOC(PRCVAL) LST4(33) = 0 LST2(67) = 4 LST2(68) = %LOC(JPI$_TQLM) LST4(35) = %LOC(TQVAL) LST4(36) = 0 LST2(73) = 4# LST2(74) = %LOC(JPI$_WSQUOTA) LST4(38) = %LOC(WSDVAL) LST4(39) = 0 LST2(79) = 4" LST2(80) = %LOC(JPI$_WSAUTH) LST4(41) = %LOC(WSQVAL) LST4(42) = 0 LST4(43) = 0E CALL IFERR(LIB$GET_EF(IFLAG),'NO EVENT FLAGS AVAIL FOR GETJPI')3 CALL IFERR(SYS$GETJPI(%VAL(IFLAG),,,LST2,,,)," . 'CREPRC ERROR IN GETJPI')C CALL IFERR(LIB$FREE_EF(IFLAG),'ERROR RETURNING EF IN GETJPI')- IF(DEBUG)TYPE *,'RESULTS FROM GETJPI :'5 IF(DEBUG)TYPE *,'priv(1), priv(2), & base prio'%  IF(DEBUG)TYPE 100,LMPRIV,LMPRIB100 FORMAT(4Z10)H IF(DEBUG)TYPE *,'astval, bioval, BYTVAL, CPUVAL, jcpuval,& dioval'B IF(DEBUG)TYPE 100,ASTVAL,BIOVAL,BYTVAL,CPUVAL,JCPUVAL,DIOVALG IF(DEBUG)TYPE *,'FILVAL, PGFVAL, PRCVAL, TQVAL, wsdval, & wsqval'@ IF(DEBUG)TYPE 100,FILVAL,PGFVAL,PRCVAL,TQVAL,WSDVAL,WSQVAL IF(.NOT.DETACH)THEN3 IF(CPUVAL.NE.0)CPUVAL = (CPUVAL-JCPUVAL)/3 END IF% IF(DEBUG)TYPE *,'FINAL RESULTS'5 IF(DEBUG)TYPE *,'priv(1), priv(2), & base prio'% IF(DEBUG)TYPE 100,LMPRIV,LMPRIBH IF(DEBUG)TYPE *,'astval, bioval, BYTVAL, CPUVAL, jcpuval,& dioval'B IF(DEBUG)TYPE 100,ASTVAL,BIOVAL,BYTVAL,CPUVAL,JCPUVAL,DIOVALG IF(DEBUG)TYPE *,'FILVAL, PGFVAL, PRCVAL, TQVAL, wsdval, & wsqval'@ IF(DEBUG)TYPE 100,FILVAL,PGFVAL,PRCVAL,TQVAL,WSDVAL,WSQVAL LIST = %LOC(ASTLM) RETURN ENDww_6&È% SUBROUTINE GETPNAM(NAME,LENGTH) IMPLICIT INTEGER*4 (S) INTEGER*4 NAME(2)0 COMMON/GET_NAM/ISIZE,ICODE,IADDR,ILEN,IEND INTEGER*2 ISIZE,ICODE$ EXTERNAL JPI$_PRCNAM,SS$_ABORT% ISIZE = '0000FFFF'X.AND.NAME(1) ICODE = %LOC(JPI$_PRCNAM) IADDR = NAME(2) ILEN = %LOC(LENGTH) IEND = 0A CALL IFERR(LIB$GET_EF(IFLAG),'UNABLE TO GET EF IN GETPNAM'), I = SYS$GETJPI(%VAL(IFLAG),,,ISIZE,,,) IF(MOD(I,8).NE.1)THEN CALL ERRMES(I)2 TYPE *,'UNABLE TO DETERMINE PROCESS NAME'! C ALL SYS$EXIT(SS$_ABORT) END IFC CALL IFERR(LIB$FREE_EF(IFLAG),'UNABLE TO FREE EF IN GETPNAM') RETURN ENDww],6&ÈDC I1MACH FROM PORTLIB 08/15/79 D INTEGER FUNCTION I1MACH(I) DC DC I/O UNIT NUMBERS. DC  DC I1MACH( 1) = THE STANDARD INPUT UNIT. DC DC I1MACH( 2) = THE STANDARD OUTPUT UNIT. DC DC I1MACH( 3) = THE STANDARD PUNCH UNIT. DC DC I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. DC  DC WORDS. DC DC I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. DC HC I1MACH( 6) = THE NUMBER OF CHARACTERS PER INTEGER STORAGE UNIT. DC DC INTEGERS.  DC DC ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM DC DC SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) DC DC WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. DC  DC I1MACH( 7) = A, THE BASE. DC DC I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. DC DC I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. DC DC FLOATING-POINT NUMBERS. ! DC DC ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, DC BASE-B FORM DC DC SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) DC DC WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, DC " 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. DC DC I1MACH(10) = B, THE BASE. DC DC SINGLE-PRECISION DC DC I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. DC # DC I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. DC DC I1MACH(13) = EMAX, THE LARGEST EXPONENT E. DC DC DOUBLE-PRECISION DC DC I1MACH(14) = T, THE NUMBER O$F BASE-B DIGITS. DC DC I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. DC DC I1MACH(16) = EMAX, THE LARGEST EXPONENT E. DC DC TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, DC THE DESIRED SET OF DATA STATEMENTS SHOULD BE AC%TIVATED BY DC REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF DC I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY DC WITH THE LOCAL OPERATING SYSTEM. DC D INTEGER IMACH(16),OUTPUT DC D EQUIVALENCE (IMACH(4),OUTPUT) & DC DC MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. DC DC DATA IMACH( 1) / 7 / DC DATA IMACH( 2) / 2 / DC DATA IMACH( 3) / 2 / DC DATA IMACH( 4) / 2 / DC DATA I'MACH( 5) / 36 / DC DATA IMACH( 6) / 4 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 33 / DC DATA IMACH( 9) / Z1FFFFFFFF / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 24 / DC DATA IMACH(12) / -256 (/ DC DATA IMACH(13) / 255 / DC DATA IMACH(14) / 60 / DC DATA IMACH(15) / -256 / DC DATA IMACH(16) / 255 / DC DC MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. DC ) DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 7 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 48 / DC DATA IMACH( 6) / 6 / DC DATA IMACH( 7) / 2 / * DC DATA IMACH( 8) / 39 / DC DATA IMACH( 9) / O0007777777777777 / DC DATA IMACH(10) / 8 / DC DATA IMACH(11) / 13 / DC DATA IMACH(12) / -50 / DC DATA IMACH(13) / 76 / DC DATA IMACH(14) / 26 / DC +DATA IMACH(15) / -50 / DC DATA IMACH(16) / 76 / DC DC MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) /, 7 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 48 / DC DATA IMACH( 6) / 6 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 39 / DC DATA IMACH( 9) / O0007777777777777 / DC DATA IMACH(10) / 8 / - DC DATA IMACH(11) / 13 / DC DATA IMACH(12) / -50 / DC DATA IMACH(13) / 76 / DC DATA IMACH(14) / 26 / DC DATA IMACH(15) / -32754 / DC DATA IMACH(16) / 32780 / DC . DC MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 7 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 60 / D/C DATA IMACH( 6) / 10 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 48 / DC DATA IMACH( 9) / 00007777777777777777B / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 48 / DC DATA IMACH(12) / -974 / DC DATA IMACH0(13) / 1070 / DC DATA IMACH(14) / 96 / DC DATA IMACH(15) / -927 / DC DATA IMACH(16) / 1070 / DC DC MACHINE CONSTANTS FOR THE CRAY 1 DC DC DATA IMACH( 1) / 100 / 1 DC DATA IMACH( 2) / 101 / DC DATA IMACH( 3) / 102 / DC DATA IMACH( 4) / 101 / DC DATA IMACH( 5) / 64 / DC DATA IMACH( 6) / 8 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 63 / 2 DC DATA IMACH( 9) / 777777777777777777777B / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 48 / DC DATA IMACH(12) / -8192 / DC DATA IMACH(13) / 8191 / DC DATA IMACH(14) / 96 / DC DATA IMACH(15) / -8192 / 3 DC DATA IMACH(16) / 8191 / DC DC MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 DC DC DATA IMACH( 1) / 11 / DC DATA IMACH( 2) / 12 / DC DATA IMACH( 3) / 8 / DC DATA4 IMACH( 4) / 10 / DC DATA IMACH( 5) / 16 / DC DATA IMACH( 6) / 2 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 15 / DC DATA IMACH( 9) /32767 / DC DATA IMACH(10) / 16 / DC DATA IMACH(11) / 56 / DC DATA IMACH(12) / -64 / DC DATA IMACH(13) / 63 / DC DATA IMACH(14) / 14 / DC DATA IMACH(15) / -64 / DC DATA IMACH(16) / 63 / DC DC MACHINE CONSTANTS FOR THE HARRIS 2206 DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 0 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 24 / DC DATA IMACH( 6) / 3 / 7 DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 23 / DC DATA IMACH( 9) / 8388607 / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 23 / DC DATA IMACH(12) / -127 / DC DATA IMACH(13) / 127 / DC 8 DATA IMACH(14) / 38 / DC DATA IMACH(15) / -127 / DC DATA IMACH(16) / 127 / DC DC MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2)9 / 6 / DC DATA IMACH( 3) / 43 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 36 / DC DATA IMACH( 6) / 6 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 35 / DC DATA IMACH( 9) / 0377777777777: / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 27 / DC DATA IMACH(12) / -127 / DC DATA IMACH(13) / 127 / DC DATA IMACH(14) / 63 / DC DATA IMACH(15) / -127 / DC DATA IMACH(16) / 127 / ; DC DC MACHINE CONSTANTS FOR THE IBM 360/370 SERIES. DC THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 7 / <DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 32 / DC DATA IMACH( 6) / 4 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 31 / DC DATA IMACH( 9) / Z7FFFFFFF / DC DATA IMACH(10) / 16 / DC DATA IMA=CH(11) / 6 / DC DATA IMACH(12) / -64 / DC DATA IMACH(13) / 63 / DC DATA IMACH(14) / 14 / DC DATA IMACH(15) / -64 / DC DATA IMACH(16) / 63 / DC DC MACHINE CONSTANTS FOR TH>E PDP-10 (KA PROCESSOR). DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 5 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 36 / DC DATA IMACH( 6) / 5 / ? DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 35 / DC DATA IMACH( 9) / "377777777777 / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 27 / DC DATA IMACH(12) / -128 / DC DATA IMACH(13) / 127 / @ DC DATA IMACH(14) / 54 / DC DATA IMACH(15) / -101 / DC DATA IMACH(16) / 127 / DC DC MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). DC DC DATA IMACH( 1) / 5 / DC DAATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 5 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 36 / DC DATA IMACH( 6) / 5 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 35 / DC DATA IMACH( 9) / "B377777777777 / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 27 / DC DATA IMACH(12) / -128 / DC DATA IMACH(13) / 127 / DC DATA IMACH(14) / 62 / DC DATA IMACH(15) / -128 / DC DATA IMACH(16) / 127 / C DC DC MACHINE CONSTANTS FOR PDP-11 FORTRAN"S SUPPORTING DC 32-BIT INTEGER ARITHMETIC. DC D DATA IMACH( 1) / 5 / D DATA IMACH( 2) / 6 / D DATA IMACH( 3) / 6 / D D DATA IMACH( 4) / 6 / D DATA IMACH( 5) / 32 / D DATA IMACH( 6) / 4 / D DATA IMACH( 7) / 2 / D DATA IMACH( 8) / 31 / D DATA IMACH( 9) / 2147483647 / D DATA IMACH(10) / 2 / D E DATA IMACH(11) / 24 / D DATA IMACH(12) / -127 / D DATA IMACH(13) / 127 / D DATA IMACH(14) / 56 / D DATA IMACH(15) / -127 / D DATA IMACH(16) / 127 / DC DC MACHINE CONSFTANTS FOR PDP-11 FORTRAN"S SUPPORTING DC 16-BIT INTEGER ARITHMETIC. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 5 / DC DATA IMACH( 4) / 6 / DC DATA IMACH( 5) / 16 / G DC DATA IMACH( 6) / 2 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 15 / DC DATA IMACH( 9) /32767 / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 24 / DC DATA IMACH(12) / -127 / H DC DATA IMACH(13) / 127 / DC DATA IMACH(14) / 56 / DC DATA IMACH(15) / -127 / DC DATA IMACH(16) / 127 / DC DC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. DC I DC NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 DC WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. DC IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. DC DC DATA IMACH( 1) / 5 / DC DATA IMACH( 2) / 6 / DC DATA IMACH( 3) / 7 / DC DATA IJMACH( 4) / 6 / DC DATA IMACH( 5) / 36 / DC DATA IMACH( 6) / 6 / DC DATA IMACH( 7) / 2 / DC DATA IMACH( 8) / 35 / DC DATA IMACH( 9) / O377777777777 / DC DATA IMACH(10) / 2 / DC DATA IMACH(11) / 27 K/ DC DATA IMACH(12) / -128 / DC DATA IMACH(13) / 127 / DC DATA IMACH(14) / 60 / DC DATA IMACH(15) /-1024 / DC DATA IMACH(16) / 1023 / DC HC-------------------------------------------L----------------------------HC DELETE NEXT TWO STATEMENTS AFTER SUPPLYING THE PROPER DATA STATEMENTS.DC DATA IMACH (5) /0/ DC IF (IMACH(5) .EQ. 0) HC 1CALL ULIBER(2,45H I1MACH - MACHINE DEPENDENT CONSTANTS NOT SET,45)HC-----------------------------------------------------------------------D IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 DC M D I1MACH=IMACH(I) D RETURN DC D 10 CALL ULIBER(1,34H ERROR IN I1MACH - I OUT OF BOUNDS,34) DC D STOP DC N D END wwo6&È SUBROUTINE CFIRST(IOLUN); COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME CHARACTER*1 CHAR CHARACTER*1 ESC CHARACTER*40 LOGIC,RESULT LOGICAL D_OPEN% INTEGER*4 SYS$TRNLOG,SYS$CRELOG BYTE IESC# EXTERNAL SS$_NOTRAN,SS$_ABORT DATA FIRST/2O0*.TRUE./ DATA WRITE/20*.FALSE./ DATA WAIT/20*.FALSE./ DATA NDRIVE/20*-1/? DATA LUNAME/'01','02','03','04','05','06','07','08','09',@ . '10','11','12','13','14','15','16','17','18','19','20'/%C if first is clear we're all set! IF(.NOT.FIRST(IOLUN))RETURNC get real name' LOGIC(1:) = 'IOP0'//LUNAME(IOLUN) 5 I = 1 L = 6 LEV = 0C attempt a translation,10 I = SYS$TRNLOG(LOGIC(1:L),L,RESULT,,,)& IF(I.EQ.%LPOC(SS$_NOTRAN))GOTO 40 IF(MOD(I,8).NE.1)THEN CALL ERRMES(I)+ TYPE *,'BAD TRANSLATION IN IOPACK'! CALL SYS$EXIT(SS$_ABORT) END IF LEV = 1 J = 1 IESC = '1B'X ESC = CHAR(IESC) IF(RESULT(1:1).EQ.ESC)J=5" LOGIC(1:L+1-J) = RESULT(J:L) L = L + 1 - J GOTO 10>C if there weren't any translations then use SY:IOP00n.DAT40 IF(LEV.EQ.0)THEN: I = SYS$CRELOG(%VAL(2),LOGIC,LOGIC(1:6)//'.DAT',)Q IF(MOD(I,8).NE.1)THEN CALL ERRMES(I)? TYPE *,'ERROR IN SETTING UP DEFAULT NAME IN IOPACK'$ CALL SYS$EXIT(SS$_ABORT) END IF GOTO 5 END IFAC there was a translation and we've got it now in RESULT(1:L)C check for a magtape! M = INDEX(RESULT(1:L),'MT') IF(M.EQ.0)GOTO 60 N = INDEX(RESULT(1:L),':') IF(N.EQ.0)GOTO 60 IF(N.LT.M)GOTO 60 NDRIVE(IOLUN) = 01 IF(RESULT(N-1:N-R1).EQ.'1')NDRIVE(IOLUN) = 1 GOTO 80(C we've got a disk file on our hands60 CONTINUE'D TYPE *,'THIS WILL BE A DISK UNIT' NDRIVE(IOLUN) = -1 IF(WRITE(IOLUN))THEN/ IF(.NOT.D_OPEN(IOLUN,'W',RESULT(1:L)))/ . STOP 'IOPACK UNABLE TO OPEN DISK FILE' ELSE/ IF(.NOT.D_OPEN(IOLUN,'R',RESULT(1:L)))/ . STOP 'IOPACK UNABLE TO OPEN DISK FILE' END IF80 CONTINUE FIRST(IOLUN) = .FALSE. RETURN END" SUSBROUTINE IOPEN(IOLUN,NAME) CHARACTER*(*) NAME; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME INTEGER*4 SYS$CRELOG EXTERNAL SS$_ABORT IF(.NOT.FIRST(IOLUN))THEN6 TYPE *,'ILLEGAL ATTEMPT TO IOPEN AN OPEN LUN'! CALL SYS$EXIT(SS$_ABORT) END IF9 I = SYS$CRELOG(%VAL(2),'IOP0'//LUNAME(IOLUN),NAME,) IF(MOD(I,8).NE.1)THEN CALL ERTRMES(I)8 TYPE *,'UNABLE TO ASSIGN LOGICAL NAME IN IOPEN'! CALL SYS$EXIT(SS$_ABORT) END IF RETURN END SUBROUTINE IOCLOS(IOLUN); COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME IF(FIRST(IOLUN))RETURN IF(NDRIVE(IOLUN).LT.0)THENC it's a disk drive CALL D_CLOS(IOLUN) ELSEC it's a tape drive-C if they U didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM) WAIT(IOLUN) = .FALSE.4C if they wrote on it write an EOF at the end3 IF(WRITE(IOLUN))CALL T_WEOF(NDRIVE(IOLUN))8 IF(WRITE(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)3 IF(WRITE(IOLUN))CALL T_WEOF(NDRIVE(IOLUN))8 IF(WRITE(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)6 IF(WRITE(IOLUN))CALL T_SKPF(NDRIVE(IOLUN),-1)8 IF(WRITE(IOLUN))CALL T_WAIT(NDRIVE(IOLUN)V,M,MM) END IF$C in either case set FIRST again FIRST(IOLUN) = .TRUE. RETURN END2 SUBROUTINE BUFFEROUT(IOLUN,PARITY,IFWA,ILWA); COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME WRITE(IOLUN) = .TRUE. CALL CFIRST(IOLUN)* NBYTES = %LOC(ILWA) - %LOC(IFWA) + 4 IF(NDRIVE(IOLUN).LT.0)THEN C disk& CALL D_PUT(IOLUN,IFWA,NBYTEWS) ELSE C tape-C if they didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)/ CALL T_WRIT(NDRIVE(IOLUN),IFWA,NBYTES) WAIT(IOLUN) = .TRUE. END IF RETURN END6 SUBROUTINE WRTAPE(IOLUN,MODE,NTYPE,NADDR,NWDCNT)C C NB:>C NWDCNT IN WRTAPE IS THE BYTE COUNT NOT THE WORD COUNTC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGIXCAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME WRITE(IOLUN) = .TRUE. CALL CFIRST(IOLUN) NBYTES = NWDCNT IF(NDRIVE(IOLUN).LT.0)THEN C disk' CALL D_PUT(IOLUN,NADDR,NBYTES) ELSE C tape-C if they didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)0 CALL T_WRIT(NDRIVE(IOLUN),NADDR,NBYTES) WAIT(IOLUN) = .TRUE. END IF RETURN END1 SUBROUTINE BUFFERIN(IOLUYN,PARITY,IFWA,ILWA); COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME WRITE(IOLUN) = .FALSE. CALL CFIRST(IOLUN)* NBYTES = %LOC(ILWA) - %LOC(IFWA) + 4 IF(NDRIVE(IOLUN).LT.0)THEN C disk& CALL D_GET(IOLUN,IFWA,NBYTES) ELSE C tape-C if they didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)/ Z CALL T_READ(NDRIVE(IOLUN),IFWA,NBYTES) WAIT(IOLUN) = .TRUE. END IF RETURN END6 SUBROUTINE RDTAPE(IOLUN,MODE,NTYPE,NADDR,NWDCNT)C C NB:4C NWDCNT IS THE BYTE COUNT NOT THE WORD COUNTC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME WRITE(IOLUN) = .FALSE. CALL CFIRST(IOLUN) NBYTES = NWDCNT IF(NDRIVE(IOLUN).LT.0)[THEN C diskD TYPE *,'DISK'' CALL D_GET(IOLUN,NADDR,NBYTES) ELSE C tape-C if they didn't do a wait, insert oneD TYPE *,'TAPE'7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)0 CALL T_READ(NDRIVE(IOLUN),NADDR,NBYTES) WAIT(IOLUN) = .TRUE. END IF RETURN END' INTEGER*4 FUNCTION LENGTHF(IOLUN)C C NB:1C LENGTHF RETURNS THE INTEGER*4 WORD COUNT%C TO GET BYTE COUNT\ USE IOWAITC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME INTEGER*4 D_LEN EXTERNAL SS$_ABORT IF(FIRST(IOLUN))THEN9 TYPE *,'CALL TO LENGTHF PRECEDES FIRST TRANSFER'! CALL SYS$EXIT(SS$_ABORT) END IF IF(NDRIVE(IOLUN).LT.0)THEN C disk% LENGTHF = (D_LEN(IOLUN)+3)/4 ELSE C tape/ CALL T_WAIT(NDRIVE(IO]LUN),NSTATE,LENG) LENGTHF = (LENG+3)/4 WAIT(IOLUN) = .FALSE. END IF RETURN END REAL FUNCTION UNIT(IOLUN)C C NB:1C THE 7600 VERSION OF UNIT ALLOWED A 4-WAY2C BRANCH. THE FIRST BRANCH WAS NEVER TAKEN1C (IT REPRESENTED OPERATION NOT FINISHED).1C SINCE 4-WAY BRANCHES ARE NON-STANDARD WE8C HAVE SIMPLY OMITTED THE FIRST BRANCH CONDITION.7C FOR 3-WAY BRANCHING, UNIT < 0.0 MEANS SUCCESS,7C ^ UNIT = 0.0 MEANS EOF, AND5C UNIT > 0.0 MEANS ERROR.C; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME EXTERNAL SS$_ABORT IF(FIRST(IOLUN))THEN6 TYPE *,'CALL TO UNIT PRECEDES FIRST TRANSFER'! CALL SYS$EXIT(SS$_ABORT) END IF IF(NDRIVE(IOLUN).LT.0)THEN C disk UNIT = D_UNIT(IOLUN) _ ELSE C tape/ CALL T_WAIT(NDRIVE(IOLUN),NSTATE,LENG) UNIT = NSTATE - 1 WAIT(IOLUN) = .FALSE. END IF RETURN END* SUBROUTINE IOWAIT(IOLUN,NSTATE,NWDS)C C NB:)C NWDS IS ACTUALLY NUMBER OF BYTES+C TO GET NUMBER OF WORDS USE LENGTHFC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME INTEGER*4 D_LE`N EXTERNAL SS$_ABORT IF(FIRST(IOLUN))THEN8 TYPE *,'CALL TO IOWAIT PRECEDES FIRST TRANSFER'! CALL SYS$EXIT(SS$_ABORT) END IF IF(NDRIVE(IOLUN).LT.0)THEN C diskD x = d_unit(iolun)% NSTATE = D_UNIT(IOLUN) + 1.5!D type *,'d_unit',x,nstate NWDS = D_LEN(IOLUN) ELSE C tape/ CALL T_WAIT(NDRIVE(IOLUN),NSTATE,NWDS) WAIT(IOLUN) = .FALSE. END IF RETURN END aSUBROUTINE ENDFILE(IOLUN) CALL IOCLOS(IOLUN) RETURN END SUBROUTINE SKIPFILE(IOLUN)C C NB:C ONLY WORKS ON TAPESC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL FIRST,WRITE,WAIT CHARACTER*2 LUNAME EXTERNAL SS$_ABORT N = 1 GOTO 10 ENTRY BACKFILE(IOLUN) N = -110 WRITE(IOLUN) = .FALSE. CALL CFIRST(IOLUN) IF(NDRIVE(IOLUN).LT.0)THENb( TYPE *,'CAN''T SKIP DISK FILES'! CALL SYS$EXIT(SS$_ABORT) END IF-C if they didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)" CALL T_SKPF(NDRIVE(IOLUN),N) WAIT(IOLUN) = .TRUE. RETURN END! SUBROUTINE SKIPSPACE(IOLUN)C C NB:+C FOR THE MOMENT ONLY WORKS ON TAPESC; COMMON/IOPACK/FIRST(20),WRITE(20),NDRIVE(20),WAIT(20) COMMON/IOPAKC/LUNAME(20) LOGICAL cFIRST,WRITE,WAIT CHARACTER*2 LUNAME EXTERNAL SS$_ABORT N = 1 GOTO 10 ENTRY BACKSPACE(IOLUN) ENTRY BSTAPE(IOLUN,MODE) N = -110 WRITE(IOLUN) = .FALSE. CALL CFIRST(IOLUN) IF(NDRIVE(IOLUN).LT.0)THEN2 TYPE *,'CAN''T SKIP DISK RECORDS FOR NOW'! CALL SYS$EXIT(SS$_ABORT) END IF-C if they didn't do a wait, insert one7 IF(WAIT(IOLUN))CALL T_WAIT(NDRIVE(IOLUN),M,MM)" CALL T_SKPR(NDRIVE(IOLUN),dN) WAIT(IOLUN) = .TRUE. RETURN ENDww6&È' INTEGER*4 FUNCTION LCMREQ(LENGTH) INTEGER*4 LIB$GET_VM- CALL IFERR(LIB$GET_VM(LENGTH*4,LCMREQ), . 'ERROR IN LCMREQ')? IF(MOD(LCMREQ,4).NE.0)STOP 'BAD ADDR IN LCMREQ - SEE RAY' LCMREQ = LCMREQ/4 RETURN END. SUBROUTINE UNLCRD(NUNIT,KADDR,N,NSTATUS) LADDR = KADDR*4< CALL BUFFERIN(NUNIT,0,%VAL(LADDR),%VAL(LADDR+4*(N-1))) RETURN eEND. SUBROUTINE UNLCWT(NUNIT,KADDR,N,NSTATUS) LADDR = KADDR*4= CALL BUFFEROUT(NUNIT,0,%VAL(LADDR),%VAL(LADDR+4*(N-1))) RETURN END- SUBROUTINE UNLCCK(NUNIT,NSTATUS,LENGTH) LENGTH = LENGTHF(NUNIT) IF(UNIT(NUNIT))10,20,3010 NSTATUS = 0 GOTO 4020 NSTATUS = 1 GOTO 4030 NSTATUS = 240 CONTINUE RETURN ENDww 6&È3 INTEGER*4 FUNCTION LOGTRANS(INPUT,OUTPUT,LEN) IMPLICITf INTEGER*4 (S)$ EXTERNAL SS$_NORMAL,SS$_NOTRAN CHARACTER*(*) INPUT,OUTPUT CHARACTER*63 TEMP LOGICAL COLON OUTPUT = INPUT LOOP = 010 TEMP = OUTPUT N = NBLANK(TEMP) COLON = TEMP(N:N).EQ.':' IF(COLON)N = N - 14 LOGTRANS = SYS$TRNLOG(TEMP(1:N),LEN,OUTPUT,,,)) IF(ICHAR(OUTPUT(1:1)).EQ.'1B'X)THEN OUTPUT = OUTPUT(5:) LEN = LEN - 4 END IF OUTPUT = OUTPUT(1:LEN) LOOP = LOOP + 1- IFg(LOGTRANS.EQ.%LOC(SS$_NORMAL))GOTO 10 IF(COLON)THEN LEN = LEN + 1 OUTPUT(LEN:LEN) = ':' END IF8 IF((LOGTRANS.EQ.%LOC(SS$_NOTRAN)).AND.(LOOP.GT.1))$ . LOGTRANS = %LOC(SS$_NORMAL)C7C special patch since VMS 1.6 omits : for SYS$INPUT?C and SYS$OUTPUT assignments in indirect command proceduresC; IF((LOGTRANS.EQ.%LOC(SS$_NORMAL)).AND.(LEN.EQ.4).AND.# . (OUTPUT(1:2).EQ.'TT'))THEN" OUTPUT = OUTPUT(1:4)//':' LhEN = 5 END IF RETURN ENDww` 7&È integer*4 function creprc7 . (input,output,error,source,prname,uic,n,debug) parameter nmax=32 implicit integer*4 (a-z)( common/procsub/id(nmax),chan(nmax) integer*4 id integer*2 chan logical debug4 character*(*) input,output,error,source,prname external dib$w_unit external ss$_abort integer*2 mbx integer*2 buf(40) integer*4 bufdsci(2) logical lerror logical rd_prc data id/nmax*0/ lerror(i) = mod(i,8).ne.1c bufdsc(1) = 80 bufdsc(2) = %loc(buf) if(id(n).ne.0)then4 if(.not.rd_prc(.false.,n,debug,status))then> write(6,*)' attempted to create a second process',) . n,' before first terminated.'$ creprc = %loc(ss$_abort) return end if end ifCC4C limit mailbox messages and buffer space to 100/C j since completion message is 90 bytes longC: creprc = sys$crembx(,chan(n),%val(100),%val(100),,,)4 if(debug)write(6,*)' result of create mailbox'" if(debug)call errmes(creprc) if(lerror(creprc))return2 creprc = sys$getchn(%val(chan(n)),,bufdsc,,)% mbx = buf(%loc(dib$w_unit)/2+1)8 if(debug)write (6,*)' result of getchn on mailbox'" if(debug)call errmes(creprc) if(lerror(creprc))return if(uic.ne.0)then6 CALL GET_JPI(.TRUE.,L kIST,LMPRIV,LMPRIB,DEBUG) if(prname.ne.' ')then& creprc = sys$creprc(id(n),, . source,input,output,error,LMPRIVF 1 ,%val(list),prname,%val(LMPRIB),%val(uic),%val(mbx),%val(64)) else& creprc = sys$creprc(id(n),, . source,input,output,error,LMPRIVC 1 ,%val(list),,%val(LMPRIB),%val(uic),%val(mbx),%val(64)) end if else7 CALL GET_JPI(.FALSE.,LIST,LMPRIV,LMPRIB,DEBUG) if(prname.ne.' ')thenl& creprc = sys$creprc(id(n),, . source,input,output,error,LMPRIV8 1 ,%val(list),prname,%val(LMPRIB),,%val(mbx),) else& creprc = sys$creprc(id(n),, . source,input,output,error,LMPRIV2 1 ,%val(list),,%val(LMPRIB),,%val(mbx),) end if end if9 if(debug)write(6,*)' result of create process call'" if(debug)call errmes(creprc)CC return endCC( integer*4 function kilprc(n,dembug)C parameter nmax=32 implicit integer*4 (a-z)( common/procsub/id(nmax),chan(nmax) integer*4 id integer*2 chan logical debug'C this entry kills the sub-process. if(id(n).eq.0)then: if(debug)write(6,*)' process ',n,' already ended' end if"c kilprc = sys$delprc(id(n),0) call endprc(n,debug) return endCCC) integer*4 function gkilprc(n,debug)C parameter nmax=32 implicitn integer*4 (a-z)( common/procsub/id(nmax),chan(nmax) integer*4 id integer*2 chan logical debug external ss$_controly0C this entry kills the sub-process (gently). if(id(n).eq.0)then: if(debug)write(6,*)' process ',n,' already ended' end if. kilprc = sys$forcex(id(n),,ss$_controly) call endprc(n,debug) return endCC( integer*4 function endprc(n,debug)C parameter nmax=32 implicit integoer*4 (a-z)( common/procsub/id(nmax),chan(nmax) integer*4 id integer*2 chan logical debug logical rd_prc external ss$_abortC if(id(n).eq.0)then: if(debug)write(6,*)' process ',n,' already ended'! endprc = %loc(ss$_abort) return end if0 if(.not.rd_prc(.true.,n,debug,status))then* type *,'internal error in endprc'. type *,'bad termination mailbox read' type *,'on process ',n! p call sys$exit(ss$_abort) end if endprc = status return endCC3 logical function rd_prc(lwait,n,debug,result) parameter nmax=32 implicit integer*4 (a-z)( common/procsub/id(nmax),chan(nmax) integer*4 id integer*2 chan? common/pr_mail/message(4),status,pid,no,etime(2),acct(8),= 1 user(12),cputim,pagefl,pgflpeak,wspeak,biocnt,diocnt,& 2 volume,stime(2),opid,extra(50) byte message,acct,user ch qaracter*30 aetime,astime logical debug logical lwait integer*2 iostat(4)$ external io$_readvblk,io$m_now external ss$_normal@ CALL IFERR(LIB$GET_EF(IFLAG),'RD_PRC UNABLE TO GET AN EF') ifunc = %loc(io$_readvblk)2 if(.not.lwait)ifunc = ifunc + %loc(io$m_now)C call sys$qiow(%val(IFLAG),%val(chan(n)),%val(ifunc),iostat,,, 1 message,%val(90),,,,), rd_prc = iostat(1).eq.%loc(ss$_normal)? CALL IFERR(LIB$FREE_EF(IFLAG),'RD_ rPRC UANBLE TO FREE EF'),C type *,'rd_prc & iostat',rd_prc,iostat if(rd_prc)then+ call sys$asctim(len,aetime,etime,), call sys$asctim(len2,astime,stime,)% if(debug)call errmes(status)A if(debug)write(6,200)status,pid,aetime(1:len),acct,user, . cputim/100.,F 1 pagefl,pgflpeak,wspeak,biocnt,diocnt,volume,astime(1:len2), 2 opid2200 format(' status = ',z10,', pid = ',z10,/,G 1 ' end time was ',a,/,' account = s',8a1,', username = ',12a1,H 2 /,' cpu time = ',f10.2,', pagefaults = ',i10,', peak = ',i10,C 3 /,' working set = ',i10,', bio = ',i10,', dio = ',i10,/,< 4 ' volumes mounted = ',i10,/,' start time = ',a,/,& 5 ' owner process id = ',z10)C perform cleanupC operations id(n) = 0' call sys$dassgn(%val(chan(n))) end if result = status return endww0+7&È SUBROUTINE QDIV(A,B,C)C7C t This routine divides a quadword by a longword and4C returns a quadword result. It makes use of5C the routine EDIV which divides a quadword by0C a longword and gives a longword result.C= INTEGER*4 A(2),B,C(2),NUM(2),DENOM,DENOM2,QUOHI,ZERO(2) LOGICAL NEGATIVE DATA ZERO/0,0/ NEGATIVE = .FALSE.C6C make internal copy of args we may need to modifyC NUM(1) = A(1) NUM(2) = A(2) DENOM = BC*C check sign of nuumerator (high order)C IF(NUM(2).LT.0)THEN# CALL SUBQUAD(ZERO,NUM,NUM)! NEGATIVE = .NOT.NEGATIVE END IFCC check sign of divisorC IF(DENOM.LT.0)THEN DENOM = -DENOM! NEGATIVE = .NOT.NEGATIVE END IFC=C All the complications arise because the high bit of the@C result from EDIV must be cleared. Therefore, we divide>C the dividend by 2 first (more or less). However, the/C dividend had bettver be greater than 1.C IF(DENOM.EQ.1)THEN C(1) = NUM(1) C(2) = NUM(2) ELSE DENOM2 = DENOM/2+C quohi is the high order result * 2 QUOHI = NUM(2) / DENOM2=C leave only the remainder in the high order numerator3C (this guarantees no problems with EDIV)+ NUM(2) = NUM(2) - (QUOHI * DENOM2)C get low order result CALL EDIV(NUM,DENOM,C)+C stick in the highest bit if needed: w IF(MOD(QUOHI,2).EQ.1)C(1) = C(1) .OR. '80000000'X C store high order result C(2) = ISHFT(QUOHI,-1) END IFC*C now check for negative result neededC( IF(NEGATIVE)CALL SUBQUAD(ZERO,C,C) RETURN ENDww@r:7&ÈDC R1MACH FROM PORTLIB 08/15/79 D REAL FUNCTION R1MACH(I) DC DC SINGLE-PRECISIONx MACHINE CONSTANTS DC R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. DC DC R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. DC DC R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. DC DC R1MACH(4) = B**(1-T), THE LAyRGEST RELATIVE SPACING. DC DC R1MACH(5) = LOG10(B) DC DC TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, DC THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY DC REMOVING THE C FROM COLUMN 1. DC z DC WHERE POSSIBLE, OCTAL OR HEXADECIMAL CONSTANTS HAVE BEEN USED DC TO SPECIFY THE CONSTANTS EXACTLY WHICH HAS IN SOME CASES DC REQUIRED THE USE OF EQUIVALENT INTEGER ARRAYS. DC D INTEGER SMALL(2) D INTEGER LARGE(2) D INTEGER RIGHT(2) { D INTEGER DIVER(2) D INTEGER LOG10(2) DC D REAL RMACH(5) DC D EQUIVALENCE (RMACH(1),SMALL(1)) D EQUIVALENCE (RMACH(2),LARGE(1)) D EQUIVA|LENCE (RMACH(3),RIGHT(1)) D EQUIVALENCE (RMACH(4),DIVER(1)) D EQUIVALENCE (RMACH(5),LOG10(1)) DC DC MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. DC DC DATA RMACH(1) / Z400800000 / DC DATA RMACH(2) / Z5FFFF}FFFF / DC DATA RMACH(3) / Z4E9800000 / DC DATA RMACH(4) / Z4EA800000 / DC DATA RMACH(5) / Z500E730E8 / DC DC MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. DC DC DATA RMACH(1) / 01771000000000000 / ~ DC DATA RMACH(2) / O0777777777777777 / DC DATA RMACH(3) / O1311000000000000 / DC DATA RMACH(4) / O1301000000000000 / DC DATA RMACH(5) / O1157163034761675 / DC DC MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. DC  DC DATA RMACH(1) / 00014000000000000000B / DC DATA RMACH(2) / 37767777777777777777B / DC DATA RMACH(3) / 16404000000000000000B / DC DATA RMACH(4) / 16414000000000000000B / DC DATA RMACH(5) / 17164642023241175720B / DC DC MACHINE CONSTANTS FOR THE CRAY 1 DC  DC DATA RMACH(1) / 200004000000000000000B / DC DATA RMACH(2) / 577777777777777777777B / DC DATA RMACH(3) / 377214000000000000000B / DC DATA RMACH(4) / 377224000000000000000B / DC DATA RMACH(5) / 377774642023241175720B / DC DC MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 DC DC NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - DC STATIC RMACH(5) DC DC DATA SMALL/20K,0/,LARGE/77777K,177777K/ DC DATA RIGHT/35420K,0/,DIVER/36020K,0/ DC DATA LOG10/40423K,42023K/  DC DC MACHINE CONSTANTS FOR THE HARRIS 220 DC DC DATA SMALL(1),SMALL(2) / "20000000, "00000201 / DC DATA LARGE(1),LARGE(2) / "37777777, "00000177 / DC DATA RIGHT(1),RIGHT(2) / "20000000, "00000352 / DC DATA DIVER(1),DIVER(2) / "20000000, "00000353 / DC DATA LOG10(1),LOG10(2) / "23210115, "00000377 / DC DC MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. DC DC DATA RMACH(1) / O402400000000 / DC DATA RMACH(2) / O376777777777 / DC DATA RMACH(3) / O714400000000 / DC DATA RMACH(4) / O716400000000 / DC DATA RMACH(5) / O776464202324 / DC DC MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, DC THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. DC DC DATA RMACH(1) / Z00100000 / DC DATA RMACH(2) / Z7FFFFFFF / DC DATA RMACH(3) / Z3B100000 / DC DATA RMACH(4) / Z3C100000 / DC DATA RMACH(5) / Z41134413 / DC DC MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). DC DC DATA RMACH(1) / "000400000000 / DC DATA RMACH(2) / "377777777777 / DC DATA RMACH(3) / "146400000000 / DC DATA RMACH(4) / "147400000000 / DC DATA RMACH(5) / "177464202324 / DC DC MACHINE CONSTANTS FOR PDP-11 FORTRAN"S SUPPORTING DC 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). DC DC DATA SMALL(1) / 8388608 / DC DATA LARGE(1) / 2147483647 / DC DATA RIGHT(1) / 880803840 / DC DATA DIVER(1) / 889192448 / DC DATA LOG10(1) / 1067065499 / DC FC DATA RMACH(1) / '00040000000'O / FC DATA RMACH(2) / '17777777777'O / FC DATA RMACH(3) / '06440000000'O / FC DATA RMACH(4) / '06500000000'O / FC DATA RMACH(5) / '07746420233'O / DC # DATA SMALL(1) / '00000080'X /# DATA LARGE(1) / 'FFFF7FFF' X /# DATA RIGHT(1) / '00003480'X /# DATA DIVER(1) / '00003500'X /# DATA LOG10(1) / '209B359A'X /DC MACHINE CONSTANTS FOR PDP-11 FORTRAN"S SUPPORTING DC 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). DC DC DATA SMALL(1),SMALL(2) / 128, 0 / DC DATA LARGE(1),LARGE(2) / 32767, -1 / DC DATA RIGHT(1),RIGHT(2) / 13440, 0 / DC DATA DIVER(1),DIVER(2) / 13568, 0 / DC DATA LOG10(1),LOG10(2) / 16282, 8347 / DC DC DATA SMALL(1),SMALL(2) / O000200, O000000 / DC DATA LARGE(1),LARGE(2) / O077777, O177777 / DC DATA RIGHT(1),RIGHT(2) / O032200, O000000 / DC DATA DIVER(1),DIVER(2) / O032400, O000000 /  DC DATA LOG10(1),LOG10(2) / O037632, O020233 / DC DC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. DC DC DATA RMACH(1) / O000400000000 / DC DATA RMACH(2) / O377777777777 / DC DATA RMACH(3) / O146400000000 / DC DATA RMACH(4) / O147400000000 / DC DATA RMACH(5) / O177464202324 / DC HC-----------------------------------------------------------------------HC DELETE NEXT TWO STATEMENTS AFTER SUPPLYING THE PROPER DATA STATEMENTS.DC DATA RMACH(5) /0./ DC IF (RMACH(5) .EQ. 0.0) HC 1CALL ULIBER(2,45H R1MACH - MACHINE DEPENDENT CONSTANTS NOT SET,45)HC-----------------------------------------------------------------------D IF (I .LT. 1 .OR. I .GT. 5) D 1 CALL ULIBER (1,34H ERROR IN R1MACH - I OUT OF BOUNDS,34) DC D R1MACH = RMACH(I) D RETURN DC  D END DC DC DC DC DC DC DC ww o7&È8 SUBROUTINE GBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)& DIMENSION NPACK(ITER),ISAM(ITER)5C THIS ROUTINE IS JUST A REPEATED CALL TO GBIT/C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS#C AND THE LOOP COUNT IS ITER ISW = 1 GO TO 103 ENTRY SBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)5C THIS ROUTINE IS JUST A REPEATED CALL TO SBIT/C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS#C AND THE LOOP COUNT IS ITER ISW = 2 GO TO 104 ENTRY GBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)6C THIS ROUTINE IS JUST A REPEATED CALL TO GBYTE/C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS#C AND THE LOOP COUNT IS ITER ISW = 3 GO TO 104 ENTRY SBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)6C THIS ROUTINE IS JUST A REPEATED CALL TO SBYTE/C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS#C AND THE LOOP COUNT IS ITER ISW = 410 IOFF = IBIT IBASE = 1 DO 20 I = 1 , ITER GO TO(11,12,13,14)ISW311 CALL GBIT(NPACK(IBASE),ISAM(I),IOFF,NBITS) GO TO 15312 CALL SBIT(NPACK(IBASE),ISAM(I),IOFF,NBITS) GO TO 15413 CALL GBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS) GO TO 15414 CALL SBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS)$15 IOFF = IOFF + NBITS + NSKIP& IBASE = IBASE + IOFF/32  IOFF = MOD(IOFF,32)20 CONTINUE RETURN END- SUBROUTINE GBYTE(NPACK,ISAM,IBIT,NBITS)C9C gbyte and sbyte are special routines to do the same/C things as their counterparts on the Mesa.5C They differ from the bits routines in that bits6C are counted from the top of the word rather thanDC the bottom. This means that the bits they specify jump around<C when crossing byte boundaries. There is no assumption>C made about the wordsize of the machine they were written?C on. However the maximum number of bits extracted must beC less than or equal to 32.C BYTE NPACK(8) INTEGER T EXTERNAL SS$_ABORT IDBIT(I) = 7 - MOD(I,8) ISW = 3 ISAM = 0 GO TO 10( ENTRY SBYTE(NPACK,ISAM,IBIT,NBITS) ISW = 410 IBASE = IBIT/8-C ibase points to the first byte involved IOFF = IBIT - 8*IBASE.C ioff is the bit offset within first byte M = (IOFF+NBITS-1)/8 + 1<C m is the number of bytes (including partials) involvedC IF(M.GT.5)THEN IF(NBITS.GT.32)THEN< TYPE *,'ILLEGAL VALUE FOR NBITS IN S/GBYTE(S) CALL'! CALL SYS$EXIT(SS$_ABORT) END IF NN = 0*C nn is the number of bits transferred DO 20 I = M , 1 , -1C loop on bytes IS = IDBIT(0)#C calc first bit within byte IE = IDBIT(7)"C calc last bit within byte# IF(I.EQ.1)IS = IDBIT(IOFF)(C first bit varies for first byte+ IF(I.EQ.M)IE = IDBIT(IOFF+NBITS-1)&C last bit varies for last byte N = IS - IE + 10C calc number of bits within byte to xfer IF(ISW.EQ.4)GO TO 12) CALL GBIT(NPACK(IBASE+I),T,IE,N)!C extract bits from source CALL SBIT(ISAM,T,NN,N)"C and load into destination GO TO 1512 CALL GBIT(ISAM,T,NN,N)!C extract bits from source) CALL SBIT(NPACK(IBASE+I),T,IE,N)"C and load into destination15 NN = NN + NC update bits xferred20 CONTINUE RETURN ENDww D7&È SUBROUTINE T_ASSG(LDRV) IMPLICIT INTEGER*4 (S)@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CHARACTER*6 DRIVES(0:1) DATA LFIRST/2*.TRUE./$ DATA DRIVES/'_MTA0:','_MTA1:'/8 CALL IFERR(SYS$ASSIGN(DRIVES(LDRV),ICHAN(LDRV),,),- . 'T_ASSG COULDN''T ASSIGN A CHANNEL')D TYPE *,LDRV,ICHAN(LDRV)) CALL IFERR(LIB$GET_EF(IFLAG(LDRV)),& . 'T_ASSG COULDN''T GET AN EF') LFIRST(LDRV)=.FALSE.. CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_ASSG COULDN''T SET EF')C set status to success ISTAT(LDRV)=0 RETURN END+ SUBROUTINE T_READ(LDRV,BUFFER,LENGTH)CC RAW TAPE I/OC CALL WITH:(C CALL T_READ(LDRV,BUFFER,LENGTH)C where8C LDRV is magtape drive number, eg 0 for MTA0:%C BUFFER is buffer address,%C LENGTH is number of bytesC,C Also, execution is asynchronous.C IMPLICIT INTEGER*4 (S) EXTERNAL IO$_READVBLK@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = LENGTHC I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_READVBLK, 1IOSB(1,LDRV),,, 1BUFFER,%VAL(LENGTH),,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_READ COULDN''T SET EF') ISTAT(LDRV)=2 RETURN END+ SUBROUTINE T_WRIT(LDRV,BUFFER,LENGTH)CC RAW TAPE I/OC CALL WITH:(C CALL T_WRIT(LDRV,BUFFER,LENGTH)C where8C LDRV is magtape drive number, eg 0 for MTA0:%C BUFFER is buffer address,%C LENGTH is number of bytesC,C Also, execution is asynchronous.C IMPLICIT INTEGER*4 (S) EXTERNAL IO$_WRITEVBLK@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = 0D I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_WRITEVBLK, 1IOSB(1,LDRV),,, 1BUFFER,%VAL(LENGTH),,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_WRIT COULDN''T SET EF') ISTAT(LDRV)=2 RETURN END+ SUBROUTINE T_WAIT(LDRV,NSTATE,NBYTES)C8C LDRV is magtape drive number, eg 0 for MTA0:C(C RETURNS NSTATE = 0 => SUCCESS$C 1 => EOF&C 2 => ERROR$C 3 => EOT7C  NBYTES = NUMBER OF BYTES IN LAST TRANSFERC IMPLICIT INTEGER*4 (S) EXTERNAL SS$_ENDOFFILE EXTERNAL SS$_DATAOVERUN@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST COMMON/IO_ERR/WRTMES LOGICAL WRTMES INTEGER*2 IST(4,0:1) EQUIVALENCE (IOSB,IST) DATA WRTMES/.TRUE./C CALL T_CHECK(LDRV)/ CALL IFERR(SYS$WAITFR(%VAL(IFLAG(LDRV))),( . 'T_WAIT COULDN''T WAIT FOR EF') CALL T_CHECK(LDRV) ISTAT(LDRV) = 0 IRES = IST(1,LDRV)! IRES = IRES.AND.'0000FFFF'X" IF(MOD(IRES,8).EQ.1)GO TO 10 ISTAT(LDRV)=22 IF(IRES.EQ.%LOC(SS$_ENDOFFILE))ISTAT(LDRV)=1" IF(ISTAT(LDRV).NE.2)GO TO 10 CALL ERRMES(IRES)C10 CONTINUE NSTATE=ISTAT(LDRV) NBYTES=IST(2,LDRV)# NBYTES=NBYTES.AND.'0000FFFF'XC6C unfortunately, the VMS 1.6 handler never returnsC SS$_DATAOVERUNC*C  IF(IRES.EQ.%LOC(SS$_DATAOVERUN))THEN8 IF((NBY(LDRV).NE.0).AND.(NBYTES.GT.NBY(LDRV)))THEN$ IRES = %LOC(SS$_DATAOVERUN)$ IF(WRTMES)CALL ERRMES(IRES)' NBYTES = MIN(NBYTES,NBY(LDRV)) END IF RETURN END SUBROUTINE T_WEOF(LDRV)CC RAW TAPE I/OC CALL WITH:C CALL T_WEOF(LDRV)C where8C LDRV is magtape drive number, eg 0 for MTA0:C,C Also, execution is asynchronous.C IMPLICIT INTEGER*4 (S) EXTERNAL IO$_WRITEOF@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = 0B I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_WRITEOF, 1IOSB(1,LDRV),,, 1,,,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_WEOF COULDN''T SET EF')  ISTAT(LDRV)=2 RETURN END SUBROUTINE T_RWND(LDRV)CC RAW TAPE I/OC CALL WITH:C CALL T_RWND(LDRV)C where8C LDRV is magtape drive number, eg 0 for MTA0:C,C Also, execution is asynchronous.C IMPLICIT INTEGER*4 (S) EXTERNAL IO$_REWIND@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = 0A I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_REWIND, 1IOSB(1,LDRV),,, 1,,,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_RWND COULDN''T SET EF') ISTAT(LDRV)=2 RETURN END$ SUBROUTINE T_SKPF(LDRV,NUMBER)CC RAW TAPE I/OC CALL WITH:!C CALL T_SKPF(LDRV,NUMBER)C where8C LDRV is magtape drive number, eg 0 for MTA0:1C NUMBER is the number of files to skipC,C Also, execution is asynchronous.C IMPLICIT INTEGER*4 (S) EXTERNAL IO$_SKIPFILE@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = 0C I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_SKIPFILE, 1IOSB(1,LDRV),,, 1%VAL(NUMBER),,,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),# . 'T_SKPF COULDN''T SET EF') ISTAT(LDRV)=2 RETURN END$ SUBROUTINE T_SKPR(LDRV,NUMBER)CC RAW TAPE I/OC CALL WITH:!C CALL T_SKPR(LDRV,NUMBER)C where8C LDRV is magtape drive number, eg 0 for MTA0:1C NUMBER is the number of files to skipC,C Also, execution is asynchronous.C  IMPLICIT INTEGER*4 (S) EXTERNAL IO$_SKIPRECORD@ COMMON/T_COM/IOSB(2,0:1),ISTAT(0:1),LFIRST(0:1),ICHAN(0:1)& COMMON/T_COM/IFLAG(0:1),NBY(0:1) LOGICAL LFIRST CALL T_CHECK(LDRV)' IF(LFIRST(LDRV))CALL T_ASSG(LDRV) NBY(LDRV) = 0E I = SYS$QIO(%VAL(IFLAG(LDRV)),%VAL(ICHAN(LDRV)),IO$_SKIPRECORD, 1IOSB(1,LDRV),,, 1%VAL(NUMBER),,,,,) IF(MOD(I,8).EQ.1)RETURN CALL ERRMES(I). CALL IFERR(SYS$SETEF(%VAL(IFLAG(LDRV))),#  . 'T_SKPR COULDN''T SET EF') ISTAT(LDRV)=2 RETURN END SUBROUTINE T_CHECK(LDRV)+ IF((LDRV.GE.0).AND.(LDRV.LE.1))RETURN5 TYPE *,'ILLEGAL VALUE OF LDRV IN TAPEIO :',LDRV STOP ENDww`7&È SUBROUTINE WAIT(X)BC WAIT PUTS YOU TO SLEEP FOR X SECONDS WHERE X IS ANY FLOATING C NUMBER IMPLICIT INTEGER*4 (S) INTEGER*4 DELAY(2) LOGICAL ERROR EXTERNAL SS$_ABORT ERROR(I) = MOD(I,8).NE.1;C NOTE THAT THE ALGORITHM IS SUBJECT TO ROUNDING ERRORS?C BUT THESE SHOULD NOT GIVE ANY SERIOUS PROBLEMS TO ANYONE. Y = X * 1.E7C Y IS TICS DELAY(2) = Y/4.294967296E9C COMPUTE REMAINDER$ Y = Y - DELAY(2)*4.294967296E9 DELAY(2) =.NOT.DELAY(2)%C SO MUCH FOR THE HIGH ORDER PARTC NOW FOR THE LOW.D TYPE *,YC MAKE SURE IT IS POSITIVE Y = AMAX1(Y,0.0)D TYPE *,YGC THROW AWAY 1 100NSEC RESOLUTION TO SIMPLIFY SIGN OVERFLOW PROBLEM DELAY(1) = Y/2." DELAY(1) = ISHFT(DELAY(1),1) DELAY(1) = - DELAY(1) I = LIB$GET_EF(IFLAG) IF(ERROR(I))THEN CALL ERRMES(I)7 TYPE *,'ERROR IN OBTAINING EVENT FLAG IN WAIT'! CALL SYS$EXIT(SS$_ABORT) END IF) I = SYS$SETIMR(%VAL(IFLAG),DELAY,,) IF(ERROR(I))THEN CALL ERRMES(I)0 TYPE *,'ERROR IN SETTING TIMER IN WAIT'! CALL SYS$EXIT(SS$_ABORT) END IF! I = SYS$WAITFR(%VAL(IFLAG)) IF(ERROR(I))THEN CALL ERRMES(I)3 TYPE *,'ERROR IN WAITING FOR FLAG IN WAIT'! CALL SYS$EXIT(SS$_ABORT) END IF I = LIB$FREE_EF(IFLAG) IF(ERROR(I))THEN CALL ERRMES(I)2 TYPE *,'ERROR FREEING EVENT FLAG IN WAIT'! CALL SYS$EXIT(SS$_ABORT) END IF2D TYPE 101,DELAY(2),DELAY(1),DELAY(2),DELAY(1)101 FORMAT(2Z8,5X,2I15) RETURN ENDwwཷ_&È .title dibdef$dibdef GLOBAL.endww_&È .title iskio; .LIST MEB* .macro struct nJfab'n': $fab ctx=n,fop=,rfm=var,dnm=, -- rat=cr,nam=nam'n',xab=xab'n'3rab'n': $rab ctx=n,fab=fab'n',rop=8nam'n': $nam rsa=rs'n',rss=nam$c_maxrss, -. esa=es'n',ess=nam$c_maxrss'rs'n': .blkb nam$c_maxrss'es'n': .blkb nam$c_maxrssprmpt'n': .blkb 256xab'n': u $xabpro .save% .psect fabt' .address fab'n'% .psect rabt' .address rab'n'% .psect namt' .address nam'n'% .psect prmt) .address prmpt'n'% .psect xabt'  .address xab'n' .restore .endm struct0 .macro setblk units=4s_sts: .long 0 .blkl unitss_len: .long 0 .blkl unitss_eofmess: .long 0 .blkl units .save .psect fabt fabtb:  .long 0 .psect rabt rabtb:  .long 0 .psect namtnamtb: .long 0 .psect prmtprmtb: .long 0 .psect xabtxabtb: .long 0 .restore n = 0 .rept units n = n + 1# struct \n .endr; .endm setblk; setblk 20;;N; IF(.NOT.D_OPEN(lun,'R' or 'W',filename [,nbuffs]))STOP 'D_OPEN ERROR'M; where lun is the iopack lun (not related to FORTRAN luns at all),G; 'W' must be specified to get write access to the file6; in which case a new file is created,F; filename is the filename in either CHARACTER form or.; null terminated BYTE string,H; and nbuffs is an optional buffer count which specifiesH; how many buffers to use in all i/o requests. This hasL; a great deal to do with actual speed. 11 is a good choice.J; There is an optional UIC parameter at the end which says ;; to set the owner field if its a new file.>; D_OPEN returns .TRUE. iff the open was successful.#d_open:: .word ^m1 movzbl @4(ap),r2 ;get lun! clrl s_sts[r2]  clrl s_len[r2]G ashl #2,r2,r2 ; mul by 2 to get word offset F $rab_store rab=@l^rabtb(r2),mbc=#0 ; clear out buffer G $fab_store fab=@l^fabtb(r2),deq=#0 ; counts in case of L $fab_store fab=@l^fabtb(r2),alq=#0 ; previous use of io lun L $xabpro_store xab=@l^xabtb(r2),uic=#0 ; also clear out owner4 cmpw 0(ap),#5 ;are there 5 args ?/ beql owner ;yes.set owner4 cmpw 0(ap),#4 ;are there 4 args ?E beql mbc ;YES. They specified a buffer count.4 cmpw 0(ap),#3 ;are there 3 args ?L beql name ;YES. Good, that's only other leg al choice / jmp badarg ;errorowner:> tstl 20(ap) ;did they specify an address?- beqlu mbc ;no. skip it9 moval @l^xabtb(r2),r1 ;get xab address into r1& movl @20(ap),xab$l_uic(r1)?mbc: ; user-specified buffer count : tstl 16(ap) ; did they omit address ?& beqlu name ; yes3 tstl @16(ap) ; did they say 0 ?3 beqlu name ; Yes. Ignore themK $rab_store rab=@l^rabtb(r2),mbc=@16(ap) ; use user value forL $fab_store fab=@l^fabtb(r2),deq=@16(ap) ; multi-buffer count M $fab_store fab=@l^fabtb(r2),alq=@16(ap) ; file alloc & extend name:; moval @12(ap),r0 ; get addr of descriptor  jsb filenamedone:L $rab_store rab=@l^rabtb(r2),rop=; select asynch operation# moval @8(ap),r0 ;1 beql read ;default to read8 cmpb @4(r0),#^a/W/ ;did they say '/W/rite'% beql write ;yes2 cmpb @4(r0),#^a/w/ ;try small w too.& beql write ;yes.7 cmpb @4(r0),#^a/A/ ;did they say append ?% beql append ;yes/ cmpb @4(ap),#^a/a/ ;try lowercase1 bneq read ;no must be readappend:K $rab_store rab=@l^rabtb(r2),rop=; select append modeO $fab_store fab=@l^fabtb(r2),fac=;so you can do find  brb rdapp7write: ; open a new file for writing O $fab_store fab=@l^fabtb(r2),fac=;so you can do find = $create fab=@l^fabtb(r2),err=error,suc=error> blbc r0,opnret ; on error, return with error code. brb conn9read: ; open an existing file to read 3 $fab_store  fab=@l^fabtb(r2),fac=5rdapp: $open fab=@l^fabtb(r2),err=error,suc=error> blbc r0,opnret ; on error, return with error code.Iconn: ; in either case connect a record stream to it. = $connect rab=@l^rabtb(r2),err=error,suc=error opnret: retbadarg: pushal invarg calls #1,errmes ret invarg: .long mth$_wronumarg filename:3 ; filename is a simple subroutine to9 ; sto re the filename specified in the fab.B ; On call, R0 must point to the filename descriptor< ; (or address of the BYTE buffer) and R2 must3 ; serve as a pointer into the FABTB.N ; On return the FAB has been set with the appropriate filename. movl r0,r3< cmpb 2(r0),#14 ;is it a character string ?N beql char ;yes. Descriptors always have 14 in high wordH movl r0,r1 ;no t CHAR, must be BYTE w/ null at end cloop:; tstb (r1)+ ;look for terminating null/ bneq cloop ;not yet foundF decl r1 ;found null. point to last good char 3 subl r0,r1 ;get string length9 $fab_store fab=@l^fabtb(r2),fns=r1,fna=(r3); brb done rsbchar:1 movzbl (r3),r1 ;get string length2 movl 4(r3),r0 ;get string address/ decl r0 ;r1 is 1 too big<chloop: ;get rid of trailing blanks5 addl2 r1,r0 ;get last char of string0 cmpb (r0),#^a/ / ;is it a blank ?B bneq cdon ;no. stop looking for more blanks: subl2 r1,r0 ;fix up address for next time0 sobgtr r1,chloop ;decrement lengthcdon:; $fab_store fab=@l^fabtb(r2),fns=r1,fna=@4(r3) rsb;;;$; CALL D_CLOS(lun)  ,where<; lun is the iopack lun (no relation to FORTRAN luns);d_clos:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2F jsb wait ;even though this is a file operationI ;you can't do it until record processing+ ;completes movzbl @4(ap),r0 clrl s_sts[r0] clrl s_len[r0]# movzbl #-1,s_eofmess[r0]= $close fab=@l^fabtb(r2),err=error,suc=error! moval @l^fabtb(r2),r1I bicl2 #fab$m_dlt,fab$l_fop(r1) ; specify no delete on closeH bicl2 #fab$m_spl,fab$l_fop(r1) ; specify no spool on closeN bicl2 #fab$m_scf,fab$l_fop(r1) ; specify no submit file on close ret;;Derrlst: .long rms$_acc,rms$_atr,rms$_atw,rms$_cda,rms$_chn,rms$_creD .long rms$_dac,rms$_dnf,rms$_dpe,rms$_ent,rms$_ext,rms$_fndD .long r ms$_ifa,rms$_irc,rms$_mkd,rms$_net,rms$_rer,rms$_rmvD .long rms$_rpl,rms$_sup,rms$_sys,rms$_wbe,rms$_wer,rms$_wpl endlst: error: .word ^mF moval @4(ap),r2 ;happily error is called by an AST " movl rab$l_ctx(r2),r3) movl rab$l_sts(r2),s_sts[r3]G ashl #2,r3,r0 ;r0 is pointer into longword tables5 moval @l^namtb(r0),r1 ;r1 points to namG bitl #nam$m_wildcard,nam$l_fnb(r1) ;check for wildcard op.J beqlu 10$ ; no special stuff except on wildcards8 cmpl s_sts[r3],#rms$_nmf ; fake it for nmf beqlu 11$5 cmpl s_sts[r3],#rms$_fnf ; same for fnf bnequ 10$(11$: movl #rms$_normal,s_sts[r3]10$:) movzwl rab$w_rsz(r2),s_len[r3] pushal s_sts[r3] blbs @(sp),okay tstl s_eofmess[r3] beql 12$F cmpl #rms$_eof,@(sp) ;assume that rab$l_sts and fab$l_sts 8 beql okay ;will always coincide. 12$: blbs wrtmes,do_mes cmpl #rms$_rtb,@(sp) beql okay?do_mes: calls #1,errmes ;dump error mess. unless EOF.  moval errlst,r1$eloop: cmpl rab$l_sts(r2),(r1)+ beql do_stv cmpl r1,#endlst beql okay brb eloopdo_stv: pushal rab$l_stv(r2) calls #1,errmesokay: clrl s_eofmess[r3] ret;;;wait:! $wait rab=@l^rabtb(r2) rsb;; CALL D_LEN(lun)$; where lun is the iopack lun5; returns the number of bytes read in the last; transfer.d_len:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait movzbl @4(ap),r1 movl s_len[r1],r0 ret;;; ; IF(D_UNIT(lun))30,40,509; where 30 is the label for a successful operation%; 40 is the label for EOF, and*; 50 is the label for error return.A; A call to D_UNIT or D_LEN synchronizes the io by waiting-; for it to complete before returning.d_unit:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait movzbl @4(ap),r1 movl s_sts[r1],r0 blbs r0,minus cmpl #rms$_eof,r0 beqlu zero  cmpl #rms$_rtb,r0 beqlu minusplus: movf #^f1.0,r0 retzero: movf #^f0.0,r0 retminus: movf #^f-1.0,r0 ret;;;#; CALL D_GET(lun,buffer,len)4; reads the next record from disk into BUFFER9; The maximum number of bytes in the transfer will2; be len. Note that D_GET is asynchronous.d_get:: .word ^m" movzbl @4(ap),r2 ashl #2,r2 ,r2 jsb wait4 cmpw 0(ap),#3 ;better have 3 args beql goin jmp badargDgoin: ; set up max record size and buffer address @ $rab_store rab=@l^rabtb(r2),ubf=@8(ap),usz=@12(ap) movzbl @4(ap),r1# movzbl #-1,s_eofmess[r1]< $get rab=@l^rabtb(r2),err=error,suc=error! moval @l^rabtb(r2),r1J bits_to_clear = rab$m_cco!rab$m_rne!rab$m_cvt!rab$m_pta!rab$m_pmtF bicl2 #bits_to_clear,rab$l_rop(r1) ;clear read modifiers ret; ; map into COMMON/IO_ERR/; .save< .psect IO_ERR,pic,ovr,rel,gbl,shr,noexe,rd,wrt,longwrtmes: .long 1 .restore;;;#; CALL D_PUT(lun,buffer,len)5; writes out the next record to iopack lun LUN;; using len bytes starting at buffer. Asynchronous.d_put:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait2 cmpw 0(ap),#3 ;better be 3 args beql goout jmp badargKgoout: ; set up buffer address and record length ; $rab_store rab=@l^rabtb(r2),rbf=@8(ap),rsz=@12(ap)2 $put rab=@l^rabtb(r2),err=error,suc=error ret;;;; CALL D_MARK(lun,addr);; stores the address (RFA) of the current record ?; in addr. addr must be able to hold at least 6 bytes;d_mark:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait moval @l^rabtb(r2),r1 movaw @8(ap),r0$ movw rab$w_rfa(r1),(r0)+& movw rab$w_rfa+2(r1),(r0)+& movw rab$w_rfa+4(r1),(r0)+ ret;;;; CALL D_JUMP(lun,addr)8; moves the file position to the record whose ;; address was stored previously in addr by a call; to D_MARKd_jump:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait0 $rab_store rab=@l^rabtb(r2),rac= movaw @8(ap),r0 moval @l^rabtb(r2),r1$ movw (r0)+,rab$w_rfa(r1)& movw (r0)+,rab$w_rfa+2(r1)& movw (r0)+,rab$w_rfa+4(r1)5 $find rab=@l^rabtb(r2),err=error,suc=error0 $rab_store rab=@l^rabtb(r2),rac= ret;;;&; CALL D_NAME(l un,filename,len);/; where filename is a CHARACTER variable4; which will receive the full filespec of the2; currently open file,and LEN is the length; of the filenamed_name:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2K moval @l^namtb(r2),r1 ;r1 points to the NAM block in question@ movzbl nam$b_rsl(r1),r2 ;r2 holds the size of stringH moval @nam$l_rsa(r1),r1 ;r1 holds the address of the string8 moval @8(ap),r0 ;r0 holds descriptor movzwl r2,@12(ap), movc5 r2,(r1),#^a/ /,(r0),@4(r0) ret;;; call D_FID(lun,buff);,; where lun is the usual iolun number?; and buff is the address of a 28 byte buffer. The first2; 16 bytes are loaded with the device name,3; the next 6 bytes are the FID, and the last2; 6 are the DID. This routine is primarily0; useful if you want to send a message to; the symbiont.;!d_fid:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2K moval @l^namtb(r2),r6 ;r1 points to the NAM block in question< movc5 #nam$c_dvi,nam$t_dvi(r6),#^a/ /,#16,@8(ap)' movc3 #6,nam$w_fid(r6),(r3)' movc3 #6,nam$w_did(r6),(r3) ret;/; CALL D_RNAM(lun1,oldfile,lun2,newfile);4; where oldfile & newfile are the old and new,; filespecs for the rename operation.5; Note that both lun1 & lun2 must not be open.;d_rnam:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @8(ap),r0 jsb filenameA pushl r2 ; save oldfab for further use later  movzbl @12(ap),r2 ashl #2,r2,r2 moval @16(ap),r0 jsb filename7 movl (sp)+,r3 ; r3 is pointer to oldfabM $rename oldfab=@l^fabtb(r3),newfab=@l^fabtb(r2),err=error,suc=error8 ret ; Return with status code.;;); I = D_ERAS(IOLUN,FILENAME),where0; IOLUN is a currently closed IOLUN, &9; FILENAME is the name of a file to be deleted.<; exceptionally, we do allow wildcards in FILENAME;d_eras:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @8(ap),r0 jsb filename6 $parse fab=@l^fabtb(r2),err=error,suc=error blbs r0,edloop jmp eretedloop:6 $search fab=@l^fabtb(r2),err=error,suc=errorN cmpl r0,#rms$_nmf ; have we exhausted wild-card processing ? bnequ 10$ jmp edone10$: blbs r0,20$ jmp eret20$:! moval @l^fabtb(r2),r1K bisl2 #fab$m_nam,fab$l_fop(r1) ; specify NAM block processing6 $erase fab=@l^fabtb(r2),err=error,suc=error! moval @l^fabtb(r2),r1K bicl2 #fab$m_nam,fab$l_fop(r1) ; specify NAM block processing blbc r0,eret> moval @l^namtb(r2),r1 ; R1 points to namblock/ bitl #nam$m_wildcard,nam$l_fnb(r1) beqlu edone jmp edloopedone:! movl #rms$_normal,r0 eret: retd_delt:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^fabtb(r2),r1F bisl2 #fab$m_dlt,fab$l_fop(r1) ; specify delete on close retd_sbmt:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^fabtb(r2),r1F bisl2 #fab$m_scf,fab$l_fop(r1) ; specify delete on close retd_spool:: .word ^m" movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^fabtb(r2),r1F bisl2 #fab$m_spl,fab$l_fop(r1) ; specify delete on close retd_cco:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^rabtb(r2),r1M bisl2 #rab$m_cco,rab$l_rop(r1) ; specify cancel ^O on next read retd_rne:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^rabtb(r2),r1O bisl2 #rab$m_rne,rab$l_rop(r1) ; specify read no echo on next read retd_cvt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^rabtb(r2),r1J bisl2 #rab$m_cvt,rab$l_rop(r1) ; specify CUPPER on next read retd_pta:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^rabtb(r2),r1N bisl2 #rab$m_pta,rab$l_rop(r1) ; specify purge type ahead buffer ret$d_pmt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2! moval @l^rabtb(r2) ,r1J bisl2 #rab$m_pmt,rab$l_rop(r1) ; specify prompt on next readF moval @8(ap),r0 ; R0 points to descriptor movzbl 0(r0),r3E movb 0(r0),rab$b_psz(r1) ; set prompt string sizeH; moval @4(r0),rab$l_pbf(r1) ; set prompt string addressH moval @l^prmtb(r2),rab$l_pbf(r1) ; set prompt string addressE movc5 r3,@4(r0),#^a/ /,#256,@l^prmtb(r2) ; store prompt retd_trunc:: .word ^m! movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait: $truncate rab=@l^rabtb(r2),err=error,suc=error ret .endww e`&È .title errmes;=; This routine prints the message associated with a given; error code.9; It is an equivalent of the previous FORTRAN routine?; of the same name. The advantage of this implimentation is;; that it is re-entrant and hence callable from an AST.; .list meberrmes:: .word ^m clrl -(sp) pushl @4(ap) pushl #1 moval (sp),r2 $putmsg_s msgvec=(r2) blbc r0,baderr retbaderr: $exit_s code=#ss$_abort .endww``&È .TITLE GCML;; ; GCML4; May be called as either CHARACTER*N GCML,RES+; RES = GCML() or as CHARACTER*N RES; CALL GCML(RES).;- .LIBRARY /SYS$LIBRARY:LIB.MLB/ .LIST ME-GETCMD: $CLIREQDESC RQTYPE = CLI$K_GETCMD-GCML:: .WORD ^M MOVL FP,R11LOOP: MOVL R9,R8 MOVL R10,R9 MOVL R11,R10 MOVL 12(R10),R11 BNEQ LOOP MOVL 8(R8),R8 PUSHAB W^GETCMD& CALLS #1,@CLI$A_UTILSERV(R8)B; MOVL 4(AP),R11 ;R11 is descriptor addressD; MOVL 4(R11),R10 ;R10 has destination addressB; MOVZWL (R11),R11 ;R11 is destination length=; MOVC5 GETCMD+CLI$Q_RQDESC,@GETCMD+CLI$Q_RQDESC+4, -C; #^X20,R11,(R10) ;transfer characters across MOVAL @4(AP),R11? MOVC5 GETCMD+CLI$Q_RQDESC,@GETCMD+CLI$Q_RQDESC+4, -& #^A/ /,(R11),@4(R11) RET .ENDww`&È .title iferr,; this function returns the value of the; first argument.<; If this is an error then the appropriate error message9; text is output, the user-supplied string is output,; and the image exits.; ; USAGE:C; J = IFERR(SYS$SETEF(%VAL(FTHEM)),'RJEMASTER UNABLE TO SETEF');iferr:: .word ^m movl @4(ap),r0 blbc r0,doit retdoit: clrl -(sp) pushl r0 pushl #1 moval (sp),r2 movq @8(ap),desc+ $putmsg_s msgvec=(r2),actrtn=ifexit $exit_s code=@4(ap)desc: .quad 0ifexit: .word 0 movq desc,@4(ap) ret .endww`&È .title jpidef$jpidef GLOBAL.endww`&È .TITLE lcmemm;9; being an emulation of the LCM routines on the 7600.;lcmrd:: .WORD ^m ashl #2,@12(ap),r0 ashl #2,@4(ap),r1 movc3 r0,(r1),@8(ap) retlcmwt:: .WORD ^m ashl #2,@12(ap),r0 ashl #2,@4(ap),r1 movc3 r0,@8(ap),(r1) ret .ENDww`&È .title PEEVEE;"; PEE impliments a P operation;+; PEE(ADDR) sets the lowest bit of ADDR4; and returns TRUE if it was clear to start with;PEE:: .word 02 movl #1,r0 ;initialize result to success8 bbcs #0,@4(ap),10$ ; branch on bit clear and set clrl r010$: ret;VEE:: .word 02 movl #1,r0 ;initialize result to success8 bbsc #0,@4(ap),10$ ; branch on bit set and clear clrl r010$: ret .endww@/`&È .title pqldef$pqldef GLOBAL.endww`&È .TITLE QUADMATH;; SUBROUTINE SUBQUAD.MAR;D; FORTRAN CALLABLE ROUTINE TO SUBTRACT TWO QUAD WORD INTEGERS;; CALL SUBQUAD (A,B,C);; RETURNS: A - B -> C;' .ENTRY SUBQUAD ^MK; note that you cannot enable integer overflow or this will fail.;;A = 4B = 8C = 12D = 16> MOVQ @A(AP),R0 ;GET FIRST PARAM FOR SUBTRACT? ;NEED TO USE REGISTERS BECAUSE@ ;SUBWC IS ONLY 2 ADDRESS INSTR.> MOVAQ @B(AP),R2 ;GET ADDRESS OF SECOND PARAM.B SUBL (R2)+,R0 ;SUBTRACT FIRST HALF OF ARGUMENTSA SBWC (R2),R1 ;THEN DO THE SECOND HALF2 MOVQ R0,@C(AP) ;STORE THE RESULT RET;;; SUBROUTINE ADDQUAD.MAR;?; FORTRAN CALLABLE ROUTINE TO ADD TWO QUAD WORD INTEGERS;; CALL ADDQUAD (A,B,C);; RETURNS: A + B -> C;' .ENTRY ADDQUAD ^MK; note that you cannot enable integer overflow or this will fail.;;A = 4B = 8C = 12> MOVQ @A(AP),R0 ;GET FIRST PARAM FOR SUBTRACT? ;NEED TO USE REGISTERS BECAUSE@ ;SUBWC IS ONLY 2 ADDRESS INSTR.> MOVAQ @B(AP),R2 ;GET ADDRESS OF SECOND PARAM.B ADDL (R2)+,R0 ;SUBTRACT FIRST HALF OF ARGUMENTSA ADWC (R2),R1 ;THEN DO THE SECOND HALF2 MOVQ R0,@C(AP) ;STORE THE RESULT RET;;;* .ENTRY EDIV ^M;; CALL EDIV (A,B,C); RETURNS A/B -> C;4 MOVQ @A(AP),R0 ;GET FIRST ARGUMENT>; MOVAL @B(AP),R2 ;GET LONGWORD DIVISOR ADDRESS1; EDIV (R2),R0,R0,R1 ;DO THE DIVISION MOVL @B(AP),R2 EDIV R2,R0,R0,R1D MOVL R0,@C(AP) ;STORE INTEGER QUOTIENT,IGNORE REM. RET* .ENTRY EMUL ^M;; CALL EMUL (A,B,C,D); RETURNS D = A*B + C;4 MOVAQ @D(AP),R0 ;GET RESULT ADDRESSC EMUL @A(AP),@B(AP),@C(AP),(R0) ;DO MULT AND STORE RESULT RET3 .ENTRY QMUL ^M;; CALL QMUL (A,B,C); RETURNS C = A * B'; where A, B, & C are quadwords.;A; this code is copied from the VAX11 Architecture Handbook; MOVAQ @A(AP),R2 MOVAQ @B(AP),R3 EMUL (R2),(R3),#0,R4 MULL3 4(R2),(R3),R0 MULL3 (R2),4(R3),R1 ADDL R1,R0 TSTL (R2) BGEQ 10$ ADDL (R3),R010$: TSTL (R3) BGEQ 20$ ADDL (R2),R020$: ADDL R0,R5 MOVQ R4,@C(AP) RET .ENDww@`&È .title sgbit0; this routine extracts bits from vax words.5; it is similar to NCAR's GBYTE but it works with2; the natural underlying structure of the VAX.;&; CALL GBIT(NPACK,ISAM,IBIT,NBITS)5; unpacks the bit pattern located at a bit offset1; of IBIT in NPACK of length NBITS into ISAM.;gbit::7 .word 0 ; don't need to save any registers= extzv @12(ap),@16(ap),@4(ap),@8(ap) ;isn't this neat ? ret;;0; this routine extracts bits from vax words.5; it is similar to NCAR's SBYTE but it works with2; the natural underlying structure of the VAX.;&; CALL SBIT(NPACK,ISAM,IBIT,NBITS)(; packs the value in ISAM into NPACK ; with NBITS offset by IBIT.;sbit::7 .word 0 ; don't need to save any registers= insv @8(ap),@12(ap),@16(ap),@4(ap) ;isn't this neat ? ret .endww@ a&È .title symjob;5; being a collection of symbiont request routines; $smrdef $msgdef jlun = 19buff: .blkb 100bdesc: .long 0 .address buffrdesc: .long 1 .address readndesc: .long namelen .address namenldesc: .long 0 .address namelun: .long jlunchan: .word 0result: .blkb 8 namelen = 80name: .blkb namelenread: .ascii /R/;;IFLAG: .long 0@share: $crembx_s chan=chan ; create a mailbox for response: blbc r0,error ; couldn't create mailboxA $sndsmb_s msgbuf=bdesc,chan=chan ; send symbiont request8 blbc r0,error ; couldn't send message pushal iflag4 calls #1,lib$get_ef ; get an event flag blbs r0,rloop $exit_s r0Orloop:$qiow_s efn=iflag,chan=chan,func=#io$_readvblk,p1=result,p2=#8 ; read mbx blbc r0,error; cmpw result,#msg$_smbrsp ; was this from symbiont ?9 bneq rloop ; NO. try another read.  pushal iflag calls #1,lib$free_ef= $dassgn_s chan=chan ; YES. get rid of channel.2 blbc r0,error ; check for error5 movl result+4,r0 ; put result into r0 rsb error: rsb;;.; CALL IFERR(JOB_RELEASE(queuename,jobid),!; 'UNABLE TO RELEASE JOB');2; where queuename is the name of the queue,!; and jobid is the job_id.; job_releas e:: .word ^mC moval buff,r3 ; r3 will move through the buffer B movw #smr$k_release,(r3)+ ; first stick in release request < moval @4(ap),r0 ; r0 has addr of descriptor9 movb (r0),(r3)+ ; insert queuename count; movc5 (r0),@4(r0),#^a/ /,#15,(r3) ; insert queuename7 movw @8(ap),(r3)+ ; throw in the job id.6 subl3 #buff,r3,bdesc ; set length of desc.6 jsb share ; jump to shared code ret;;-; CALL IFERR(JOB_REMOVE(queuename,jobid),!; 'UNABLE TO RELEASE JOB');2; where queuename is the name of the queue,!; and jobid is the job_id.; job_remove:: .word ^mC moval buff,r3 ; r3 will move through the buffer @ movw #smr$k_rmvjob,(r3)+ ; first stick in remove request < moval @4(ap),r0 ; r0 has addr of descriptor9 movb (r0),(r3)+ ; insert queuename count; movc5 (r0),@4(r0),#^a/ /,#15,(r3) ; insert queuename7 movw @8(ap),(r3)+ ; throw in the job id.6 subl3 #buff,r3,bdesc ; set length of desc.6 jsb share ; jump to shared code ret;;:; CALL IFERR(JOB_ENTER(queuename,filename,delete,hold,; . nofeed,jobid);D; where queuename is the name of the queue, filename is the name; of the file,@; delete, hold, and plot are logical variable s indicatingD; whether the file is to be deleted, held, or is a plot file,3; and jobid is returned with the job number.;;$job_enter:: .word ^m movl #jlun,lun 6 pushal @8(ap) ; push filename desc.1 pushal rdesc ; push 'R' desc.2 pushal lun ; push lun number0 calls #3,d_open ; open the file* blbs r0,common ; success6 jmp baderr ; unable to open file;;7; CALL IFERR(JOB_ENLUN(queuename,iolun,delete,hold,; . nofeed,jobid);I; where queuename is the name of the queue, iolun is the iolun number; of the file,@; delete, hold, and plot are logical variables indicatingD; whether the file is to be deleted, held, or is a plot file,3; and jobid is returned with the job number.?; Note that JOB_ENLUN is just like JOB_ENTER except that>; it assumes you have the file in q uestion already open;; on iolun. In many cases this is in fact the case.;;$job_enlun:: .word ^m movl @8(ap),luncommon:C moval buff,r3 ; r3 will move through the buffer @ movw #smr$k_enter,(r3)+ ; first stick in enter request < moval @4(ap),r0 ; r0 has addr of descriptor9 movb (r0),(r3)+ ; insert queuename count; movc5 (r0),@4(r0),#^a/ /,#15,(r3) ; insert queuename2 pushal (r3 ) ; push buff addr.2 pushal lun ; push lun number0 calls #2,d_fid ; get fid stuff> addl2 #28,r3 ; skip over stuff we just got< pushal nldesc ; push result length param.> pushal ndesc ; push name buffer desc addr.2 pushal lun ; push lun number5 calls #3,d_name ; get full file nameA locc #^a/]/,nldesc,name ; find end of directory string9 decl r0 ; r0 has filename length> movb r0,(r3)+ ; store filename length count9 incl r1 ; r1 is addr of filename9 movc5 r0,(r1),#^a/ /,#19,(r3) ; store filename pushal lun- calls #1,d_clos ; close unitD blbc @12(ap),nodel ; if delete flag clear don't set it" movb #smo$k_delete,(r3)+Bnodel: blbc @16(ap),nohold ; if hold flag clear don't set it movb #smo$k_ho ld,(r3)+Dnohold: blbc @20(ap),nofeed ; if nofeed flag clear don't set it" movb #smo$k_nofeed,(r3)+9nofeed: subl3 #buff,r3,bdesc ; set length of desc.6 jsb share ; jump to shared code4 movzwl result+2,@24(ap) ; return job number retbaderr: ret .endww