home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #19 / NN_1992_19.iso / spool / vmsnet / sources / 346 < prev    next >
Encoding:
Internet Message Format  |  1992-09-03  |  36.4 KB
  1. Path: sparky!uunet!usc!news.service.uci.edu!unogate!mvb.saic.com!vmsnet-sources
  2. From: ewilts@galaxy.gov.bc.ca (Ed Wilts)
  3. Newsgroups: vmsnet.sources
  4. Subject: Time functions, part 02/02
  5. Message-ID: <8045354@MVB.SAIC.COM>
  6. Date: Fri, 04 Sep 1992 05:22:33 GMT
  7. Reply-To: EWILTS@GALAXY.GOV.BC.CA
  8. Organization: BC Systems Corporation
  9. Lines: 1204
  10. Approved: Mark.Berryman@Mvb.Saic.Com
  11.  
  12. Submitted-by: ewilts@galaxy.gov.bc.ca (Ed Wilts)
  13. Posting-number: Volume 3, Issue 151
  14. Archive-name: time_functions/part01
  15.  
  16. -+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+
  17. X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
  18. X`09`09`09RESULT = 'YES'
  19. X`09`09ELSE
  20. X`09`09`09RESULT = 'NO'
  21. X`09`09ENDIF
  22. X`09`09GOTO 1999
  23. XC
  24. XC   ------------------------------------------------------------------------
  25. V---
  26. XC
  27. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. GREATER_THAN .OR.
  28. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(GT)' ) THEN
  29. XC
  30. XC`09   Compare for greater than.
  31. XC
  32. X`09`09STATUS = LIB$SUBX( BIN_2, BIN_1, BIN_SCR, 2 )
  33. X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
  34. X`09`09`09RESULT = 'YES'
  35. X`09`09ELSE
  36. X`09`09`09RESULT = 'NO'
  37. X`09`09ENDIF
  38. X`09`09GOTO 1999
  39. XC
  40. XC   ------------------------------------------------------------------------
  41. V---
  42. XC
  43. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. GREATER_THAN_EQUAL_TO .OR.
  44. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(GE)' ) THEN
  45. XC
  46. XC`09   Compare for greater than or equal to.
  47. XC
  48. X`09`09STATUS = LIB$SUBX( BIN_2, BIN_1, BIN_SCR, 2 )
  49. X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
  50. X`09`09`09RESULT = 'YES'
  51. X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
  52. X`09`09`09RESULT = 'YES'
  53. X`09`09ELSE
  54. X`09`09`09RESULT = 'NO'
  55. X`09`09ENDIF
  56. X`09`09GOTO 1999
  57. XC
  58. XC   ------------------------------------------------------------------------
  59. V---
  60. XC
  61. X`09ELSE
  62. XC
  63. XC`09   Invalid operator.
  64. XC
  65. X`09`09CALL LIB$STOP(TIME__INVOPR)
  66. X`09ENDIF
  67. X      ENDDO`09
  68. XC
  69. XC   ------------------------------------------------------------------------
  70. V---
  71. XC
  72. XC   See if there are any additional parameters on the line.
  73. XC
  74. X1999`09CONTINUE
  75. X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP3_1, OP3_2 )
  76. X`09IF ( STATUS ) THEN
  77. X`09`09CALL LIB$STOP(TIME__TOOMNYOPR)
  78. X`09ENDIF
  79. XC
  80. XC   ------------------------------------------------------------------------
  81. V---
  82. XC
  83. XC   Store the symbol in the symbol table, or output it to SYS$OUTPUT dependi
  84. Vng
  85. XC`09on whether a symbol was defined.
  86. XC
  87. X`09STATUS = STR$TRIM`20
  88. X`091`09( RESULT, RESULT, RESULT_S )
  89. X`09IF ( SYMBOL_S .NE. 0 ) THEN
  90. X`09`09STATUS = LIB$SET_SYMBOL
  91. X`091`09`09( SYMBOL(1:SYMBOL_S), RESULT(1:RESULT_S) )
  92. X`09ELSE
  93. X`09`09STATUS = LIB$PUT_OUTPUT ( RESULT(1:RESULT_S) )
  94. X`09END IF`09
  95. XC
  96. XC   Exit.
  97. XC
  98. X`09CALL EXIT(status)
  99. X`09END
  100. $ CALL UNPACK TIME.FOR;1 2118724995
  101. $ create 'f'
  102. X! 23-Mar-83  FJN  Added keywords subtopic
  103. X! 02-Apr-83  FJN  Added LASTMONTH and LASTWEEK keywords
  104. X1 TIME
  105. X The function of this command is to perform time calculation services.
  106. X Format:
  107. X
  108. X         TIME `5B time-spec `5B (operator) time-spec`5D ... `5D
  109. X
  110. X By default if no operands are specified the command will display the
  111. X current system time and the user's connect time.
  112. X
  113. X If only one operand is supplied, then instead of calculating the user's
  114. X connect time the operand (which must be in absolute time format) will be`20
  115. X subtracted from the current system time and that resulting delta time
  116. X displayed along with the current system time.
  117. X
  118. X `5B`5D indicates optional.  () are required for the operator.
  119. X '...' only valid for (+),(-),(*), & (/) operators
  120. X
  121. X The TIME symbol is defined by:
  122. X
  123. X`09TIME :== $ECSEXE:TIME
  124. X
  125. X2 Time-spec
  126. X The times values which may be specified are absolute time,`20
  127. X delta time, keyword for an absolute time or a positive
  128. X integer value.
  129. X
  130. X3 Absolute_time
  131. X Formats:
  132. X
  133. X    dd-mmm-yyyy`5B:`5D`5Bhh:mm:ss.ss`5D
  134. X
  135. X 1. If you specify both the date (dd-mmm-yyyy) and the time
  136. X    (hh:mm:ss.ss), you may type the colon between the date and
  137. X    the time or seperate them with a tab or a blank. `20
  138. X
  139. X    The lexical function 'F$TIME()' may be used to generate`20
  140. X    the current time value (this returns the value with a blank
  141. X    between the date and time fields). `20
  142. X
  143. X    On output there will always be a colon between the date and`20
  144. X    the time of day fields.
  145. X
  146. X 2. If only the date is specified the system will supply the
  147. X    current time of day for the missing time field.
  148. X
  149. X 3. If you specify a time of day you can truncate the time on`20
  150. X    the right.  The truncated fields will be zero filled (See
  151. X    point 4 if you wish to supply punctuation).
  152. X
  153. X 4. If you omit any of the fields but supply the punctuation marks
  154. X    the system will supply the current system time values as`20
  155. X    defaults (do not confuse this with truncation where the
  156. X    punctuation marks are also omited; point 3).
  157. X
  158. X3 Delta_time
  159. X Format
  160. X
  161. X    dd`5B-`5Dhh`5B:mm:ss.ss`5D
  162. X
  163. X When you specify a delta time value, you can truncate the time field
  164. X on the right; you may also omit any of the variable fields, as long
  165. X as you supply the punctuation marks.
  166. X
  167. X When any field is omitted from a delta time value, the system
  168. X supplies a value of 0 for the field.
  169. X
  170. X3 Integer
  171. X An positive integer value may also be specified.  The value must
  172. X be within the range:
  173. X`20
  174. X    0 - 2147483647
  175. X
  176. X3 Keywords
  177. X The following keywords represent certain absolute dates (the times
  178. X are always 00:00:00.00):
  179. X
  180. X    YESTERDAY    yesterday's start.
  181. X    TODAY        start of the current day.
  182. X    TOMORROW     start of tomorrow.
  183. X
  184. X    THISMONTH    First day of the current month.
  185. X    NEXTMONTH    First day of the next month.
  186. X    LASTMONTH    First day of the previous month.
  187. X
  188. X    THISYEAR     January 1 of the current year.
  189. X
  190. X    THISWEEK     Monday of the current week (possibly today).
  191. X    NEXTWEEK     Next Monday (first day of the next week).
  192. X    LASTWEEK     Monday of the previous (full 7-day) week.
  193. X
  194. X2 Operator
  195. X The operators available are addition, subtraction, multiplication,
  196. X division, and comparison.
  197. X The syntax for the operators are:
  198. X
  199. X     (+)    Addition
  200. X     (-)    Subtraction
  201. X     (*)    Multiplication
  202. X     (/)    Division
  203. X     (=)    Compare for equal to
  204. X     (<>)   Compare for not equal to
  205. X     (<)    Compare for less than
  206. X     (<=)   Compare for less than or equal to
  207. X     (>)    Compare for greater than
  208. X     (>=)   Compare for greater than or equal to
  209. X     (?)    General comparison
  210. X
  211. X The operator MUST be enclosed in parenthesis's.  This is to avoid`20
  212. X syntax confusion with the '-' used in the time specifications.
  213. X
  214. X Note:  If any of the results yealds a negative time value the
  215. X        absolute value of the calculation is displayed.
  216. X
  217. X3 Addition (+)
  218. X This operator will add the two operands and return the result.
  219. X Valid combinations and the type of result returned are shown
  220. X below:
  221. X
  222. X     TIME   absolute_time (+) delta_time     -->  absolute_time
  223. X     TIME   delta_time (+) absolute_time     -->  absolute_time
  224. X     TIME   delta_time (+) delta_time        -->  delta_time
  225. X     TIME   integer (+) integer              -->  integer
  226. X
  227. X3 Subtraction (-)
  228. X This operator will subtract the two operands and return the
  229. X result.  Valid combinations and the type of result returned
  230. X are shown below:
  231. X
  232. X     TIME   absolute_time (-) absolute_time  -->  delta_time
  233. X     TIME   absolute_time (-) delta_time     -->  absolute_time
  234. X     TIME   delta_time (-) delta_time        -->  delta_time
  235. X     TIME   integer (-) integer              -->  integer
  236. X
  237. X Note:  If any of the results yealds a negative value the
  238. X        absolute value of the calculation is returned.
  239. X
  240. X3 Multiplication (*)
  241. X This operator will multiply the two operands and return the
  242. X result.  Valid combinations and the type of result returnd
  243. X are shown below:
  244. X
  245. X     TIME   delta_time (*) integer           -->  delta_time
  246. X     TIME   integer (*) delta_time           -->  delta_time
  247. X     TIME   integer (*) integer              -->  integer
  248. X
  249. X3 Division (/)
  250. X This operator will divide the two operands and return the
  251. X result.  Valid combinations and the type of result returned
  252. X are shown below:
  253. X
  254. X     TIME   delta_time (/) delta_time        -->  integer
  255. X     TIME   delta_time (/) integer           -->  delta_time
  256. X     TIME   integer (/) integer              -->  integer
  257. X
  258. X3 Comparison (?)
  259. X This operator will compare the two operands and return the
  260. X results of the comparison.
  261. X
  262. X     TIME   absolute_time       (?)      absolute_time
  263. X
  264. X                            GREATER_THAN
  265. X                              EQUAL_TO
  266. X                              LESS_THAN
  267. X
  268. X     TIME   delta_time       (?)      delta_time
  269. X
  270. X                         GREATER_THAN
  271. X                           EQUAL_TO
  272. X                           LESS_THAN
  273. X
  274. X3 EQ (=)
  275. X This operator wil compare the two operands and return YES
  276. X if they are equal and NO if they are not.
  277. X
  278. X     TIME   absolute_time  (=)   absolute_time
  279. X     TIME   absolute_time  (EQ)   absolute_time
  280. X
  281. X     TIME   delta_time     (=)   delta_time
  282. X     TIME   delta_time     (EQ)   delta_time
  283. X
  284. X3 NE (<>)
  285. X This operator will compare the two operands and return YES
  286. X if they are not equal and NO if they are equal.
  287. X
  288. X     TIME   absolute_time  (<>)   absolute_time
  289. X     TIME   absolute_time  (NE)   absolute_time
  290. X
  291. X     TIME   delta_time     (<>)   delta_time
  292. X     TIME   delta_time     (NE)   delta_time
  293. X
  294. X3 LT (<)
  295. X This operator will compare the two operands and return YES
  296. X if the first operand is less than the second operand,
  297. X otherwise it will return NO.
  298. X
  299. X     TIME   absolute_time  (<)   absolute_time
  300. X     TIME   absolute_time  (LT)   absolute_time
  301. X
  302. X     TIME   delta_time     (<)   delta_time
  303. X     TIME   delta_time     (LT)   delta_time
  304. X
  305. X3 LE (<=)
  306. X This operator will compare the two operands and return YES
  307. X if the first operand is less than or equal to the second`20
  308. X operand, otherwise it will return NO.
  309. X
  310. X     TIME   absolute_time  (<=)   absolute_time
  311. X     TIME   absolute_time  (LE)   absolute_time
  312. X
  313. X     TIME   delta_time     (<=)   delta_time
  314. X     TIME   delta_time     (LE)   delta_time
  315. X
  316. X3 GT (>)
  317. X This operator will compare the two operands and return YES
  318. X if the first operand is greater than the second operand,
  319. X otherwise it will return NO.
  320. X
  321. X     TIME   absolute_time  (>)   absolute_time
  322. X     TIME   absolute_time  (GT)   absolute_time
  323. X
  324. X     TIME   delta_time     (>)   delta_time
  325. X     TIME   delta_time     (GT)   delta_time
  326. X
  327. X3 GE (>=)
  328. X This operator will compare the two operands and return YES
  329. X if the first operand is greater than or equal to the second
  330. X operand, otherwise it will return NO.
  331. X
  332. X     TIME   absolute_time  (>=)   absolute_time
  333. X     TIME   absolute_time  (GE)   absolute_time
  334. X
  335. X     TIME   delta_time     (>=)   delta_time
  336. X     TIME   delta_time     (GE)   delta_time
  337. X
  338. X2 Qualifiers
  339. X
  340. X/DEBUG
  341. X This option will show the intermediate results of a sequence of`20
  342. X operations.  It also disables some internal error checking so`20
  343. X the output may not be correct.
  344. X
  345. X/SYMBOL=symbol_name
  346. X This option will cause the results of the calculation to be stored in
  347. X the specified symbol instead of being displayed to the output device.
  348. $ CALL UNPACK TIME.HLP;2 73615922
  349. $ create 'f'
  350. XC   ------------------------------------------------------------------------
  351. V---
  352. XC   TIMECNV.FOR - The function of this routine is to convert the absolute
  353. XC`09time, delta time, or interger value character string passed into`20
  354. XC`09a positive 64 bit binary value.  If the format is incorrect then the
  355. XC`09status returned is even.
  356. XC
  357. XC`09Note:  The delta times will be converted to positive values.
  358. XC
  359. XC   Calling Procedure:
  360. XC
  361. XC`09status = TIMECNV( string, binary_value )
  362. XC
  363. XC   Entry Conditions:
  364. XC
  365. XC`09string - must contain the absolute time, the delta time or an integer
  366. XC`09`09 character string (integer = 0 through 2147483647) or a
  367. XC`09`09 recognized keyword name.
  368. XC
  369. XC   Exit Conditions:
  370. XC
  371. XC`09status = 3 if string is absolute time format.
  372. XC`09       = 4 if invalid absolute time format.
  373. XC`09       = 5 if string is delta time format.
  374. XC`09       = 6 if invalid delta time format.
  375. XC`09       = 7 if integer value.
  376. XC`09       = 8 if invalid integer value.
  377. XC
  378. XC`09binary_value - contains the binary value of the value converted.
  379. XC`09`09Both absolute times and delta times will be positive.
  380. XC`09`09This variable must be 2 longword long.
  381. XC
  382. XC   ------------------------------------------------------------------------
  383. V---
  384. XC
  385. X`09INTEGER*4 FUNCTION TIMECNV( STRING, BIN_VAL )
  386. XC
  387. X`09IMPLICIT INTEGER*4 (A-Z)
  388. XC
  389. X`09EXTERNAL`09OTS$_INPCONERR
  390. XC
  391. X`09PARAMETER`09DASH='-'
  392. X`09PARAMETER`09COLON=':'
  393. X`09PARAMETER`09BLANK=' '
  394. X`09PARAMETER`09PERIOD='.'
  395. XC
  396. X`09CHARACTER*(*)`09STRING
  397. X`09CHARACTER`09WORK*(32)
  398. XC
  399. X`09INTEGER*4`09TIMEKEY
  400. XC
  401. X`09INTEGER*4`09BIN_VAL(2)
  402. X`09INTEGER*4`09ZERO(2) /0,0/
  403. XC
  404. XC   ------------------------------------------------------------------------
  405. V---
  406. XC
  407. XC   Initialize the return code to integer value.
  408. XC
  409. X`09TIMECNV = 7
  410. XC
  411. XC   Determine if it is absolute, delta, or integer format.
  412. XC`092 dashes is absolute.
  413. XC`091 dash or (no dash and a colon) or (no dash and a period) is delta.
  414. XC`09no dash and no colon and no period is and integer.
  415. XC
  416. X`09I = INDEX( STRING, DASH )
  417. X`09IF ( I .NE. 0 ) THEN`09
  418. X`09`09TIMECNV = 5
  419. X`09`09J = INDEX( STRING(I+1:), DASH )
  420. X`09`09IF ( J .NE. 0 ) THEN
  421. X`09`09`09TIMECNV = 3
  422. X`09`09ENDIF
  423. X`09ENDIF
  424. XC`20
  425. X`09IF ( TIMECNV .EQ. 7 ) THEN
  426. X`09`09IF ( (INDEX( STRING, COLON ) +`20
  427. X`091`09      INDEX( STRING, PERIOD )) .NE. 0 ) TIMECNV = 5
  428. X`09ENDIF
  429. XC
  430. XC   ------------------------------------------------------------------------
  431. V---
  432. XC
  433. XC   Convert the time based on the type of time it is.
  434. XC
  435. X`09IF ( TIMECNV .EQ. 3 ) THEN
  436. XC
  437. XC`09   Absolute time; remove the colon from between the year and hour
  438. XC `09`09if present.
  439. XC
  440. X`09`09B1 = INDEX( STRING, BLANK )
  441. X`09`09IF ( B1 .EQ. 0 ) THEN
  442. X`09`09`09B1 = INDEX( STRING, COLON )
  443. X`09`09`09IF ( B1 .NE. 0 ) THEN
  444. X`09`09`09`09STRING(B1:B1) = BLANK
  445. X`09`09`09ENDIF
  446. X`09`09ENDIF
  447. XC
  448. XC`09   If trailing fields of the time of day are missing supply 0's.
  449. XC
  450. X`09`09WORK = STRING
  451. X`09`09IF ( B1 .NE. 0 ) THEN`09`09! no time; allow full subs.
  452. X`09`09    L = LEN( STRING ) + 1
  453. X`09`09    C1 = INDEX( WORK, COLON )
  454. X`09`09    IF ( C1 .EQ. 0 ) THEN
  455. X`09`09`09WORK(L:) = ':0:0.0'
  456. X`09`09    ELSEIF ( INDEX( WORK(C1+1:), COLON ) .EQ. 0 ) THEN
  457. X`09`09`09WORK(L:) = ':0.0'
  458. X`09`09    ELSEIF ( INDEX( WORK, PERIOD ) .EQ. 0 ) THEN
  459. X`09`09`09WORK(L:) = '.0'
  460. X`09`09    ENDIF
  461. X`09`09ENDIF
  462. XC
  463. XC`09   Convert to absolute binary time.
  464. XC
  465. X`09`09STATUS = SYS$BINTIM( WORK, BIN_VAL )
  466. X`09`09IF ( .NOT. STATUS ) THEN
  467. XC
  468. XC`09`09    Specify return status of invalid absolute time format.
  469. XC
  470. X`09`09`09TIMECNV = 4
  471. X`09`09ENDIF
  472. XC
  473. XC   ------------------------------------------------------------------------
  474. V---
  475. XC
  476. X`09ELSEIF ( TIMECNV .EQ. 5 ) THEN
  477. XC
  478. XC`09   Delta time; remove the dash from between the days and the hour.
  479. XC
  480. X`09`09I = INDEX( STRING, DASH )
  481. X`09`09IF ( I .NE. 0 ) THEN
  482. X`09`09`09STRING(I:I) = BLANK
  483. X`09`09ENDIF
  484. XC
  485. XC`09   Convert to delta binary time.
  486. XC
  487. X`09`09STATUS = SYS$BINTIM( STRING, BIN_VAL )
  488. X`09`09IF ( .NOT. STATUS ) THEN
  489. XC
  490. XC`09`09    Specify return status of invalid delta time format.
  491. XC
  492. X`09`09`09TIMECNV = 6
  493. X`09`09ENDIF
  494. X`09`09STATUS = LIB$SUBX( ZERO, BIN_VAL, BIN_VAL, 2 )
  495. XC
  496. XC   ------------------------------------------------------------------------
  497. V---
  498. XC
  499. X`09ELSEIF ( TIMEKEY(string, bin_val)) THEN
  500. XC
  501. XC Keyword was found, treat as an absolute time
  502. XC
  503. X`09`09timecnv = 3
  504. X`09ELSE
  505. XC
  506. XC`09   Convert the integer value to binary.
  507. XC
  508. X`09`09STATUS = OTS$CVT_TI_L( STRING, BIN_VAL(1), %VAL(4), %VAL(3) )
  509. X`09`09IF ( STATUS .EQ. %LOC(OTS$_INPCONERR) .OR.
  510. X`091`09      BIN_VAL(1) .LT. 0 ) THEN
  511. XC
  512. XC`09`09   Specify return status of invalid integer value format.
  513. XC
  514. X`09`09`09TIMECNV = 8
  515. X`09`09ENDIF
  516. X`09`09BIN_VAL(2) = 0
  517. X`09ENDIF
  518. XC
  519. XC   ------------------------------------------------------------------------
  520. V---
  521. XC
  522. XC   Return
  523. XC
  524. X`09RETURN
  525. X`09END
  526. $ CALL UNPACK TIMECNV.FOR;1 2017346050
  527. $ create 'f'
  528. XC   ------------------------------------------------------------------------
  529. V---
  530. XC   TIMECUR.FOR - The function of this routine is to determine the current
  531. XC`09system time and the processes current connect time.  The values are
  532. XC`09converted to string data and returned as the function value of the
  533. XC`09routine.
  534. XC
  535. XC   Calling Procedure:
  536. XC
  537. XC`09return_string = TIMECUR ( login_time )
  538. XC
  539. XC   Entry Conditions:
  540. XC
  541. XC`09login_time - This must be the time to subtract from the current system
  542. XC`09`09time in order to get the delta time.  If zero is passed than
  543. XC`09`09the process login time is used instead.
  544. XC
  545. XC   Exit Conditions:
  546. XC
  547. XC`09A character string with the current time and the current connect time
  548. XC`09will be returned as the value of the function.
  549. XC
  550. XC`09The format of returned string is:
  551. XC
  552. XC`09`09TIMECUR = 'dd-mmm-yyyy:hh:mm:ss.hh<tab>dddd-hh:mm:ss.hh'
  553. XC
  554. XC`09Leading blanks will be included.
  555. XC
  556. XC   ------------------------------------------------------------------------
  557. V---
  558. XC
  559. X`09CHARACTER*40 FUNCTION TIMECUR ( LOGINTIM )
  560. XC
  561. X`09IMPLICIT INTEGER*4 (A-Z)
  562. XC
  563. X`09PARAMETER`09ABSZ=23
  564. X`09PARAMETER`09DELTAZ=16
  565. X`09PARAMETER`09DASH='-'
  566. X`09PARAMETER`09EQUAL=':='
  567. X`09PARAMETER`09COLON=':'
  568. X`09PARAMETER`09TAB='`09'
  569. XC
  570. X`09CHARACTER`09ABS_C*(ABSZ)
  571. X`09CHARACTER`09JPI_LOGINTIM*(ABSZ)
  572. X`09CHARACTER`09DELTA_C*(DELTAZ)
  573. XC
  574. X`09INTEGER*4`09ABS(2), ABS_S
  575. X`09INTEGER*4`09LOGINTIM(2), LOGINTIM_S
  576. X`09INTEGER*4`09DELTA(2), DELTA_S
  577. XC
  578. XC   ------------------------------------------------------------------------
  579. V---
  580. XC
  581. XC   Fetch the processes login time.
  582. XC
  583. X`09IF ( LOGINTIM(1) .EQ. 0 ) THEN
  584. X`09`09TIMECUR = JPI_LOGINTIM ( LOGINTIM, LOGINTIM_S )
  585. X`09ENDIF
  586. XC
  587. XC   Fetch the current character system time.
  588. XC
  589. X`09CALL SYS$ASCTIM ( ABS_S, ABS_C, , %VAL(0) )
  590. XC
  591. XC   Convert the current system time to binary system time
  592. XC
  593. X`09CALL SYS$BINTIM ( ABS_C, ABS )
  594. XC
  595. XC   Subtract the login time from the current system time to get connect time
  596. V.
  597. XC`09Note: that the acutal calculation is done to yeald negative result
  598. XC`09      because delta times are negative values.
  599. XC
  600. X`09CALL LIB$SUBX ( LOGINTIM, ABS, DELTA, 2 )
  601. XC
  602. XC   Convert the binary connect time to character.
  603. XC
  604. X`09CALL SYS$ASCTIM ( DELTA_S, DELTA_C, DELTA, %VAL(0) )
  605. XC
  606. XC   Insert the colon between year & hour, and insert the dash between`20
  607. XC`09day & hour.
  608. XC
  609. X`09ABS_C(12:12) = COLON
  610. X`09DELTA_C(5:5) = DASH
  611. XC
  612. XC   Format the retrun string.
  613. XC
  614. X`09TIMECUR = ABS_C // TAB // DELTA_C
  615. XC
  616. XC   Return.
  617. XC
  618. X`09RETURN
  619. X`09END
  620. $ CALL UNPACK TIMECUR.FOR;1 577170431
  621. $ create 'f'
  622. X`09.TITLE`09TIMEEDIV - Time division routine.
  623. X`09.IDENT`09/01/
  624. X;++
  625. X;   TIMEEDIV.MAR - The function of this routine is to divide a quadword
  626. X;`09by a quadword and return a quadword result and a quadword remainder.
  627. X;
  628. X;
  629. X;   Calling Procedure:
  630. X;
  631. X;`09status = TIMEEDIV( divisor, dividend, result, remainder ) ! FORTRAN
  632. X;
  633. X;   Entry Conditions:
  634. X;
  635. X;`094(AP) - must contain the address of the quadword dividend.
  636. X;`098(AP) - must contain the address of the quadword divisor.
  637. X;
  638. X;   Exit Conditions:
  639. X;
  640. X;`0912(AP) - must contain the address of the quadword to receive the
  641. X;`09`09result.
  642. X;`0916(AP) - must contain the address of the quadword to receive the
  643. X;`09`09remainder.
  644. X;
  645. X;`09R0 - will contain 1 on exit.
  646. X;`09     if divide by 0 then = 0
  647. X;---------------------------------------------------------------------------
  648. V---
  649. X;
  650. X;   Psect for quadword divide.
  651. X;
  652. X`09.PSECT`09TIMEEDIV
  653. X;
  654. XDIVR`09=`094
  655. XDIVD`09=`098
  656. XRESULT`09=`0912
  657. XREMAINDER =`0916
  658. XLOW`09=`090
  659. XHIGH`09=`094
  660. X;
  661. X;   Entry point - TIMEEDIV
  662. X;
  663. X`09.ENTRY`09TIMEEDIV,`5EM<R2,R3,R4,R5,R6,R7,R8,R9>
  664. X;
  665. X;   Fetch the divisor and the dividend.
  666. X;
  667. X`09MOVQ`09@DIVR(AP),R2`09`09; Fetch value of divisor.
  668. X`09MOVQ`09@DIVD(AP),R4`09`09; Fetch value of dividend.
  669. X`09CLRQ`09R6`09`09`09; Clear MS Qw of dividend work area.
  670. X;
  671. X;   Check for divide by zero.
  672. X;
  673. X`09ADDL3`09R2,R3,R0`09`09; If divisor .EQ. 0,
  674. X`09BEQL`09DIVIDE_BY_ZERO`09`09;   then return dividend as result and
  675. X`09`09`09`09`09;   0 for remainder.
  676. X;
  677. X;   Determine the sign of the result and save the value.
  678. X;
  679. X`09XORL3`09R3,R5,R9`09`09; Exclusive OR sign bits of divisor
  680. X`09`09`09`09`09;   and dividend to determine sign
  681. X`09`09`09`09`09;   of result.
  682. X;
  683. X;   Form absolute values of each operand.
  684. X;
  685. X`09TSTL`09R3`09`09`09; Is divisor < 0 ??
  686. X`09BGEQ`0910$`09`09`09;   No
  687. X`09MOVQ`09R2,R0`09`09`09;   Yes; Place divisor in scratch area
  688. X`09CLRQ`09R2`09`09`09;`09 Zero difference area
  689. X`09SUBL`09R0,R2`09`09`09;`09 0 - divisor(low)
  690. X`09SBWC`09R1,R3`09`09`09;`09 0 - divisor(high) - carry
  691. X10$:
  692. X`09TSTL`09R5`09`09`09; Is dividend < 0 ??
  693. X`09BGEQ`0920$`09`09`09;   No
  694. X`09MOVQ`09R4,R0`09`09`09;   Yes; Place dividend in work area
  695. X`09CLRQ`09R4`09`09`09;`09 Zero difference area
  696. X`09SUBL`09R0,R4`09`09`09;`09 0 - dividend(low)
  697. X`09SBWC`09R1,R5`09`09`09;`09 0 - dividend(high) - carry
  698. X20$:
  699. X;;;;
  700. X;
  701. X;
  702. X;   Shift 128 bit dividend work area 1 bit left.
  703. X;;;;
  704. X`09CLRL`09R8`09`09`09; Clear the loop counter.
  705. XLOOP:
  706. X`09ASHQ`09#1,R6,R6`09`09; Shift dividend MS left 1 bit.
  707. X`09BITL`09#`5Ex80000000,R5`09`09; If dividend LS hi bit = 1,
  708. X`09BEQL`0930$`09`09`09;   then
  709. X`09BISL`09#1,R6`09`09`09;     Set MS low bit = 1.
  710. X30$:`09`09`09`09`09; Endif
  711. X`09ASHQ`09#1,R4,R4`09`09; Shift dividend LS left 1 bit.
  712. X;
  713. X;   Trial subtract the divisor from the dividend work area (most significent
  714. V)
  715. X;
  716. X`09MOVQ`09R6,R0`09`09`09; Move the MS dividend work area to tmp
  717. X`09SUBL`09R2,R0`09`09`09; Subtract divisor(low).
  718. X`09SBWC`09R3,R1`09`09`09; Subtract divisor(high) w/carry.
  719. X`09BLSS`0950$`09`09`09; If result is positive, then
  720. X`09MOVQ`09R0,R6`09`09`09;   Place result in dividend MS
  721. X`09BISL`09#1,R4`09`09`09;   Set dividend LS low bit = 1.
  722. X50$:`09`09`09`09`09; Endif
  723. X;
  724. X;   Process the loop control data and repeat loop if not done
  725. X;
  726. X`09AOBLSS`09#64,R8,LOOP
  727. X;;;;
  728. X;   Set the signs of the result and remainder based on the divisor and divid
  729. Vend
  730. X;;;;
  731. X`09TSTL`09@DIVD(AP)`09`09; If dividend < 0,
  732. X`09BGEQ`0970$`09`09`09;   then
  733. X`09MOVQ`09R6,R0`09`09`09;     Place remainder in scratch area
  734. X`09CLRQ`09R6`09`09`09;     Zero remainder storage area.
  735. X`09SUBL`09R0,R6`09`09`09;     0 - remainder(low)
  736. X`09SBWC`09R1,R7`09`09`09;     0 - remainder(high) - carry
  737. X70$:`09`09`09`09`09; Endif
  738. X;
  739. X;   Register 9 has sign to set result to.
  740. X;
  741. X`09TSTL`09R9`09`09`09; If saved sign < 0,
  742. X`09BGEQ`0980$`09`09`09;   then
  743. X`09MOVQ`09R4,R0`09`09`09;     Place result in scratch area.
  744. X`09CLRQ`09R4`09`09`09;     Zero result storage area.
  745. X`09SUBL`09R0,R4`09`09`09;     0 - result(low)
  746. X`09SBWC`09R1,R5`09`09`09;     0 - result(high) - carry
  747. X80$:`09`09`09`09`09; Endif
  748. X;;;;
  749. X;   Store the result and remainder values.
  750. X;;;;
  751. X`09MOVL`09#1,R0`09`09`09; Set the return status.
  752. XDIVIDE_BY_ZERO:
  753. X`09MOVQ`09R4,@RESULT(AP)`09`09; Store the result.
  754. X`09MOVQ`09R6,@REMAINDER(AP)`09; Store the remainder.
  755. X;
  756. X;   Return`20
  757. X;
  758. XEXIT:
  759. X`09RET
  760. X;
  761. X`09.END
  762. $ CALL UNPACK TIMEEDIV.MAR;1 1564323094
  763. $ create 'f'
  764. X`09.TITLE`09TIMEEMUL Extended multiply routine
  765. X`09.IDENT`09/01/
  766. X;++
  767. X;   TIMEEMUL.MAR - The function of this routine is to multiply a quadword`20
  768. X;`09by a quadword and return a quadword result.
  769. X;
  770. X;   Calling Procedure:
  771. X;
  772. X;`09status = TIMEEMUL( multiplier, multiplican, result )`09! FORTRAN
  773. X;
  774. X;   Entry Conditions:
  775. X;
  776. X;`094(AP) - must contain the address of the quadword multiplier.
  777. X;`098(AP) - must contain the address of the quadword multiplican.
  778. X;
  779. X;   Exit Conditions:
  780. X;
  781. X;`0912(AP) - must contain the address of the quadword to receive the
  782. X;`09`09quadword result.
  783. X;
  784. X;`09R0 - will contain 1 on exit.
  785. X;`09     if overflow R0 = 0.
  786. X;---------------------------------------------------------------------------
  787. V---
  788. X;
  789. X;   Psect for quadword multiply.
  790. X;
  791. X`09.PSECT`09TIMEEMUL
  792. X;
  793. XMULC `09=`094
  794. XMULR`09=`098
  795. XRESULT`09=`0912
  796. XLOW`09=`090
  797. XHIGH`09=`094
  798. X;
  799. X;   Entry point - TIMEEMUL
  800. X;
  801. X`09.ENTRY`09TIMEEMUL,`5EM<R2,R3,R4,R5,R6,R7,R8,R9>
  802. X;
  803. X;   Fetch the multiplier and multiplicand.
  804. X;
  805. X`09MOVQ`09@MULR(AP),R2`09`09; Fetch value of multiplier.
  806. X`09MOVQ`09@MULC(AP),R4`09`09; Fetch value of multiplicand.
  807. X`09CLRQ`09R6`09`09`09; Clear LS part of multiplicand area.
  808. X;
  809. X;   Determine the sign of the result and save the value.
  810. X;
  811. X`09XORL3`09R3,R5,R9`09`09; Exclusive OR sign bits of multiplier
  812. X`09`09`09`09`09;   and multiplicand to determine sign
  813. X`09`09`09`09`09;   of result.
  814. X;
  815. X;   Form absolute values of each operand.
  816. X;
  817. X`09TSTL`09R3`09`09`09; Is multiplier < 0 ??
  818. X`09BGEQ`0910$`09`09`09;   No
  819. X`09MOVQ`09R2,R0`09`09`09;   Yes; Place multiplier in scr area
  820. X`09CLRQ`09R2`09`09`09;`09 Zero difference area
  821. X`09SUBL`09R0,R2`09`09`09;`09 0 - multiplier(low)
  822. X`09SBWC`09R1,R3`09`09`09;`09 0 - multiplier(high) - carry
  823. X10$:
  824. X`09TSTL`09R5`09`09`09; Is multiplicand < 0 ??
  825. X`09BGEQ`0920$`09`09`09;   No
  826. X`09MOVQ`09R4,R0`09`09`09;   Yes; Place multiplicand in work area
  827. X`09CLRQ`09R4`09`09`09;`09 Zero difference area
  828. X`09SUBL`09R0,R4`09`09`09;`09 0 - multiplicand(low)
  829. X`09SBWC`09R1,R5`09`09`09;`09 0 - multiplicand(high) - carry
  830. X20$:
  831. X;;;;
  832. X;
  833. X;
  834. X;   Add multiplier and multiplicand then shift multiplicand.
  835. X;;;;
  836. X`09CLRL`09R8`09`09`09; Clear the loop counter.
  837. XLOOP:
  838. X`09BITL`09#1,R4`09`09`09; If multiplicand LS low bit set,
  839. X`09BEQL`0925$`09`09`09;   then
  840. X`09ADDL`09R2,R6`09`09`09;     Add MS multiplicand(low) to`20
  841. X`09`09`09`09`09;       multiplier(low).
  842. X`09ADWC`09R3,R7`09`09`09;     Add MS multiplicand(high) to
  843. X`09`09`09`09`09;       multiplier(high) with carry.
  844. X25$:`09`09`09`09`09; Endif
  845. X;
  846. X;   Shift 128 bit multiplicand work area 1 bit right.
  847. X;
  848. X`09ASHQ`09#<-1>,R4,R4`09`09; Shift LS right 1 bit.
  849. X`09BICL`09#`5Ex80000000,R5`09`09; Clear LS hi bit.
  850. X`09BITL`09#1,R6`09`09`09; If MS low bit = 1,
  851. X`09BEQL`0930$`09`09`09;   then
  852. X`09BISL`09#`5Ex80000000,R5`09`09;     Set LS high bit = 1.
  853. X30$:`09`09`09`09`09; Endif
  854. X`09ASHQ`09#<-1>,R6,R6`09`09; Shift MS right 1 bit.
  855. X`09BICL`09#`5Ex80000000,R7`09`09; Clear MS hi bit.
  856. X;
  857. X;   Process the loop control data and repeat loop if not done
  858. X;
  859. X`09AOBLSS`09#64,R8,LOOP
  860. XEND_LOOP:
  861. X;;;;
  862. X;   Set the signs of the result based on the multiplier and multiplicand.
  863. X;   `09Register 9 has sign to set result to.
  864. X;;;;
  865. X`09TSTL`09R9`09`09`09; If saved sign < 0,
  866. X`09BGEQ`0980$`09`09`09;   then
  867. X`09MOVQ`09R4,R0`09`09`09;     Place result in scratch area.
  868. X`09CLRQ`09R4`09`09`09;     Zero result storage area.
  869. X`09SUBL`09R0,R4`09`09`09;     0 - result(low)
  870. X`09SBWC`09R1,R5`09`09`09;     0 - result(high) - carry
  871. X80$:`09`09`09`09`09; Endif
  872. X;;;;
  873. X;   Check for overflow.
  874. X;;;;
  875. X`09MOVL`09#1,R0`09`09`09; Set the return status = 1
  876. X`09ADDL3`09R6,R7,R1`09`09; If multiplicand MS .ne. 0
  877. X`09BEQL`0990$`09`09`09;   then
  878. X`09MOVL`09#0,R0`09`09`09;     set return status = 0
  879. X90$:`09`09`09`09`09; Endif
  880. X;;;;
  881. X;   Store the result value.
  882. X;;;;
  883. X`09MOVQ`09R4,@RESULT(AP)`09`09; Store the result.
  884. X;
  885. X;   Return`20
  886. X;
  887. XEXIT:
  888. X`09RET
  889. X;
  890. X`09.END
  891. $ CALL UNPACK TIMEEMUL.MAR;1 844888009
  892. $ create 'f'
  893. XC   ------------------------------------------------------------------------
  894. V---
  895. XC   TIMEGET - The function of this routine is to find the next character
  896. XC`09string from the time calculation line and return pointers to the First`2
  897. V0
  898. XC`09and Last characters of the string.
  899. XC
  900. XC`09The delimiters are:
  901. XC
  902. XC`09`09end of string
  903. XC`09`09'('
  904. XC`09`09')'
  905. XC
  906. XC`09Beginning and trailing blanks will not be returned.
  907. XC
  908. XC   ------------------------------------------------------------------------
  909. V---
  910. XC
  911. X`09INTEGER*4 FUNCTION TIMEGET ( STRING, S1, S2 )
  912. XC
  913. X`09IMPLICIT INTEGER*4 (A-Z)
  914. XC
  915. X`09EXTERNAL`09SS$_NORMAL
  916. XC
  917. X`09PARAMETER`09OPEN_P='('
  918. X`09PARAMETER`09CLOSE_P=')'
  919. X`09PARAMETER`09BLANK=' '
  920. XC
  921. X`09CHARACTER`09STRING*(*)
  922. XC
  923. X`09INTEGER*4`09S1, S2, TMP
  924. X`09INTEGER*4`09STRING_S
  925. XC
  926. XC   ------------------------------------------------------------------------
  927. V---
  928. XC
  929. XC   Initialize the return code.
  930. XC
  931. X`09TIMEGET = %LOC(SS$_NORMAL)
  932. XC
  933. XC   Find the beginning of the string.
  934. XC
  935. X`09STRING_S = LEN( STRING )
  936. XC
  937. X`09S1 = S2 + 1
  938. X`09TMP = LIB$SKPC ( BLANK, STRING(S1:STRING_S) ) + (S1-1)
  939. X`09IF ( TMP .EQ. (S1-1) ) THEN
  940. X`09`09TIMEGET = 0
  941. X`09`09GOTO 999
  942. X`09END IF
  943. X`09S1 = TMP
  944. XC
  945. XC   Find the end of the string.
  946. XC
  947. X`09TMP = INDEX( STRING(S1:STRING_S), OPEN_P ) + (S1-1)
  948. X`09IF ( TMP .NE. (S1-1) .AND. TMP .NE. S1 ) THEN
  949. X`09`09S2 = TMP - 1
  950. X`09ELSE
  951. X`09`09TMP = INDEX( STRING(S1:STRING_S), CLOSE_P ) + (S1-1)
  952. X`09`09IF ( TMP .NE. (S1-1) ) THEN
  953. X`09`09`09S2 = TMP
  954. X`09`09ELSE
  955. X`09`09`09S2 = STRING_S
  956. X`09`09ENDIF
  957. X`09ENDIF
  958. XC
  959. XC   Remove trailing blanks from the string.
  960. XC
  961. X`09STATUS = STR$TRIM( STRING(S1:S2), STRING(S1:S2), TMP )
  962. X`09S2 = TMP + (S1-1)
  963. XC
  964. XC   Return
  965. XC
  966. X999`09CONTINUE
  967. X`09RETURN
  968. X`09END
  969. $ CALL UNPACK TIMEGET.FOR;1 578512302
  970. $ create 'f'
  971. XC Last Modified:  14-MAY-1990 20:28:31.66, By: RLB`20
  972. X
  973. X`09INTEGER*4 FUNCTION TIMEKEY( string,bin_val )
  974. XC
  975. X`09IMPLICIT INTEGER*4 (A-Z)
  976. X`09CHARACTER*(*) string
  977. X`09INTEGER*4 bin_val(2)
  978. XC
  979. XC+/TIMEKEY
  980. XC
  981. XC Functional Description:
  982. XC`09Check for absolute time specified by a keyword.  The recognized
  983. XC`09keywords and their meanings are:
  984. XC
  985. XC`09`09YESTERDAY`0900:00 AM of the previous day
  986. XC`09`09TODAY`09`0900:00 AM of the current day
  987. XC`09`09TOMORROW`09midnight of the current day (00:00 AM tomorrow)
  988. XC`09`09THISMONTH`09first day of the current month (00:00 AM)
  989. XC`09`09NEXTMONTH`09first day of the next month (00:00 AM)
  990. XC`09`09LASTMONTH`09first day of the previous month (00:00 AM)
  991. XC`09`09THISYEAR`09January 1st of the current year (00:00 AM)
  992. Xc`09        LASTYEAR`09January 1st of the next year (00:00 AM)
  993. Xc`09        NEXTYEAR`09January 1st of the next year (00:00 AM)
  994. XC`09`09THISWEEK`090000 AM on the last Monday (start of this week)
  995. XC`09`09NEXTWEEK`090000 AM on the next Monday (next week start)
  996. XC`09`09LASTWEEK`090000 AM on the last Monday of a full week
  997. Xc`09`09
  998. XC
  999. XC Input Parameters:
  1000. XC`09string - character string compared against the literal keywords.
  1001. XC`09`09 Abbreviations are not check for.
  1002. XC
  1003. XC Implicit Inputs:
  1004. XC`09NONE
  1005. XC
  1006. XC Output Parameters:
  1007. XC`09TIMEKEY - returns 1 if keyword match found, else 0.
  1008. XC`09bin_val - quadword in which the absolute time is returned.
  1009. XC
  1010. XC Implicit Outputs:
  1011. XC`09NONE
  1012. XC
  1013. XC Condition Codes Signalled:
  1014. XC`09NONE
  1015. XC
  1016. XC Side Effects:
  1017. XC`09NONE
  1018. XC
  1019. XC-
  1020. X`09CHARACTER*24 work
  1021. X`09INTEGER*2 work_s
  1022. X`09INTEGER*2 tincr(2)
  1023. X`09INTEGER*4 days, bin_tmp(2)
  1024. X`09INTEGER*4 secs_per_day, ticks_per_sec
  1025. X`09PARAMETER (secs_per_day = 24*60*60, ticks_per_sec = 10*1000*1000)
  1026. X`09parameter one_day = '1 0:0:0.0'
  1027. X`09parameter midnight = '00:00:00.00'
  1028. XC
  1029. X`09TIMEKEY = 1
  1030. X
  1031. X`09call sys$bintim(one_day,bin_tmp)
  1032. X`09IF (string .EQ. 'YESTERDAY') THEN
  1033. XC                                           `20
  1034. XC YESTERDAY seen, return absolute time of 00:00 AM yesterday.
  1035. XC
  1036. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1037. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1038. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1039. X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val)`09!Minus 1 day
  1040. X
  1041. X`09    ELSE IF (string .EQ. 'TODAY') THEN
  1042. XC
  1043. XC TODAY seen, return absolute time of 00:00 AM on this day
  1044. XC
  1045. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1046. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1047. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1048. X
  1049. X`09    ELSE IF (string .EQ. 'TOMORROW') THEN
  1050. XC
  1051. XC TOMORROW seen, return absolute time of 00:00 AM tomorrow morning.
  1052. XC
  1053. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1054. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1055. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1056. X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)`09!plus 1 day
  1057. X
  1058. X`09    ELSE IF (string .EQ. 'THISMONTH') THEN
  1059. XC
  1060. XC THISMONTH seen, return absolute time of 00:00 AM on the 1st of the month.
  1061. XC
  1062. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1063. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1064. X`09    work(1:2) = ' 1'`09`09`09!First day of month
  1065. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1066. X
  1067. X`09    ELSE IF (string .EQ. 'THISYEAR') THEN
  1068. XC
  1069. XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
  1070. XC
  1071. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1072. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1073. X`09    work(1:6) = ' 1-JAN'`09`09!First day of year
  1074. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1075. X
  1076. X`09    ELSE IF (string .EQ. 'LASTYEAR') THEN
  1077. XC
  1078. XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
  1079. XC
  1080. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1081. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1082. X`09    work(1:6) = ' 1-JAN'`09`09!1st day of year
  1083. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1084. X`09    call lib$sub_times(bin_val, bin_tmp, bin_val) ! subtract 1 day`20
  1085. X`09    call sys$asctim(work_s, work, bin_val, )
  1086. X`09    work(1:6) = ' 1-JAN'
  1087. X`09    call sys$bintim(work(1:work_s), bin_val)
  1088. X
  1089. X`09    ELSE IF (string .EQ. 'NEXTYEAR') THEN
  1090. XC
  1091. XC THISYEAR seen, return absolute time of 00:00 AM on the 1st of January.
  1092. XC
  1093. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1094. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1095. X`09    work(1:6) = '31-DEC'`09`09!last  day of year
  1096. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1097. X`09    call lib$add_times(bin_val, bin_tmp, bin_val) ! add 1 day`20
  1098. X
  1099. X`09    ELSE IF (string .EQ. 'NEXTMONTH') THEN
  1100. XC
  1101. XC NEXTMONTH seen, return absolute time of 00:00 AM on the 1st of next month.
  1102. XC
  1103. Xc  get the 1st of this month first
  1104. Xc  then compute first of next month
  1105. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1106. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1107. X`09    work(1:2) = ' 1'`09`09`09!First day of month
  1108. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1109. Xc`09    CALL SYS$GETTIM(bin_val)
  1110. X`09    call lib$mult_delta_time(32,bin_tmp)
  1111. X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)
  1112. X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
  1113. X`09    work(13:23) = midnight`09`09!To get 00 AM of +32 days
  1114. X`09    work(1:2) = ' 1'`09`09`09!First day of next month
  1115. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1116. X
  1117. X`09    ELSE IF (string .EQ. 'LASTMONTH') THEN
  1118. XC
  1119. XC LASTMONTH seen, return absolute time of 00:00 AM on the 1st of last month.
  1120. XC
  1121. Xc  get the 1st of this month first
  1122. Xc  then compute first of last month
  1123. Xc
  1124. X`09    CALL SYS$ASCTIM(work_s, work,, )
  1125. X`09    work(13:23) = midnight`09`09!To get 00 AM today
  1126. X`09    work(1:2) = ' 1'`09`09`09!First day of month
  1127. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1128. Xc`09    CALL SYS$GETTIM(bin_val)`09`09! Now produce
  1129. X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val) !Minus 1 day
  1130. X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
  1131. X`09    work(13:23) = midnight`09`09!To get 00 AM of`20
  1132. X`09    work(1:2) = ' 1'`09`09`09!First day of past month
  1133. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1134. X
  1135. X`09    ELSE IF (string .EQ. 'THISWEEK') THEN
  1136. XC
  1137. XC THISWEEK seen, return absolute time of 00:00 AM on the latest Monday
  1138. XC
  1139. X`09    CALL SYS$GETTIM(bin_val)
  1140. X`09    CALL LIB$DAY_OF_WEEK( bin_val, days )
  1141. X`09    days = days-1
  1142. X`09    if( days.gt.0 ) then
  1143. X`09      call lib$mult_delta_time(days,bin_tmp)
  1144. X`09      CALL lib$sub_times(bin_val, bin_tmp, bin_val)
  1145. X`09    endif
  1146. X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
  1147. X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
  1148. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1149. X
  1150. X`09    ELSE IF (string .EQ. 'NEXTWEEK') THEN
  1151. XC
  1152. XC NEXTWEEK seen, return absolute time of 00:00 AM on the next Monday
  1153. XC
  1154. X`09    CALL SYS$GETTIM(bin_val)
  1155. X`09    CALL LIB$DAY(days, bin_val)
  1156. X`09    days = 7 - MOD( MOD(days, 7) + 2, 7)
  1157. X`09    call lib$mult_delta_time(days,bin_tmp)
  1158. X`09    CALL lib$add_times(bin_val, bin_tmp, bin_val)
  1159. X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
  1160. X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
  1161. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1162. X
  1163. X`09    ELSE IF (string .EQ. 'LASTWEEK') THEN
  1164. XC
  1165. XC LASTWEEK seen, return absolute time of 00:00 AM on the past Monday
  1166. XC
  1167. X`09    CALL SYS$GETTIM(bin_val)
  1168. X`09    CALL LIB$DAY(days, bin_val)
  1169. X`09    days = 7 + MOD( MOD(days, 7) + 2, 7)
  1170. X`09    call lib$mult_delta_time(days,bin_tmp)
  1171. X`09    CALL lib$sub_times(bin_val, bin_tmp, bin_val)
  1172. X`09    CALL SYS$ASCTIM(work_s, work, bin_val, )
  1173. X`09    work(13:23) = midnight`09`09!To get 00 AM on Monday
  1174. X`09    CALL SYS$BINTIM(work(1:work_s), bin_val)
  1175. X`09    ELSE
  1176. XC
  1177. XC Not a keyword!
  1178. XC
  1179. X`09    TIMEKEY = 0
  1180. X`09    ENDIF
  1181. XC
  1182. X
  1183. X`09RETURN
  1184. X`09END
  1185. $ CALL UNPACK TIMEKEY.FOR;1 1295927103
  1186. $ create 'f'
  1187. X.TITLE`09TIME_MESSAGES`09TIME messages and condition codes
  1188. X.FACILITY`09TIME,2047/PREFIX=TIME__
  1189. X!
  1190. X! Messages for TIME program.  Following the defacto standard on the Fermilab
  1191. X! Accelerator VAX's, the facility number used with a program's built-in
  1192. X! messages is 2047 (shared among many, many programs).
  1193. X!
  1194. X! Modification History:
  1195. X! V1.0`0915-Mar-83`09FJN`09Created
  1196. X!
  1197. X
  1198. X.SEVERITY`09ERROR
  1199. XINVABSTIM`09<invalid absolute time format>
  1200. XINVADD`09`09<invalid add>
  1201. XINVCMP`09`09<invalid compare>
  1202. XINVDELTIM`09<invalid delta time format>
  1203. XINVDIV`09`09<invalid divide>
  1204. XINVINT`09`09<invalid integer value format>
  1205. XINVMUL`09`09<invalid multiply>
  1206. XINVOPR`09`09<invalid operation>
  1207. XINVSUB`09`09<invalid subtract>
  1208. XMISPAR`09`09<time parameter missing>
  1209. XOVRFLO`09`09<time calculation overflow>
  1210. XTOOMNYOPR`09<too many operands supplied>
  1211. X
  1212. X.END
  1213. $ CALL UNPACK TIME_MESSAGES.MSG;1 1195077451
  1214. $ v=f$verify(v)
  1215. $ EXIT
  1216.