🚀 go-pugleaf

Submitted-by: ewilts@galaxy.gov.bc.ca (Ed Wilts)
Posting-number: Volume 3, Issue 151
Archive-name: time_functions/part01

-+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+
X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. GREATER_THAN .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(GT)' ) THEN
XC
XC`09   Compare for greater than.
XC
X`09`09STATUS = LIB$SUBX( BIN_2, BIN_1, BIN_SCR, 2 )
X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. GREATER_THAN_EQUAL_TO .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(GE)' ) THEN
XC
XC`09   Compare for greater than or equal to.
XC
X`09`09STATUS = LIB$SUBX( BIN_2, BIN_1, BIN_SCR, 2 )
X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSE
XC
XC`09   Invalid operator.
XC
X`09`09CALL LIB$STOP(TIME__INVOPR)
X`09ENDIF
X      ENDDO`09
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   See if there are any additional parameters on the line.
XC
X1999`09CONTINUE
X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP3_1, OP3_2 )
X`09IF ( STATUS ) THEN
X`09`09CALL LIB$STOP(TIME__TOOMNYOPR)
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Store the symbol in the symbol table, or output it to SYS$OUTPUT dependi
Vng
XC`09on whether a symbol was defined.
XC
X`09STATUS = STR$TRIM`20
X`091`09( RESULT, RESULT, RESULT_S )
X`09IF ( SYMBOL_S .NE. 0 ) THEN
X`09`09STATUS = LIB$SET_SYMBOL
X`091`09`09( SYMBOL(1:SYMBOL_S), RESULT(1:RESULT_S) )
X`09ELSE
X`09`09STATUS = LIB$PUT_OUTPUT ( RESULT(1:RESULT_S) )
X`09END IF`09
XC
XC   Exit.
XC
X`09CALL EXIT(status)
X`09END
$ CALL UNPACK TIME.FOR;1 2118724995
$ create 'f'
X! 23-Mar-83  FJN  Added keywords subtopic
X! 02-Apr-83  FJN  Added LASTMONTH and LASTWEEK keywords
X1 TIME
X The function of this command is to perform time calculation services.
X Format:
X
X         TIME `5B time-spec `5B (operator) time-spec`5D ... `5D
X
X By default if no operands are specified the command will display the
X current system time and the user's connect time.
X
X If only one operand is supplied, then instead of calculating the user's
X connect time the operand (which must be in absolute time format) will be`20
X subtracted from the current system time and that resulting delta time
X displayed along with the current system time.
X
X `5B`5D indicates optional.  () are required for the operator.
X '...' only valid for (+),(-),(*), & (/) operators
X
X The TIME symbol is defined by:
X
X`09TIME :== $ECSEXE:TIME
X
X2 Time-spec
X The times values which may be specified are absolute time,`20
X delta time, keyword for an absolute time or a positive
X integer value.
X
X3 Absolute_time
X Formats:
X
X    dd-mmm-yyyy`5B:`5D`5Bhh:mm:ss.ss`5D
X
X 1. If you specify both the date (dd-mmm-yyyy) and the time
X    (hh:mm:ss.ss), you may type the colon between the date and
X    the time or seperate them with a tab or a blank. `20
X
X    The lexical function 'F$TIME()' may be used to generate`20
X    the current time value (this returns the value with a blank
X    between the date and time fields). `20
X
X    On output there will always be a colon between the date and`20
X    the time of day fields.
X
X 2. If only the date is specified the system will supply the
X    current time of day for the missing time field.
X
X 3. If you specify a time of day you can truncate the time on`20
X    the right.  The truncated fields will be zero filled (See
X    point 4 if you wish to supply punctuation).
X
X 4. If you omit any of the fields but supply the punctuation marks
X    the system will supply the current system time values as`20
X    defaults (do not confuse this with truncation where the
X    punctuation marks are also omited; point 3).
X
X3 Delta_time
X Format
X
X    dd`5B-`5Dhh`5B:mm:ss.ss`5D
X
X When you specify a delta time value, you can truncate the time field
X on the right; you may also omit any of the variable fields, as long
X as you supply the punctuation marks.
X
X When any field is omitted from a delta time value, the system
X supplies a value of 0 for the field.
X
X3 Integer
X An positive integer value may also be specified.  The value must
X be within the range:
X`20
X    0 - 2147483647
X
X3 Keywords
X The following keywords represent certain absolute dates (the times
X are always 00:00:00.00):
X
X    YESTERDAY    yesterday's start.
X    TODAY        start of the current day.
X    TOMORROW     start of tomorrow.
X
X    THISMONTH    First day of the current month.
X    NEXTMONTH    First day of the next month.
X    LASTMONTH    First day of the previous month.
X
X    THISYEAR     January 1 of the current year.
X
X    THISWEEK     Monday of the current week (possibly today).
X    NEXTWEEK     Next Monday (first day of the next week).
X    LASTWEEK     Monday of the previous (full 7-day) week.
X
X2 Operator
X The operators available are addition, subtraction, multiplication,
X division, and comparison.
X The syntax for the operators are:
X
X     (+)    Addition
X     (-)    Subtraction
X     (*)    Multiplication
X     (/)    Division
X     (=)    Compare for equal to
X     (<>)   Compare for not equal to
X     (<)    Compare for less than
X     (<=)   Compare for less than or equal to
X     (>)    Compare for greater than
X     (>=)   Compare for greater than or equal to
X     (?)    General comparison
X
X The operator MUST be enclosed in parenthesis's.  This is to avoid`20
X syntax confusion with the '-' used in the time specifications.
X
X Note:  If any of the results yealds a negative time value the
X        absolute value of the calculation is displayed.
X
X3 Addition (+)
X This operator will add the two operands and return the result.
X Valid combinations and the type of result returned are shown
X below:
X
X     TIME   absolute_time (+) delta_time     -->  absolute_time
X     TIME   delta_time (+) absolute_time     -->  absolute_time
X     TIME   delta_time (+) delta_time        -->  delta_time
X     TIME   integer (+) integer              -->  integer
X
X3 Subtraction (-)
X This operator will subtract the two operands and return the
X result.  Valid combinations and the type of result returned
X are shown below:
X
X     TIME   absolute_time (-) absolute_time  -->  delta_time
X     TIME   absolute_time (-) delta_time     -->  absolute_time
X     TIME   delta_time (-) delta_time        -->  delta_time
X     TIME   integer (-) integer              -->  integer
X
X Note:  If any of the results yealds a negative value the
X        absolute value of the calculation is returned.
X
X3 Multiplication (*)
X This operator will multiply the two operands and return the
X result.  Valid combinations and the type of result returnd
X are shown below:
X
X     TIME   delta_time (*) integer           -->  delta_time
X     TIME   integer (*) delta_time           -->  delta_time
X     TIME   integer (*) integer              -->  integer
X
X3 Division (/)
X This operator will divide the two operands and return the
X result.  Valid combinations and the type of result returned
X are shown below:
X
X     TIME   delta_time (/) delta_time        -->  integer
X     TIME   delta_time (/) integer           -->  delta_time
X     TIME   integer (/) integer              -->  integer
X
X3 Comparison (?)
X This operator will compare the two operands and return the
X results of the comparison.
X
X     TIME   absolute_time       (?)      absolute_time
X
X                            GREATER_THAN
X                              EQUAL_TO
X                              LESS_THAN
X
X     TIME   delta_time       (?)      delta_time
X
X                         GREATER_THAN
X                           EQUAL_TO
X                           LESS_THAN
X
X3 EQ (=)
X This operator wil compare the two operands and return YES
X if they are equal and NO if they are not.
X
X     TIME   absolute_time  (=)   absolute_time
X     TIME   absolute_time  (EQ)   absolute_time
X
X     TIME   delta_time     (=)   delta_time
X     TIME   delta_time     (EQ)   delta_time
X
X3 NE (<>)
X This operator will compare the two operands and return YES
X if they are not equal and NO if they are equal.
X
X     TIME   absolute_time  (<>)   absolute_time
X     TIME   absolute_time  (NE)   absolute_time
X
X     TIME   delta_time     (<>)   delta_time
X     TIME   delta_time     (NE)   delta_time
X
X3 LT (<)
X This operator will compare the two operands and return YES
X if the first operand is less than the second operand,
X otherwise it will return NO.
X
X     TIME   absolute_time  (<)   absolute_time
X     TIME   absolute_time  (LT)   absolute_time
X
X     TIME   delta_time     (<)   delta_time
X     TIME   delta_time     (LT)   delta_time
X
X3 LE (<=)
X This operator will compare the two operands and return YES
X if the first operand is less than or equal to the second`20
X operand, otherwise it will return NO.
X
X     TIME   absolute_time  (<=)   absolute_time
X     TIME   absolute_time  (LE)   absolute_time
X
X     TIME   delta_time     (<=)   delta_time
X     TIME   delta_time     (LE)   delta_time
X
X3 GT (>)
X This operator will compare the two operands and return YES
X if the first operand is greater than the second operand,
X otherwise it will return NO.
X
X     TIME   absolute_time  (>)   absolute_time
X     TIME   absolute_time  (GT)   absolute_time
X
X     TIME   delta_time     (>)   delta_time
X     TIME   delta_time     (GT)   delta_time
X
X3 GE (>=)
X This operator will compare the two operands and return YES
X if the first operand is greater than or equal to the second
X operand, otherwise it will return NO.
X
X     TIME   absolute_time  (>=)   absolute_time
X     TIME   absolute_time  (GE)   absolute_time
X
X     TIME   delta_time     (>=)   delta_time
X     TIME   delta_time     (GE)   delta_time
X
X2 Qualifiers
X
X/DEBUG
X This option will show the intermediate results of a sequence of`20
X operations.  It also disables some internal error checking so`20
X the output may not be correct.
X
X/SYMBOL=symbol_name
X This option will cause the results of the calculation to be stored in
X the specified symbol instead of being displayed to the output device.
$ CALL UNPACK TIME.HLP;2 73615922
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   TIMECNV.FOR - The function of this routine is to convert the absolute
XC`09time, delta time, or interger value character string passed into`20
XC`09a positive 64 bit binary value.  If the format is incorrect then the
XC`09status returned is even.
XC
XC`09Note:  The delta times will be converted to positive values.
XC
XC   Calling Procedure:
XC
XC`09status = TIMECNV( string, binary_value )
XC
XC   Entry Conditions:
XC
XC`09string - must contain the absolute time, the delta time or an integer
XC`09`09 character string (integer = 0 through 2147483647) or a
XC`09`09 recognized keyword name.
XC
XC   Exit Conditions:
XC
XC`09status = 3 if string is absolute time format.
XC`09       = 4 if invalid absolute time format.
XC`09       = 5 if string is delta time format.
XC`09       = 6 if invalid delta time format.
XC`09       = 7 if integer value.
XC`09       = 8 if invalid integer value.
XC
XC`09binary_value - contains the binary value of the value converted.
XC`09`09Both absolute times and delta times will be positive.
XC`09`09This variable must be 2 longword long.
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09INTEGER*4 FUNCTION TIMECNV( STRING, BIN_VAL )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09EXTERNAL`09OTS$_INPCONERR
XC
X`09PARAMETER`09DASH='-'
X`09PARAMETER`09COLON=':'
X`09PARAMETER`09BLANK=' '
X`09PARAMETER`09PERIOD='.'
XC
X`09CHARACTER*(*)`09STRING
X`09CHARACTER`09WORK*(32)
XC
X`09INTEGER*4`09TIMEKEY
XC
X`09INTEGER*4`09BIN_VAL(2)
X`09INTEGER*4`09ZERO(2) /0,0/
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Initialize the return code to integer value.
XC
X`09TIMECNV = 7
XC
XC   Determine if it is absolute, delta, or integer format.
XC`092 dashes is absolute.
XC`091 dash or (no dash and a colon) or (no dash and a period) is delta.
XC`09no dash and no colon and no period is and integer.
XC
X`09I = INDEX( STRING, DASH )
X`09IF ( I .NE. 0 ) THEN`09
X`09`09TIMECNV = 5
X`09`09J = INDEX( STRING(I+1:), DASH )
X`09`09IF ( J .NE. 0 ) THEN
X`09`09`09TIMECNV = 3
X`09`09ENDIF
X`09ENDIF
XC`20
X`09IF ( TIMECNV .EQ. 7 ) THEN
X`09`09IF ( (INDEX( STRING, COLON ) +`20
X`091`09      INDEX( STRING, PERIOD )) .NE. 0 ) TIMECNV = 5
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Convert the time based on the type of time it is.
XC
X`09IF ( TIMECNV .EQ. 3 ) THEN
XC
XC`09   Absolute time; remove the colon from between the year and hour
XC `09`09if present.
XC
X`09`09B1 = INDEX( STRING, BLANK )
X`09`09IF ( B1 .EQ. 0 ) THEN
X`09`09`09B1 = INDEX( STRING, COLON )
X`09`09`09IF ( B1 .NE. 0 ) THEN
X`09`09`09`09STRING(B1:B1) = BLANK
X`09`09`09ENDIF
X`09`09ENDIF
XC
XC`09   If trailing fields of the time of day are missing supply 0's.
XC
X`09`09WORK = STRING
X`09`09IF ( B1 .NE. 0 ) THEN`09`09! no time; allow full subs.
X`09`09    L = LEN( STRING ) + 1
X`09`09    C1 = INDEX( WORK, COLON )
X`09`09    IF ( C1 .EQ. 0 ) THEN
X`09`09`09WORK(L:) = ':0:0.0'
X`09`09    ELSEIF ( INDEX( WORK(C1+1:), COLON ) .EQ. 0 ) THEN
X`09`09`09WORK(L:) = ':0.0'
X`09`09    ELSEIF ( INDEX( WORK, PERIOD ) .EQ. 0 ) THEN
X`09`09`09WORK(L:) = '.0'
X`09`09    ENDIF
X`09`09ENDIF
XC
XC`09   Convert to absolute binary time.
XC
X`09`09STATUS = SYS$BINTIM( WORK, BIN_VAL )
X`09`09IF ( .NOT. STATUS ) THEN
XC
XC`09`09    Specify return status of invalid absolute time format.
XC
X`09`09`09TIMECNV = 4
X`09`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( TIMECNV .EQ. 5 ) THEN
XC
XC`09   Delta time; remove the dash from between the days and the hour.
XC
X`09`09I = INDEX( STRING, DASH )
X`09`09IF ( I .NE. 0 ) THEN
X`09`09`09STRING(I:I) = BLANK
X`09`09ENDIF
XC
XC`09   Convert to delta binary time.
XC
X`09`09STATUS = SYS$BINTIM( STRING, BIN_VAL )
X`09`09IF ( .NOT. STATUS ) THEN
XC
XC`09`09    Specify return status of invalid delta time format.
XC
X`09`09`09TIMECNV = 6
X`09`09ENDIF
X`09`09STATUS = LIB$SUBX( ZERO, BIN_VAL, BIN_VAL, 2 )
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( TIMEKEY(string, bin_val)) THEN
XC
XC Keyword was found, treat as an absolute time
XC
X`09`09timecnv = 3
X`09ELSE
XC
XC`09   Convert the integer value to binary.
XC
X`09`09STATUS = OTS$CVT_TI_L( STRING, BIN_VAL(1), %VAL(4), %VAL(3) )
X`09`09IF ( STATUS .EQ. %LOC(OTS$_INPCONERR) .OR.
X`091`09      BIN_VAL(1) .LT. 0 ) THEN
XC
XC`09`09   Specify return status of invalid integer value format.
XC
X`09`09`09TIMECNV = 8
X`09`09ENDIF
X`09`09BIN_VAL(2) = 0
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Return
XC
X`09RETURN
X`09END
$ CALL UNPACK TIMECNV.FOR;1 2017346050
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   TIMECUR.FOR - The function of this routine is to determine the current
XC`09system time and the processes current connect time.  The values are
XC`09converted to string data and returned as the function value of the
XC`09routine.
XC
XC   Calling Procedure:
XC
XC`09return_string = TIMECUR ( login_time )
XC
XC   Entry Conditions:
XC
XC`09login_time - This must be the time to subtract from the current system
XC`09`09time in order to get the delta time.  If zero is passed than
XC`09`09the process login time is used instead.
XC
XC   Exit Conditions:
XC
XC`09A character string with the current time and the current connect time
XC`09will be returned as the value of the function.
XC
XC`09The format of returned string is:
XC
XC`09`09TIMECUR = 'dd-mmm-yyyy:hh:mm:ss.hh<tab>dddd-hh:mm:ss.hh'
XC
XC`09Leading blanks will be included.
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09CHARACTER*40 FUNCTION TIMECUR ( LOGINTIM )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09PARAMETER`09ABSZ=23
X`09PARAMETER`09DELTAZ=16
X`09PARAMETER`09DASH='-'
X`09PARAMETER`09EQUAL=':='
X`09PARAMETER`09COLON=':'
X`09PARAMETER`09TAB='`09'
XC
X`09CHARACTER`09ABS_C*(ABSZ)
X`09CHARACTER`09JPI_LOGINTIM*(ABSZ)
X`09CHARACTER`09DELTA_C*(DELTAZ)
XC
X`09INTEGER*4`09ABS(2), ABS_S
X`09INTEGER*4`09LOGINTIM(2), LOGINTIM_S
X`09INTEGER*4`09DELTA(2), DELTA_S
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Fetch the processes login time.
XC
X`09IF ( LOGINTIM(1) .EQ. 0 ) THEN
X`09`09TIMECUR = JPI_LOGINTIM ( LOGINTIM, LOGINTIM_S )
X`09ENDIF
XC
XC   Fetch the current character system time.
XC
X`09CALL SYS$ASCTIM ( ABS_S, ABS_C, , %VAL(0) )
XC
XC   Convert the current system time to binary system time
XC
X`09CALL SYS$BINTIM ( ABS_C, ABS )
XC
XC   Subtract the login time from the current system time to get connect time
V.
XC`09Note: that the acutal calculation is done to yeald negative result
XC`09      because delta times are negative values.
XC
X`09CALL LIB$SUBX ( LOGINTIM, ABS, DELTA, 2 )
XC
XC   Convert the binary connect time to character.
XC
X`09CALL SYS$ASCTIM ( DELTA_S, DELTA_C, DELTA, %VAL(0) )
XC
XC   Insert the colon between year & hour, and insert the dash between`20
XC`09day & hour.
XC
X`09ABS_C(12:12) = COLON
X`09DELTA_C(5:5) = DASH
XC
XC   Format the retrun string.
XC
X`09TIMECUR = ABS_C // TAB // DELTA_C
XC
XC   Return.
XC
X`09RETURN
X`09END
$ CALL UNPACK TIMECUR.FOR;1 577170431
$ create 'f'
X`09.TITLE`09TIMEEDIV - Time division routine.
X`09.IDENT`09/01/
X;++
X;   TIMEEDIV.MAR - The function of this routine is to divide a quadword
X;`09by a quadword and return a quadword result and a quadword remainder.
X;
X;
X;   Calling Procedure:
X;
X;`09status = TIMEEDIV( divisor, dividend, result, remainder ) ! FORTRAN
X;
X;   Entry Conditions:
X;
X;`094(AP) - must contain the address of the quadword dividend.
X;`098(AP) - must contain the address of the quadword divisor.
X;
X;   Exit Conditions:
X;
X;`0912(AP) - must contain the address of the quadword to receive the
X;`09`09result.
X;`0916(AP) - must contain the address of the quadword to receive the
X;`09`09remainder.
X;
X;`09R0 - will contain 1 on exit.
X;`09     if divide by 0 then = 0
X;---------------------------------------------------------------------------
V---
X;
X;   Psect for quadword divide.
X;
X`09.PSECT`09TIMEEDIV
X;
XDIVR`09=`094
XDIVD`09=`098
XRESULT`09=`0912
XREMAINDER =`0916
XLOW`09=`090
XHIGH`09=`094
X;
X;   Entry point - TIMEEDIV
X;
X`09.ENTRY`09TIMEEDIV,`5EM<R2,R3,R4,R5,R6,R7,R8,R9>
X;
X;   Fetch the divisor and the dividend.
X;
X`09MOVQ`09@DIVR(AP),R2`09`09; Fetch value of divisor.
X`09MOVQ`09@DIVD(AP),R4`09`09; Fetch value of dividend.
X`09CLRQ`09R6`09`09`09; Clear MS Qw of dividend work area.
X;
X;   Check for divide by zero.
X;
X`09ADDL3`09R2,R3,R0`09`09; If divisor .EQ. 0,
X`09BEQL`09DIVIDE_BY_ZERO`09`09;   then return dividend as result and
X`09`09`09`09`09;   0 for remainder.
X;
X;   Determine the sign of the result and save the value.
X;
X`09XORL3`09R3,R5,R9`09`09; Exclusive OR sign bits of divisor
X`09`09`09`09`09;   and dividend to determine sign
X`09`09`09`09`09;   of result.
X;
X;   Form absolute values of each operand.
X;
X`09TSTL`09R3`09`09`09; Is divisor < 0 ??
X`09BGEQ`0910$`09`09`09;   No
X`09MOVQ`09R2,R0`09`09`09;   Yes; Place divisor in scratch area
X`09CLRQ`09R2`09`09`09;`09 Zero difference area
X`09SUBL`09R0,R2`09`09`09;`09 0 - divisor(low)
X`09SBWC`09R1,R3`09`09`09;`09 0 - divisor(high) - carry
X10$:
X`09TSTL`09R5`09`09`09; Is dividend < 0 ??
X`09BGEQ`0920$`09`09`09;   No
X`09MOVQ`09R4,R0`09`09`09;   Yes; Place dividend in work area
X`09CLRQ`09R4`09`09`09;`09 Zero difference area
X`09SUBL`09R0,R4`09`09`09;`09 0 - dividend(low)
X`09SBWC`09R1,R5`09`09`09;`09 0 - dividend(high) - carry
X20$:
X;;;;
X;
X;
X;   Shift 128 bit dividend work area 1 bit left.
X;;;;
X`09CLRL`09R8`09`09`09; Clear the loop counter.
XLOOP:
X`09ASHQ`09#1,R6,R6`09`09; Shift dividend MS left 1 bit.
X`09BITL`09#`5Ex80000000,R5`09`09; If dividend LS hi bit = 1,
X`09BEQL`0930$`09`09`09;   then
X`09BISL`09#1,R6`09`09`09;     Set MS low bit = 1.
X30$:`09`09`09`09`09; Endif
X`09ASHQ`09#1,R4,R4`09`09; Shift dividend LS left 1 bit.
X;
X;   Trial subtract the divisor from the dividend work area (most significent
V)
X;
X`09MOVQ`09R6,R0`09`09`09; Move the MS dividend work area to tmp
X`09SUBL`09R2,R0`09`09`09; Subtract divisor(low).
X`09SBWC`09R3,R1`09`09`09; Subtract divisor(high) w/carry.
X`09BLSS`0950$`09`09`09; If result is positive, then
X`09MOVQ`09R0,R6`09`09`09;   Place result in dividend MS
X`09BISL`09#1,R4`09`09`09;   Set dividend LS low bit = 1.
X50$:`09`09`09`09`09; Endif
X;
X;   Process the loop control data and repeat loop if not done
X;
X`09AOBLSS`09#64,R8,LOOP
X;;;;
X;   Set the signs of the result and remainder based on the divisor and divid
Vend
X;;;;
X`09TSTL`09@DIVD(AP)`09`09; If dividend < 0,
X`09BGEQ`0970$`09`09`09;   then
X`09MOVQ`09R6,R0`09`09`09;     Place remainder in scratch area
X`09CLRQ`09R6`09`09`09;     Zero remainder storage area.
X`09SUBL`09R0,R6`09`09`09;     0 - remainder(low)
X`09SBWC`09R1,R7`09`09`09;     0 - remainder(high) - carry
X70$:`09`09`09`09`09; Endif
X;
X;   Register 9 has sign to set result to.
X;
X`09TSTL`09R9`09`09`09; If saved sign < 0,
X`09BGEQ`0980$`09`09`09;   then
X`09MOVQ`09R4,R0`09`09`09;     Place result in scratch area.
X`09CLRQ`09R4`09`09`09;     Zero result storage area.
X`09SUBL`09R0,R4`09`09`09;     0 - result(low)
X`09SBWC`09R1,R5`09`09`09;     0 - result(high) - carry
X80$:`09`09`09`09`09; Endif
X;;;;
X;   Store the result and remainder values.
X;;;;
X`09MOVL`09#1,R0`09`09`09; Set the return status.
XDIVIDE_BY_ZERO:
X`09MOVQ`09R4,@RESULT(AP)`09`09; Store the result.
X`09MOVQ`09R6,@REMAINDER(AP)`09; Store the remainder.
X;
X;   Return`20
X;
XEXIT:
X`09RET
X;
X`09.END
$ CALL UNPACK TIMEEDIV.MAR;1 1564323094
$ create 'f'
X`09.TITLE`09TIMEEMUL Extended multiply routine
X`09.IDENT`09/01/
X;++
X;   TIMEEMUL.MAR - The function of this routine is to multiply a quadword`20
X;`09by a quadword and return a quadword result.
X;
X;   Calling Procedure:
X;
X;`09status = TIMEEMUL( multiplier, multiplican, result )`09! FORTRAN
X;
X;   Entry Conditions:
X;
X;`094(AP) - must contain the address of the quadword multiplier.
X;`098(AP) - must contain the address of the quadword multiplican.
X;
X;   Exit Conditions:
X;
X;`0912(AP) - must contain the address of the quadword to receive the
X;`09`09quadword result.
X;
X;`09R0 - will contain 1 on exit.
X;`09     if overflow R0 = 0.
X;---------------------------------------------------------------------------
V---
X;
X;   Psect for quadword multiply.
X;
X`09.PSECT`09TIMEEMUL
X;
XMULC `09=`094
XMULR`09=`098
XRESULT`09=`0912
XLOW`09=`090
XHIGH`09=`094
X;
X;   Entry point - TIMEEMUL
X;
X`09.ENTRY`09TIMEEMUL,`5EM<R2,R3,R4,R5,R6,R7,R8,R9>
X;
X;   Fetch the multiplier and multiplicand.
X;
X`09MOVQ`09@MULR(AP),R2`09`09; Fetch value of multiplier.
X`09MOVQ`09@MULC(AP),R4`09`09; Fetch value of multiplicand.
X`09CLRQ`09R6`09`09`09; Clear LS part of multiplicand area.
X;
X;   Determine the sign of the result and save the value.
X;
X`09XORL3`09R3,R5,R9`09`09; Exclusive OR sign bits of multiplier
X`09`09`09`09`09;   and multiplicand to determine sign
X`09`09`09`09`09;   of result.
X;
X;   Form absolute values of each operand.
X;
X`09TSTL`09R3`09`09`09; Is multiplier < 0 ??
X`09BGEQ`0910$`09`09`09;   No
X`09MOVQ`09R2,R0`09`09`09;   Yes; Place multiplier in scr area
X`09CLRQ`09R2`09`09`09;`09 Zero difference area
X`09SUBL`09R0,R2`09`09`09;`09 0 - multiplier(low)
X`09SBWC`09R1,R3`09`09`09;`09 0 - multiplier(high) - carry
X10$:
X`09TSTL`09R5`09`09`09; Is multiplicand < 0 ??
X`09BGEQ`0920$`09`09`09;   No
X`09MOVQ`09R4,R0`09`09`09;   Yes; Place multiplicand in work area
X`09CLRQ`09R4`09`09`09;`09 Zero difference area
X`09SUBL`09R0,R4`09`09`09;`09 0 - multiplicand(low)
X`09SBWC`09R1,R5`09`09`09;`09 0 - multiplicand(high) - carry
X20$:
X;;;;
X;
X;
X;   Add multiplier and multiplicand then shift multiplicand.
X;;;;
X`09CLRL`09R8`09`09`09; Clear the loop counter.
XLOOP:
X`09BITL`09#1,R4`09`09`09; If multiplicand LS low bit set,
X`09BEQL`0925$`09`09`09;   then
X`09ADDL`09R2,R6`09`09`09;     Add MS multiplicand(low) to`20
X`09`09`09`09`09;       multiplier(low).
X`09ADWC`09R3,R7`09`09`09;     Add MS multiplicand(high) to
X`09`09`09`09`09;       multiplier(high) with carry.
X25$:`09`09`09`09`09; Endif
X;
X;   Shift 128 bit multiplicand work area 1 bit right.
X;
X`09ASHQ`09#<-1>,R4,R4`09`09; Shift LS right 1 bit.
X`09BICL`09#`5Ex80000000,R5`09`09; Clear LS hi bit.
X`09BITL`09#1,R6`09`09`09; If MS low bit = 1,
X`09BEQL`0930$`09`09`09;   then
X`09BISL`09#`5Ex80000000,R5`09`09;     Set LS high bit = 1.
X30$:`09`09`09`09`09; Endif
X`09ASHQ`09#<-1>,R6,R6`09`09; Shift MS right 1 bit.
X`09BICL`09#`5Ex80000000,R7`09`09; Clear MS hi bit.
X;
X;   Process the loop control data and repeat loop if not done
X;
X`09AOBLSS`09#64,R8,LOOP
XEND_LOOP:
X;;;;
X;   Set the signs of the result based on the multiplier and multiplicand.
X;   `09Register 9 has sign to set result to.
X;;;;
X`09TSTL`09R9`09`09`09; If saved sign < 0,
X`09BGEQ`0980$`09`09`09;   then
X`09MOVQ`09R4,R0`09`09`09;     Place result in scratch area.
X`09CLRQ`09R4`09`09`09;     Zero result storage area.
X`09SUBL`09R0,R4`09`09`09;     0 - result(low)
X`09SBWC`09R1,R5`09`09`09;     0 - result(high) - carry
X80$:`09`09`09`09`09; Endif
X;;;;
X;   Check for overflow.
X;;;;
X`09MOVL`09#1,R0`09`09`09; Set the return status = 1
X`09ADDL3`09R6,R7,R1`09`09; If multiplicand MS .ne. 0
X`09BEQL`0990$`09`09`09;   then
X`09MOVL`09#0,R0`09`09`09;     set return status = 0
X90$:`09`09`09`09`09; Endif
X;;;;
X;   Store the result value.
X;;;;
X`09MOVQ`09R4,@RESULT(AP)`09`09; Store the result.
X;
X;   Return`20
X;
XEXIT:
X`09RET
X;
X`09.END
$ CALL UNPACK TIMEEMUL.MAR;1 844888009
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   TIMEGET - The function of this routine is to find the next character
XC`09string from the time calculation line and return pointers to the First`2
V0
XC`09and Last characters of the string.
XC
XC`09The delimiters are:
XC
XC`09`09end of string
XC`09`09'('
XC`09`09')'
XC
XC`09Beginning and trailing blanks will not be returned.
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09INTEGER*4 FUNCTION TIMEGET ( STRING, S1, S2 )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09EXTERNAL`09SS$_NORMAL
XC
X`09PARAMETER`09OPEN_P='('
X`09PARAMETER`09CLOSE_P=')'
X`09PARAMETER`09BLANK=' '
XC
X`09CHARACTER`09STRING*(*)
XC
X`09INTEGER*4`09S1, S2, TMP
X`09INTEGER*4`09STRING_S
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Initialize the return code.
XC
X`09TIMEGET = %LOC(SS$_NORMAL)
XC
XC   Find the beginning of the string.
XC
X`09STRING_S = LEN( STRING )
XC
X`09S1 = S2 + 1
X`09TMP = LIB$SKPC ( BLANK, STRING(S1:STRING_S) ) + (S1-1)
X`09IF ( TMP .EQ. (S1-1) ) THEN
X`09`09TIMEGET = 0
X`09`09GOTO 999
X`09END IF
X`09S1 = TMP
XC
XC   Find the end of the string.
XC
X`09TMP = INDEX( STRING(S1:STRING_S), OPEN_P ) + (S1-1)
X`09IF ( TMP .NE. (S1-1) .AND. TMP .NE. S1 ) THEN
X`09`09S2 = TMP - 1
X`09ELSE
X`09`09TMP = INDEX( STRING(S1:STRING_S), CLOSE_P ) + (S1-1)
X`09`09IF ( TMP .NE. (S1-1) ) THEN
X`09`09`09S2 = TMP
X`09`09ELSE
X`09`09`09S2 = STRING_S
X`09`09ENDIF
X`09ENDIF
XC
XC   Remove trailing blanks from the string.
XC
X`09STATUS = STR$TRIM( STRING(S1:S2), STRING(S1:S2), TMP )
X`09S2 = TMP + (S1-1)
XC
XC   Return
XC
X999`09CONTINUE
X`09RETURN
X`09END
$ CALL UNPACK TIMEGET.FOR;1 578512302
$ create 'f'
XC Last Modified:  14-MAY-1990 20:28:31.66, By: RLB`20
X
X`09INTEGER*4 FUNCTION TIMEKEY( string,bin_val )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
X`09CHARACTER*(*) string
X`09INTEGER*4 bin_val(2)
XC
XC+/TIMEKEY
XC
XC Functional Description:
XC`09Check for absolute time specified by a keyword.  The recognized
XC`09keywords and their meanings are:
XC
XC`09`09YESTERDAY`0900:00 AM of the previous day
XC`09`09TODAY`09`0900:00 AM of the current day
XC`09`09TOMORROW`09midnight of the current day (00:00 AM tomorrow)
XC`09`09THISMONTH`09first day of the current month (00:00 AM)
XC`09`09NEXTMONTH`09first day of the next month (00:00 AM)
XC`09`09LASTMONTH`09first day of the previous month (00:00 AM)
XC`09`09THISYEAR`09January 1st of the current year (00:00 AM)
Xc`09        LASTYEAR`09January 1st of the next year (00:00 AM)
Xc`09        NEXTYEAR`09January 1st of the next year (00:00 AM)
XC`09`09THISWEEK`090000 AM on the last Monday (start of this week)
XC`09`09NEXTWEEK`090000 AM on the next Monday (next week start)
XC`09`09LASTWEEK`090000 AM on the last Monday of a full week
Xc`09`09
XC
XC Input Parameters:
XC`09string - character string compared against the literal keywords.
XC`09`09 Abbreviations are not check for.
XC
XC Implicit Inputs:
XC`09NONE
XC
XC Output Parameters:
XC`09TIMEKEY - returns 1 if keyword match found, else 0.
XC`09bin_val - quadword in which the absolute time is returned.
XC
XC Implicit Outputs:
XC`09NONE
XC
XC Condition Codes Signalled:
XC`09NONE
XC
XC Side Effects:
XC`09NONE
XC
XC-
X`09CHARACTER*24 work
X`09INTEGER*2 work_s
X`09INTEGER*2 tincr(2)
X`09INTEGER*4 days, bin_tmp(2)
X`09INTEGER*4 secs_per_day, ticks_per_sec
X`09PARAMETER (secs_per_day = 24*60*60, ticks_per_sec = 10*1000*1000)
X`09parameter one_day = '1 0:0:0.0'
X`09parameter midnight = '00:00:00.00'
XC
X`09TIMEKEY = 1
X
X`09call sys$bintim(one_day,bin_tmp)
X`09IF (string .EQ. 'YESTERDAY') THEN
XC                                           `20
XC YESTERDAY seen, return absolute time of 00:00 AM yesterday.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val)`09!Minus 1 day
X
X`09    ELSE IF (string .EQ. 'TODAY') THEN
XC
XC TODAY seen, return absolute time of 00:00 AM on this day
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'TOMORROW') THEN
XC
XC TOMORROW seen, return absolute time of 00:00 AM tomorrow morning.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)`09!plus 1 day
X
X`09    ELSE IF (string .EQ. 'THISMONTH') THEN
XC
XC THISMONTH seen, return absolute time of 00:00 AM on the 1st of the month.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:2) = ' 1'`09`09`09!First day of month
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'THISYEAR') THEN
XC
XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:6) = ' 1-JAN'`09`09!First day of year
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'LASTYEAR') THEN
XC
XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:6) = ' 1-JAN'`09`09!1st day of year
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X`09    call lib$sub_times(bin_val, bin_tmp, bin_val) ! subtract 1 day`20
X`09    call sys$asctim(work_s, work, bin_val, )
X`09    work(1:6) = ' 1-JAN'
X`09    call sys$bintim(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'NEXTYEAR') THEN
XC
XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
XC
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:6) = '31-DEC'`09`09!last  day of year
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X`09    call lib$add_times(bin_val, bin_tmp, bin_val) ! add 1 day`20
X
X`09    ELSE IF (string .EQ. 'NEXTMONTH') THEN
XC
XC NEXTMONTH seen, return absolute time of 00:00 AM on the 1st of next month.
XC
Xc  get the 1st of this month first
Xc  then compute first of next month
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:2) = ' 1'`09`09`09!First day of month
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
Xc`09    CALL SYS$GETTIM(bin_val)
X`09    call lib$mult_delta_time(32,bin_tmp)
X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)
X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
X`09    work(13:23) = midnight`09`09!To get 00 AM of +32 days
X`09    work(1:2) = ' 1'`09`09`09!First day of next month
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'LASTMONTH') THEN
XC
XC LASTMONTH seen, return absolute time of 00:00 AM on the 1st of last month.
XC
Xc  get the 1st of this month first
Xc  then compute first of last month
Xc
X`09    CALL SYS$ASCTIM(work_s, work,, )
X`09    work(13:23) = midnight`09`09!To get 00 AM today
X`09    work(1:2) = ' 1'`09`09`09!First day of month
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
Xc`09    CALL SYS$GETTIM(bin_val)`09`09! Now produce
X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val) !Minus 1 day
X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
X`09    work(13:23) = midnight`09`09!To get 00 AM of`20
X`09    work(1:2) = ' 1'`09`09`09!First day of past month
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'THISWEEK') THEN
XC
XC THISWEEK seen, return absolute time of 00:00 AM on the latest Monday
XC
X`09    CALL SYS$GETTIM(bin_val)
X`09    CALL LIB$DAY_OF_WEEK( bin_val, days )
X`09    days = days-1
X`09    if( days.gt.0 ) then
X`09      call lib$mult_delta_time(days,bin_tmp)
X`09      CALL lib$sub_times(bin_val, bin_tmp, bin_val)
X`09    endif
X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'NEXTWEEK') THEN
XC
XC NEXTWEEK seen, return absolute time of 00:00 AM on the next Monday
XC
X`09    CALL SYS$GETTIM(bin_val)
X`09    CALL LIB$DAY(days, bin_val)
X`09    days = 7 - MOD( MOD(days, 7) + 2, 7)
X`09    call lib$mult_delta_time(days,bin_tmp)
X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)
X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X
X`09    ELSE IF (string .EQ. 'LASTWEEK') THEN
XC
XC LASTWEEK seen, return absolute time of 00:00 AM on the past Monday
XC
X`09    CALL SYS$GETTIM(bin_val)
X`09    CALL LIB$DAY(days, bin_val)
X`09    days = 7 + MOD( MOD(days, 7) + 2, 7)
X`09    call lib$mult_delta_time(days,bin_tmp)
X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val)
X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
X`09    ELSE
XC
XC Not a keyword!
XC
X`09    TIMEKEY = 0
X`09    ENDIF
XC
X
X`09RETURN
X`09END
$ CALL UNPACK TIMEKEY.FOR;1 1295927103
$ create 'f'
X.TITLE`09TIME_MESSAGES`09TIME messages and condition codes
X.FACILITY`09TIME,2047/PREFIX=TIME__
X!
X! Messages for TIME program.  Following the defacto standard on the Fermilab
X! Accelerator VAX's, the facility number used with a program's built-in
X! messages is 2047 (shared among many, many programs).
X!
X! Modification History:
X! V1.0`0915-Mar-83`09FJN`09Created
X!
X
X.SEVERITY`09ERROR
XINVABSTIM`09<invalid absolute time format>
XINVADD`09`09<invalid add>
XINVCMP`09`09<invalid compare>
XINVDELTIM`09<invalid delta time format>
XINVDIV`09`09<invalid divide>
XINVINT`09`09<invalid integer value format>
XINVMUL`09`09<invalid multiply>
XINVOPR`09`09<invalid operation>
XINVSUB`09`09<invalid subtract>
XMISPAR`09`09<time parameter missing>
XOVRFLO`09`09<time calculation overflow>
XTOOMNYOPR`09<too many operands supplied>
X
X.END
$ CALL UNPACK TIME_MESSAGES.MSG;1 1195077451
$ v=f$verify(v)
$ EXIT