home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #19 / NN_1992_19.iso / spool / vmsnet / sources / 345 < prev    next >
Encoding:
Internet Message Format  |  1992-09-03  |  47.2 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 01/02
  5. Message-ID: <8045352@MVB.SAIC.COM>
  6. Date: Fri, 04 Sep 1992 05:22:25 GMT
  7. Reply-To: EWILTS@GALAXY.GOV.BC.CA
  8. Organization: BC Systems Corporation
  9. Lines: 1495
  10. Approved: Mark.Berryman@Mvb.Saic.Com
  11.  
  12. Submitted-by: ewilts@galaxy.gov.bc.ca (Ed Wilts)
  13. Posting-number: Volume 3, Issue 150
  14. Archive-name: time_functions/part01
  15.  
  16.           [ No description or Readme file was provided with this
  17.            submission.  It appears to provide various time
  18.            calculation and comparison functions.  It includes both
  19.            DCL and Fortran code. ]
  20.  
  21. $! ------------------ CUT HERE -----------------------
  22. $ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
  23. $!
  24. $! This archive created by VMS_SHARE Version 7.2-010  25-Jun-1992
  25. $!   On  3-SEP-1992 22:08:57.78   By user BERRYMAN 
  26. $!
  27. $! This VMS_SHARE Written by:
  28. $!    Andy Harper, Kings College London UK
  29. $!
  30. $! Acknowledgements to:
  31. $!    James Gray       - Original VMS_SHARE
  32. $!    Michael Bednarek - Original Concept and implementation
  33. $!
  34. $!+ THIS PACKAGE DISTRIBUTED IN 2 PARTS, TO KEEP EACH PART
  35. $!  BELOW 100 BLOCKS
  36. $!
  37. $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
  38. $! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
  39. $!
  40. $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
  41. $!       1. CVTIME.COM;1
  42. $!       2. DAYMONTH.COM;2
  43. $!       3. DESCRIP.MMS;1
  44. $!       4. GET_STRING.FOR;1
  45. $!       5. JPILGINTM.FOR;1
  46. $!       6. LIB_NARGS.MAR;1
  47. $!       7. Q_STRING.FOR;1
  48. $!       8. TABS2BLNK.FOR;1
  49. $!       9. TEST.COM;1
  50. $!      10. TIME.FOR;1
  51. $!      11. TIME.HLP;2
  52. $!      12. TIMECNV.FOR;1
  53. $!      13. TIMECUR.FOR;1
  54. $!      14. TIMEEDIV.MAR;1
  55. $!      15. TIMEEMUL.MAR;1
  56. $!      16. TIMEGET.FOR;1
  57. $!      17. TIMEKEY.FOR;1
  58. $!      18. TIME_MESSAGES.MSG;1
  59. $!
  60. $set="set"
  61. $set symbol/scope=(nolocal,noglobal)
  62. $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
  63. $e="write sys$error  ""%UNPACK"", "
  64. $w="write sys$output ""%UNPACK"", "
  65. $ if f$trnlnm("SHARE_LOG") then $ w = "!"
  66. $ ve=f$getsyi("version")
  67. $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
  68. $ e "-E-OLDVER, Must run at least VMS 4.4"
  69. $ v=f$verify(v)
  70. $ exit 44
  71. $UNPACK: SUBROUTINE ! P1=filename, P2=checksum
  72. $ x = P1 - f$parse(P1,,,"version")
  73. $ y = f$search(x)
  74. $ if y .eqs. "" then $ goto file_absent
  75. $ x = f$integer(f$parse(P1,,,"version")-";")
  76. $ y = f$integer(f$parse(y,,,"version")-";")
  77. $ if x .gt. y then $ goto file_absent
  78. $ if f$mode() .eqs. "INTERACTIVE" then $ goto file_interactive
  79. $ if x .eq. y then e "-W-EXISTS, File ''P1' exists. Skipped."
  80. $ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists. Skipped."
  81. $file_delete:
  82. $ delete 'f'*
  83. $ exit
  84. $file_interactive:
  85. $ if x .eq. y then e "-W-EXISTS, File ''P1' exists."
  86. $ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists."
  87. $ read/error=file_delete/end=file_delete-
  88.   /prompt="Create new version [y/n]: " -
  89.   sys$command x
  90. $ if .not. x then $ e "-W-SKIPPED, File ''P1' skipped."
  91. $ if .not. x then $ goto file_delete
  92. $ P1 = P1 - f$parse(P1,,,"version")
  93. $file_absent:
  94. $ if f$parse(P1) .nes. "" then $ goto dirok
  95. $ dn=f$parse(P1,,,"DIRECTORY")
  96. $ w "-I-CREDIR, Creating directory ''dn'."
  97. $ create/dir 'dn'
  98. $ if $status then $ goto dirok
  99. $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
  100. $ delete 'f'*
  101. $ exit
  102. $dirok:
  103. $ w "-I-PROCESS, Processing file ''P1'."
  104. $ if .not. f$verify() then $ define/user sys$output nl:
  105. $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
  106. PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
  107. SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
  108. CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
  109. LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
  110. BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
  111. IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
  112. MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
  113. ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
  114. 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
  115. POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
  116. ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
  117. COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
  118. "output_file"));ENDPROCEDURE;Unpacker;QUIT;
  119. $ delete/nolog 'f'*
  120. $ CHECKSUM 'P1'
  121. $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
  122. $ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
  123. $ ENDSUBROUTINE
  124. $START:
  125. $ create 'f'
  126. X$ vfl = f$VERIFY(0+f$trnlnm("debug$dcl"))
  127. X$! do LASTMONTH, NEXTMONTH, THISYEAR, NEXTYEAR, LASTYEAR
  128. X$! p1 -- keyword`20
  129. X$! p2 -- global symbol to pass value to
  130. X$! p3 -- target date to use as input
  131. X$! p4 -- week type: GE /HARRIS
  132. X$ p3 = f$cvtime(p3,"absolute","date")
  133. X$ VALID_KEYWORDS = ",THISMONTH,LASTMONTH,NEXTMONTH,THISYEAR,NEXTYEAR,LASTYEA
  134. VR"
  135. X$ valid_keywords = valid_keywords+",THISWEEK,NEXTWEEK,LASTWEEK"
  136. X$ if f$LOC(","+p1,valid_keywords).lt.f$LEN(valid_keywords) then $ goto 'p1'
  137. X$ write sys$output "%CVTIME-E-INVKEYWORD, ",p1," is an invalid keyword"
  138. X$ exit "%X00038060"
  139. X$NEXTMONTH:
  140. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
  141. X$ time = f$CVTIME("1-"+p3+"-"+"+32-0","ABSOLUTE","DATE")
  142. X$ time = "1-"+f$cvtime(time,"absolute","month")+"-"+f$cvtime(time,"absolute"
  143. V,"year")
  144. X$ goto exit
  145. X$THISMONTH:
  146. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
  147. X$ time = f$CVTIME("1-"+p3+"-","ABSOLUTE","DATE")
  148. X$ goto exit
  149. X$LASTMONTH:
  150. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
  151. X$ last_month = "1-"+p3+"-:-1-0:"
  152. X$ time = "1-"+f$CVTIME(last_month,"ABSOLUTE","MONTH")+"-"+ -
  153. X`09f$CVTIME(last_month,"ABSOLUTE","YEAR")
  154. X$ goto exit
  155. X$LASTYEAR:
  156. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","year")
  157. X$ last_year = "1-JAN-"+p3+":-1-0:"
  158. X$ time = "1-JAN-"+f$CVTIME(last_year,"ABSOLUTE","YEAR")
  159. X$ goto exit
  160. X$THISYEAR:
  161. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","YEAR")
  162. X$ time = f$CVTIME("1-JAN-"+p3,"ABSOLUTE","DATE")
  163. X$ goto exit
  164. X$NEXTYEAR:
  165. X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","YEAR")
  166. X$ time = f$CVTIME("31-DEC-"+p3+":+1-0:","ABSOLUTE","DATE")
  167. X$ goto exit
  168. X$EXIT:
  169. X$ if p2.nes."" then $ 'p2' == time
  170. X$ if p2.eqs."" then $ write sys$output "CVTIME: ",p1," = ",time
  171. X$ exit !'f$VER(vfl)'
  172. X$THISWEEK: ! Monday is beginning of week
  173. X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
  174. X$then
  175. X$ sunday = 1
  176. X$ monday = 2
  177. X$ tuesday = 3
  178. X$ wednesday = 4
  179. X$ thursday = 5
  180. X$ friday = 6
  181. X$ saturday = 0
  182. X$else
  183. X$ sunday = 6
  184. X$ monday = 0
  185. X$ tuesday = 1
  186. X$ wednesday = 2
  187. X$ thursday = 3
  188. X$ friday = 4
  189. X$ saturday = 5
  190. X$endif
  191. X$ today = 'f$CVTIME(p3,,"WEEKDAY")'
  192. X$ time = f$CVTIME(p3+":0:0:0.0-"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
  193. X$ goto exit
  194. X$NEXTWEEK: ! Monday is beginning of week
  195. X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
  196. X$then
  197. X$ sunday = 1
  198. X$ monday = 2
  199. X$ tuesday = 3
  200. X$ wednesday = 4
  201. X$ thursday = 5
  202. X$ friday = 6
  203. X$ saturday = 0
  204. X$else
  205. X$ sunday = 6
  206. X$ monday = 0
  207. X$ tuesday = 1
  208. X$ wednesday = 2
  209. X$ thursday = 3
  210. X$ friday = 4
  211. X$ saturday = 5
  212. X$endif
  213. X$ today = 7-'f$CVTIME(p3,,"WEEKDAY")'
  214. X$ time = f$CVTIME(p3+":0:0:0.0+"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
  215. X$ goto exit
  216. X$LASTWEEK: ! Monday is beginning of week
  217. X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
  218. X$then
  219. X$ sunday = 1
  220. X$ monday = 2
  221. X$ tuesday = 3
  222. X$ wednesday = 4
  223. X$ thursday = 5
  224. X$ friday = 6
  225. X$ saturday = 0
  226. X$else
  227. X$ sunday = 6
  228. X$ monday = 0
  229. X$ tuesday = 1
  230. X$ wednesday = 2
  231. X$ thursday = 3
  232. X$ friday = 4
  233. X$ saturday = 5
  234. X$endif
  235. X$ today = 7+'f$CVTIME(p3,,"WEEKDAY")'
  236. X$ time = f$CVTIME(p3+":0:0:0.0-"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
  237. X$ goto EXIT
  238. X$!Last Modified:  29-JUN-1989 17:09:29.50, By: RLB`20
  239. $ CALL UNPACK CVTIME.COM;1 2137918295
  240. $ create 'f'
  241. X$!Last Modified:  6-JUL-1992 12:33:46 by RFORSTER : DAYMONTH.COM
  242. X$ vfl = f$ver(0)
  243. X$! determine days in this month
  244. X$! and month_day, month_name, and year
  245. X$`20
  246. X$ time = ""
  247. X$ if p1.nes."" then   time = p1
  248. X$ if time.eqs."" then time = f$time()
  249. X$ month_day  == f$extract(0,2,time)
  250. X$ month_name == f$extract(3,3,time)
  251. X$ year       == f$extract(7,4,time)
  252. X$ other_time = f$cvtime(time)
  253. X$ month_number == f$extract(5,2,other_time)
  254. X$ cvttime = "$sys_utilities:time"
  255. X$ cvttime/sym=tmp LASTMONTH(+)0-0:
  256. X$ i1 = f$loc(":",tmp)
  257. X$ tmp = f$ext(0,i1,tmp)+" "+f$ext(i1+1,999,tmp)
  258. X$ prev_month_name == f$extract(3,3,tmp)
  259. X$ prev_year       == f$extract(7,4,tmp)
  260. X$ other_time      = f$cvtime(tmp)
  261. X$ prev_month_no   == f$extract(5,2,other_time)
  262. X$ cvttime/sym=tmp THISMONTH(-)1-0:
  263. X$ prev_month_days == f$extract(0,2,tmp)
  264. X$ exit ! 'f$ver(vfl)'
  265. $ CALL UNPACK DAYMONTH.COM;2 40240505
  266. $ create 'f'
  267. X!Last Modified:   3-JUN-1992 14:04:48.77, By: DECMCC`20
  268. X
  269. Xolb_elements = -
  270. X`09time,-
  271. X`09timeget,-
  272. X`09timecnv,-
  273. X`09timecur,-
  274. X`09timekey,-
  275. X`09timeediv,-
  276. X        timeemul,-
  277. X`09get_string,-
  278. X`09lib_nargs,-
  279. X`09jpi_logintim=jpilgintm.obj,-
  280. X`09q_string,-
  281. X`09tabs_to_blanks=tabs2blnk.obj,-
  282. X`09time_messages`20
  283. X
  284. X!.obj.olb :`09!
  285. X!`09@ IF F$SEARCH(F$PARSE("$(MMS$TARGET)")).nes.F$SEARCH("$(MMS$TARGET)") -
  286. X!`09  Then $ copy/log $(MMS$TARGET) $(MMS$TARGET)
  287. X!`09@ if f$search("$(mms$target)").eqs."" then $ $(libr)/create $@
  288. X!`09$(libr) $(librflags) $(MMS$TARGET) $(MMS$SOURCE)
  289. X!
  290. Xtime.exe : time.olb($(OLB_elements))`20
  291. X`09$ set noon
  292. X`09$ pURGE = ""
  293. X`09$ LINK/NODEBUG/NOTRACE/exe=$@  -
  294. X`09`09time.olb/inc=(TIME,time_messages),-
  295. X`09`09time.olb/lib !`20
  296. X`09$ purge *.obj,*.exe
  297. X
  298. Xtime.olb : time.olb($(OLB_elements))
  299. X
  300. Xkit_elements = GET_STRING.FOR,  JPILGINTM.FOR, Q_STRING.FOR, -
  301. XTABS2BLNK.FOR, TIME.FOR, TIMECNV.FOR, TIMECUR.FOR, TIMEGET.FOR, -
  302. XTIMEKEY.FOR, LIB_NARGS.MAR, TIMEEDIV.MAR, TIMEEMUL.MAR, -
  303. XTIME_MESSAGES.MSG, DESCRIP.MMS, CVTIME.COM, DAYMONTH.COM, -
  304. XTEST.COM, TIME.HLP
  305. X
  306. Xtime_kit : $(kit_elements)
  307. X        $ set noon
  308. X        $ mftu = "$utl_root:`5Bmftu`5Dmftu "
  309. X        $ kit_list = f$edit("$(kit_elements)","collapse,trim")
  310. X        $ mftu pack 'kit_list'/output=time_kit.pack
  311. X        $ mftu encode time_kit.pack/output=time_kit.mftu_encoded
  312. X        $ @utl:vms_share 'kit_list' time_kit
  313. $ CALL UNPACK DESCRIP.MMS;1 55479058
  314. $ create 'f'
  315. XC   ------------------------------------------------------------------------
  316. V---
  317. XC   GETSTRING.FOR - The function of this routine is to find the next charact
  318. Ver
  319. XC`09string and return pointers to the First and Last characters of the
  320. XC`09string.
  321. XC   ------------------------------------------------------------------------
  322. V---
  323. XC
  324. X`09INTEGER*4 FUNCTION GET_STRING ( STRING, FIRST, LAST )
  325. XC
  326. X`09IMPLICIT INTEGER*4 (A-Z)
  327. XC
  328. X`09EXTERNAL`09SS$_NORMAL
  329. XC
  330. X`09PARAMETER`09BLANK=' '
  331. XC
  332. X`09CHARACTER`09STRING*(*)
  333. XC
  334. X`09INTEGER*4`09FIRST, LAST, TMP
  335. XC   ------------------------------------------------------------------------
  336. V---
  337. XC
  338. XC   Translate all tabs to blanks.
  339. XC
  340. X`09STATUS = TABS_TO_BLANKS ( STRING, STRING )
  341. XC
  342. XC   Find the beginning of the string.
  343. XC
  344. X`09GET_STRING = %LOC(SS$_NORMAL)
  345. X`09STRING_S = LEN( STRING )
  346. XC
  347. X`09FIRST = LAST + 1
  348. X`09TMP = LIB$SKPC ( BLANK, STRING(FIRST:STRING_S) ) + (FIRST-1)
  349. X`09IF ( TMP .EQ. (FIRST-1) ) THEN
  350. X`09`09GET_STRING = 0
  351. X`09END IF
  352. X`09FIRST = TMP
  353. XC
  354. XC   Find the end of the string.
  355. XC
  356. X`09LAST = INDEX ( STRING(FIRST:STRING_S), BLANK ) + (FIRST-1)
  357. X`09IF ( LAST .EQ. (FIRST-1) ) LAST = STRING_S + 1
  358. X`09LAST = LAST - 1
  359. XC
  360. XC   Return
  361. XC
  362. X`09RETURN
  363. X`09END
  364. $ CALL UNPACK GET_STRING.FOR;1 185589850
  365. $ create 'f'
  366. XC   ------------------------------------------------------------------------
  367. V---
  368. XC   JPILGINTM.FOR - The function of this routine is return the time that the
  369. XC`09the current process logged in to the system as a character string.
  370. XC
  371. XC`09dd-mmm-yyyy:hh:mm:ss.cc
  372. XC   ------------------------------------------------------------------------
  373. V---
  374. X`09CHARACTER*(*) FUNCTION JPI_LOGINTIM ( LOGINTIM, LOGINTIM_S )
  375. XC
  376. X`09IMPLICIT INTEGER*4 (A-Z)
  377. XC
  378. X`09PARAMETER`09ITEMLIST_2Z=8
  379. X`09PARAMETER`09ITEMLIST_4Z=ITEMLIST_2Z/2
  380. X`09PARAMETER`09BLANK=' ', COLON=':'
  381. XC
  382. X`09INTEGER*4`09LOGINTIM(2), LOGINTIM_S
  383. XC
  384. X`09INTEGER*2`09ITEMLIST_2(ITEMLIST_2Z)
  385. X`09INTEGER*4`09ITEMLIST_4(ITEMLIST_4Z)
  386. XC
  387. X`09EQUIVALENCE`09(ITEMLIST_2, ITEMLIST_4)
  388. XC
  389. X`09INCLUDE`09'SYS$LIBRARY:FORSYSDEF($JPIDEF)/NOLIST'
  390. XC
  391. XC   ------------------------------------------------------------------------
  392. V---
  393. XC`09`09      ITEMLIST
  394. XC`09+----------------+----------------+
  395. XC`09: JPI$_LOGINTIM  :        8       :
  396. XC`09+----------------+----------------+
  397. XC`09:        ADDRESS OF BUFFER        :
  398. XC`09+----------------+----------------+
  399. XC`09:                0                :
  400. XC`09+----------------+----------------+
  401. XC`09:                0                :
  402. XC`09+----------------+----------------+
  403. XC   ------------------------------------------------------------------------
  404. V---
  405. XC
  406. XC   Build the Item list.
  407. XC
  408. X`09ITEMLIST_2(1) = 8
  409. X`09ITEMLIST_2(2) = JPI$_LOGINTIM
  410. XC
  411. X`09ITEMLIST_4(2) = %LOC(LOGINTIM)
  412. X`09ITEMLIST_4(3) = 0
  413. X`09ITEMLIST_4(4) = 0
  414. XC
  415. XC   Get the processes login time.
  416. XC
  417. X`09STATUS = SYS$GETJPI (,,,ITEMLIST_4,,,)
  418. XC
  419. XC   Format for return.
  420. XC
  421. X`09LOGINTIM_S = LEN( JPI_LOGINTIM )
  422. X`09STATUS = SYS$ASCTIM`20
  423. X`091`09( LOGINTIM_S, JPI_LOGINTIM(1:LOGINTIM_S), LOGINTIM, )
  424. XC
  425. X`09JPI_LOGINTIM(12:12) = COLON
  426. XC
  427. XC   Return.
  428. XC
  429. X`09RETURN
  430. X`09END
  431. $ CALL UNPACK JPILGINTM.FOR;1 2068076096
  432. $ create 'f'
  433. X;Last Modified:  14-MAY-1990 20:14:56.49, By: RLB`20
  434. X`09.title lib_nargs
  435. X;
  436. X;  Count the number of arguments of a subroutine/function
  437. X;
  438. X`09.ENTRY`09LIB_NARGS,`5EM<>
  439. X; get the previous frame pointer
  440. X`09MOVZBL`09@B`5E8(FP),R0
  441. X`09TSTB`09(AP)
  442. X; If there's no previous caller then return
  443. X`09BEQL`09$10
  444. X`09TSTL`09B`5E4(AP)
  445. X; If there's no arguments then return
  446. X`09BEQL`09$10
  447. X`09MOVL`09R0,@B`5E4(AP)
  448. X$10:
  449. X`09RET
  450. X;
  451. X;  See if 2 arguments are same or different
  452. X;
  453. X`09.ENTRY`09LIB_TST_ARG_DFT,`5EM<R2>
  454. X`09CLRL`09R0
  455. X`09MOVL`09B`5E8(FP),R1
  456. X`09MOVZBL`09@B`5E4(AP),R2
  457. X`09CMPB`09R2,(R1)
  458. X`09BGTRU`09$20
  459. X`09TSTL`09(R1)`5BR2`5D
  460. X`09BEQL`09$20
  461. X`09MCOML`09S`5E#0,R0
  462. X$20:
  463. X`09RET
  464. X`09.END
  465. $ CALL UNPACK LIB_NARGS.MAR;1 1129670880
  466. $ create 'f'
  467. X`09INTEGER*4 FUNCTION Q_STRING
  468. X`091`09( STRING, QUALIFIER, ABBREV_S, QUAL_STRING, QUAL_STR_S )
  469. XC   ------------------------------------------------------------------------
  470. V---
  471. XC   Q_STRING - The function of this subroutine is to search the specified
  472. XC`09string for the specified slash qualifier.  If a match is found the
  473. XC`09qualifier is removed from the string and replaced with blanks.  If`20
  474. XC`09there was a string attached to the qualifier (via '=' or ':'), then
  475. XC`09the qualifier string is returned.
  476. XC
  477. XC`09If mulitple occurences of the qualifier appear in the passed string
  478. XC`09then the last occurence will be returned and the previous entries
  479. XC`09blanked out.
  480. XC
  481. XC`09It is assumed that the qualifier has a negative value associated with
  482. XC`09it, which is be express as /NOqualifier.  This form of the qualifier
  483. XC`09is also considered a match and proper status to indicate if positive
  484. XC`09or negative response was returned.
  485. XC
  486. XC`09If an ambiguous qualifier is found (abbreviation match but wrong`20
  487. XC`09spelling after abbrev limit) an ambiguous error status is returned,
  488. XC`09the entire qualifier string and substring are returned in the qualifier
  489. XC`09string return parameter, and the ambiguous qualifier is blanked from
  490. XC`09the input string.
  491. XC
  492. XC`09  Input string:
  493. XC`09    rrrrrrrrrrrrrrrr/QUALIFIER=QUAL_STRING rrrrrrrrrrrrrrrr
  494. XC`09  Qutput string:
  495. XC`09    RRRRRRRRRRRRRRRR                       RRRRRRRRRRRRRRRR
  496. XC
  497. XC`09Special Note:  The input string will be translated to all upper case
  498. XC`09`09       and all tabs will be replaced with a single blank.
  499. XC
  500. XC   Calling Procedure:
  501. XC
  502. XC`09status = Q_STRING
  503. XC`091`09( string, qualifier, abbrev_size, qual_string `5B,qual_str_s`5D )
  504. XC
  505. XC   Entry Conditions:
  506. XC
  507. XC`09string - must be the address of a string descriptor which contains
  508. XC`09`09the input string to be scanned for the qualifier.  String will
  509. XC`09`09be translated to upper case and all tabs will be replaced with
  510. XC`09`09a single blank.  Any qualifiers found will be blanked out of
  511. XC`09`09the string.
  512. XC
  513. XC`09qualifier - must be the address of a string descriptor which contains
  514. XC`09`09the qualifier (including the '/').  The qualifier must be
  515. XC`09`09passed as an upper case string.
  516. XC
  517. XC`09abbrev_size - must be the address of a numeric value (integer*4) which
  518. XC`09`09specifies how many characters of the qualifier are required
  519. XC`09`09to make a match.
  520. XC
  521. XC   Exit conditions:
  522. XC
  523. XC`09qual_string - Must be the address of a string descriptor pointing to
  524. XC`09`09a string storage area large enough to hold the qualifier
  525. XC`09`09associated string value.  The string associated with the
  526. XC`09`09qualifier will be stored there if it is found.
  527. XC
  528. XC`09`09If an ambiguous qualifier is found both the qualifier and`20
  529. XC`09`09the qualifier string will be returned in this parameter.
  530. XC
  531. XC`09qual_str_s - Optional address of an Integer*4 variable where the
  532. XC`09`09length of the qual_string stored will be returned.
  533. XC
  534. XC`09status - will contain the completion status of the function.
  535. XC`09`09= 0 -- qualifier not found.
  536. XC`09`09= 1 -- good completion; qualifier string returned.
  537. XC`09`09= 2 -- ambiguous qualifier found.  The entire qualifier and`20
  538. XC`09`09       qualifier string are returned in the qualifier string
  539. XC`09`09       return parameter.
  540. XC`09`09= 3 -- qualifier found; no qualifier string available to`20
  541. XC`09`09       return.
  542. XC`09`09= 11 - good completion; negative form of qualifier w/qualifier
  543. XC`09`09       string returned.
  544. XC`09`09= 13 - negative form of qualifier found; no qualifier string
  545. XC`09`09       available to return.
  546. XC
  547. XC   ------------------------------------------------------------------------
  548. V---
  549. XC
  550. X`09IMPLICIT INTEGER*4 (A-Z)
  551. XC
  552. X`09PARAMETER`09NEG_QUAL_Z=67`09`09! Maximum number of characters
  553. XC`09`09`09`09`09`09!  allowed in the negative form
  554. XC`09`09`09`09`09`09!  of the qualifier including
  555. XC`09`09`09`09`09`09!  the '/'.
  556. XC
  557. X`09CHARACTER`09STRING*(*)`09`09! Input string to search.
  558. X`09CHARACTER`09QUALIFIER*(*)`09`09! Positive form of qualifier`20
  559. XC`09`09`09`09`09`09!  passed as input to search
  560. XC`09`09`09`09`09`09!  the input string for.  This
  561. XC`09`09`09`09`09`09!  must include the '/' at the
  562. XC`09`09`09`09`09`09!  beginning.
  563. X`09CHARACTER`09QUAL_STRING*(*)`09`09! Return parameter where the
  564. XC`09`09`09`09`09`09!  qualifier string is returned
  565. XC
  566. X`09CHARACTER`09NEG_QUAL*(NEG_QUAL_Z)`09! Temp string used to form the
  567. XC`09`09`09`09`09`09!  the negative form of the
  568. XC`09`09`09`09`09`09!  qualifier ('/NOqualifier').
  569. XC
  570. X`09INTEGER*4`09ABBREV_S`09`09! Number of characters in the
  571. XC`09`09`09`09`09`09!  qualifier which must be`20
  572. XC`09`09`09`09`09`09!  present to indicate a match
  573. XC`09`09`09`09`09`09!  This includes the '/'.
  574. XC
  575. X`09INTEGER*4`09STATUS`09`09`09! General return status area.
  576. X`09INTEGER*4`09Q_STRING_NEG`09`09! 1/2 of return status.  used
  577. XC`09`09`09`09`09`09!  to indicate that a negative
  578. XC`09`09`09`09`09`09!  form of the qualifier was
  579. XC`09`09`09`09`09`09!  found.  later added to
  580. XC`09`09`09`09`09`09!  Q_STRING_TMP
  581. X`09INTEGER*4`09Q_STRING_TMP`09`09! 1/2 of return status.  used
  582. XC`09`09`09`09`09`09!  to indicate if qualifier
  583. XC`09`09`09`09`09`09!  was found and if qualifier
  584. XC`09`09`09`09`09`09!  string was returned.
  585. X`09INTEGER*4`09P1, P2`09`09`09! Substring pointers used to
  586. XC`09`09`09`09`09`09!  isolate the qualifier
  587. XC`09`09`09`09`09`09!  return string.
  588. X`09INTEGER*4`09Q1, Q2, Q3`09`09! Substring pointers used to
  589. XC`09`09`09`09`09`09!  indicate the beginning of
  590. XC`09`09`09`09`09`09!  found qualifier, the end
  591. XC`09`09`09`09`09`09!  of the found qualifier, and
  592. XC`09`09`09`09`09`09!  the end of the qualifer`20
  593. XC`09`09`09`09`09`09!  return string.
  594. X`09INTEGER*4`09N1`09`09`09! Substring pointer to indicate
  595. XC`09`09`09`09`09`09!  the location of a found`20
  596. XC`09`09`09`09`09`09!  negative form of the`20
  597. XC`09`09`09`09`09`09!  qualifer.
  598. XC
  599. XC   ------------------------------------------------------------------------
  600. V---
  601. XC
  602. XC   Translate all characters to upper case.
  603. XC
  604. X`09STATUS = STR$UPCASE( STRING, STRING )
  605. XC
  606. XC   Initialize return status.
  607. XC
  608. X`09Q_STRING = 0
  609. XC
  610. XC   Determine how many return qualifiers have been passed and init return ar
  611. Vgs
  612. XC
  613. X`09ARGS = LIB_NARGS()
  614. X`09IF ( ARGS .GE. 5 ) THEN
  615. X`09    QUAL_STR_S = 0
  616. X`09ENDIF
  617. X`09QUAL_STRING = ' '
  618. XC
  619. XC   ------------------------------------------------------------------------
  620. V---
  621. XC
  622. XC   Determine what the negative form of the qualifier looks like.
  623. XC
  624. X`09Q_S = LEN( QUALIFIER )
  625. XC
  626. XC   If qualifier is only 1 char long; form negative as '/NO'
  627. XC
  628. X`09IF ( Q_S .EQ. 1 ) THEN
  629. X`09    NEG_QUAL = QUALIFIER(1:1) // 'NO'
  630. XC
  631. XC   If qualifier is too large to fit negative form tmp space; build to fit.
  632. XC
  633. X`09ELSEIF ( Q_S .GT. (NEG_QUAL_Z - 2) ) THEN
  634. X`09`09NEG_QUAL = QUALIFIER(1:1) // 'NO' // QUALIFIER(2:NEG_QUAL_Z-2)
  635. XC
  636. XC   Build negative form of qualifier using entier passed qualifier.
  637. XC
  638. X`09ELSE
  639. X`09`09NEG_QUAL = QUALIFIER(1:1) // 'NO' // QUALIFIER(2:Q_S)
  640. X`09ENDIF
  641. XC
  642. XC   ------------------------------------------------------------------------
  643. V---
  644. XC
  645. XC   Establish the loop to find all occurences of the qualifier.
  646. XC
  647. X`09DO WHILE (.TRUE.)
  648. X`09    Q_STRING_TMP = 0`09`09`09`09! Init 1/2 rtn status
  649. X`09    Q_STRING_NEG = 0`09`09`09`09! Init 1/2 rtn status
  650. XC
  651. XC`09  Determine if there are any occurences of the qualifier in the string.
  652. XC
  653. X`09    Q1 = INDEX( STRING, QUALIFIER(1:ABBREV_S) )`09`09! check pos
  654. X`09    N1 = INDEX( STRING, NEG_QUAL(1:ABBREV_S+2) )`09! check neg
  655. XC
  656. XC`09  If neither positive form or negative form; exit loop and return.
  657. XC
  658. X`09    IF ( (Q1 + N1) .EQ. 0 ) GOTO 1999
  659. XC
  660. XC`09  Determine if the string is positive or negative form of qualifier.
  661. XC
  662. X`09    IF ( Q1 .EQ. 0 ) Q1 = 99999999
  663. X`09    IF ( N1 .EQ. 0 ) N1 = 99999999
  664. X`09    IF ( Q1 .GT. N1 ) THEN
  665. X`09`09Q_STRING_NEG = 10`09`09`09! set return status
  666. X`09`09Q1 = N1`09`09`09`09`09! store start loc
  667. X`09    ENDIF
  668. XC
  669. XC`09  Isolate the qualifier ( space, tab, '/', end-of-string).
  670. XC
  671. X`09    Q3 = Q1 - 1
  672. X`09    STATUS = GET_STRING( STRING, Q1, Q3 )   ! look for space, tab, eol
  673. X`09    Q2 = INDEX( STRING(Q1+1:Q3), QUALIFIER(1:1) ) ! look for '/'
  674. XC
  675. XC`09  Determine if '/' or space,tab,eol is first found.
  676. XC
  677. X`09    IF ( Q2 .NE. 0 ) THEN
  678. X`09`09    Q2 = Q2 + Q1
  679. X`09`09    IF ( Q2 .LT. Q3 ) THEN
  680. X`09`09`09    Q3 = Q2 - 1
  681. X`09`09    ENDIF
  682. X`09    ENDIF
  683. XC
  684. XC`09  See if the qualifier has a value attached.
  685. XC
  686. X`09    P1 = INDEX( STRING(Q1:Q3), '=' )`09! look for '='
  687. X`09    P2 = INDEX( STRING(Q1:Q3), ':' )`09! look for ':'
  688. X`09    IF ( P1 .EQ. 0 ) P1 = P2`09`09! adjust for '=' not found
  689. X`09    IF ( P2 .EQ. 0 ) P2 = P1`09`09! adjust for ':' not found
  690. X`09    P1 = MIN( P1, P2 )`09`09`09! determine which is closest.
  691. X`09    IF ( P1 .NE. 0 ) THEN`09`09! see if either found
  692. X`09`09P1 = P1 + (Q1-1)`09`09! calc delimiter loc in string
  693. X`09`09P2 = Q3`09`09`09`09! get end string position
  694. X`09`09Q2 = P1 - 1`09`09`09! calc end of qualifier
  695. X`09`09P1 = P1 + 1`09`09`09! calc begin qual str loc.
  696. X`09`09IF ( P1 .GT. P2 ) THEN`09`09! if no string, then
  697. X`09`09    Q_STRING_TMP = 3`09`09!   set return status w/no str
  698. X`09`09ELSE`09`09`09`09! else
  699. X`09`09    Q_STRING_TMP = 1`09`09!   set return status w/string
  700. X`09`09ENDIF`09`09`09`09! endif
  701. X`09    ELSE`09
  702. XC
  703. XC`09      No string attached to qualifier; no string to return.
  704. XC
  705. X`09`09Q2 = Q3`09`09`09`09! set end of qualifier loc
  706. X`09`09Q_STRING_TMP = 3`09`09! set return status w/ no str
  707. X`09    ENDIF
  708. XC
  709. XC`09  Verify that the qualifier matches the spelling.
  710. XC
  711. X`09    IF ( Q_STRING_NEG .EQ. 0 ) THEN
  712. X`09`09IF ( STRING(Q1:Q2) .NE. QUALIFIER(1:Q2-Q1+1) ) THEN
  713. X`09`09    Q_STRING_TMP = 2
  714. X`09`09ENDIF
  715. X`09    ELSE
  716. X`09`09IF ( STRING(Q1:Q2) .NE. NEG_QUAL(1:Q2-Q1+1) ) THEN
  717. X`09`09    Q_STRING_TMP = 2
  718. X`09`09    Q_STRING_NEG = 0
  719. X`09`09ENDIF
  720. X`09    ENDIF
  721. XC
  722. XC`09  Store the associated qualifier string for return if present.
  723. XC
  724. X`09    IF ( Q_STRING_TMP .EQ. 1 ) THEN`09! If qual string found, then
  725. X`09`09QUAL_STRING = STRING(P1:P2)`09!   Store qualifier string.
  726. X`09`09Q_S_S = P2 - (P1-1)`09`09!   Store length of string.
  727. X`09    ELSEIF ( Q_STRING_TMP .EQ. 2 ) THEN ! If ambiguous qualifier,`20
  728. X`09`09QUAL_STRING = STRING(Q1:Q3)`09!   Store qual and qual str.
  729. X`09`09Q_S_S = Q3 - (Q1-1)`09`09!   Store length of string.
  730. X`09    ELSE`09`09`09`09! Else
  731. X`09`09QUAL_STRING = ' '`09`09!   Store blank.
  732. X`09`09Q_S_S = 0`09`09`09!   Store length zero.
  733. X`09    ENDIF
  734. XC
  735. XC`09  Store the length of the qualifier string.
  736. XC
  737. X`09    IF ( ARGS .GE. 5 ) THEN
  738. X`09`09QUAL_STR_S = Q_S_S
  739. X`09`09IF ( LEN( QUAL_STRING ) .LT. Q_S_S ) THEN
  740. X`09`09    QUAL_STR_S = LEN( QUAL_STRING )
  741. X`09`09ENDIF
  742. X`09    ENDIF
  743. XC
  744. XC`09  Remove the qualifier and qualifier string from the input string.
  745. XC
  746. X`09    STRING(Q1:Q3) = ' '
  747. XC
  748. XC`09  Update the return status.
  749. XC
  750. X`09    Q_STRING = Q_STRING_TMP + Q_STRING_NEG
  751. XC
  752. XC`09  If ambiguous string found exit from loop.
  753. XC
  754. X`09    IF ( Q_STRING_TMP .EQ. 2 ) GOTO 1999
  755. X`09ENDDO
  756. X1999`09CONTINUE
  757. XC
  758. XC   ------------------------------------------------------------------------
  759. V---
  760. XC
  761. XC   Return.
  762. XC
  763. X`09RETURN
  764. X`09END
  765. $ CALL UNPACK Q_STRING.FOR;1 1400278957
  766. $ create 'f'
  767. XC   ------------------------------------------------------------------------
  768. V---
  769. XC   TABS2BLNK.FOR - The function of this routine is to translate all tabs to
  770. XC`09to blanks using a translation table.
  771. XC   ------------------------------------------------------------------------
  772. V---
  773. X`09INTEGER*4 FUNCTION TABS_TO_BLANKS ( SOURCE, DESTINATION )
  774. XC
  775. X`09PARAMETER`09BLANK=' '
  776. XC
  777. X`09CHARACTER`09SOURCE*(*), DESTINATION*(*)
  778. XC
  779. X`09CHARACTER*(1)`09TBL_C(256)
  780. X`09BYTE`09`09TBL_B1(128)
  781. X`09BYTE`09`09TBL_B2(128)
  782. XC
  783. X`09EQUIVALENCE`09( TBL_C(1), TBL_B1(1) ), ( TBL_C(129), TBL_B2(1) )
  784. XC
  785. XC   ------------------------------------------------------------------------
  786. V---
  787. XC
  788. XC   Define the translation table.
  789. XC
  790. X`09DATA TBL_B1
  791. X`091 /'00'x, '01'x, '02'x, '03'x, '04'x, '05'x, '06'x, '07'x,`20
  792. X`092  '08'x, '20'x, '0A'x, '0B'x, '0C'x, '0D'x, '0E'x, '0F'x,`20
  793. X`093  '10'x, '11'x, '12'x, '13'x, '14'x, '15'x, '16'x, '17'x,`20
  794. X`094  '18'x, '19'x, '1A'x, '1B'x, '1C'x, '1D'x, '1E'x, '1F'x,`20
  795. X`095  '20'x, '21'x, '22'x, '23'x, '24'x, '25'x, '26'x, '27'x,`20
  796. X`096  '28'x, '29'x, '2A'x, '2B'x, '2C'x, '2D'x, '2E'x, '2F'x,`20
  797. X`097  '30'x, '31'x, '32'x, '33'x, '34'x, '35'x, '36'x, '37'x,`20
  798. X`098  '38'x, '39'x, '3A'x, '3B'x, '3C'x, '3D'x, '3E'x, '3F'x,`20
  799. X`099  '40'x, '41'x, '42'x, '43'x, '44'x, '45'x, '46'x, '47'x,`20
  800. X`099  '48'x, '49'x, '4A'x, '4B'x, '4C'x, '4D'x, '4E'x, '4F'x,`20
  801. X`091  '50'x, '51'x, '52'x, '53'x, '54'x, '55'x, '56'x, '57'x,`20
  802. X`092  '58'x, '59'x, '5A'x, '5B'x, '5C'x, '5D'x, '5E'x, '5F'x,`20
  803. X`093  '60'x, '61'x, '62'x, '63'x, '64'x, '65'x, '66'x, '67'x,`20
  804. X`094  '68'x, '69'x, '6A'x, '6B'x, '6C'x, '6D'x, '6E'x, '6F'x,`20
  805. X`095  '70'x, '71'x, '72'x, '73'x, '74'x, '75'x, '76'x, '77'x,`20
  806. X`096  '78'x, '79'x, '7A'x, '7B'x, '7C'x, '7D'x, '7E'x, '7F'x/
  807. XC
  808. X`09DATA TBL_B2
  809. X`091 /'80'x, '81'x, '82'x, '83'x, '84'x, '85'x, '86'x, '87'x,`20
  810. X`092  '88'x, '89'x, '8A'x, '8B'x, '8C'x, '8D'x, '8E'x, '8F'x,`20
  811. X`093  '90'x, '91'x, '92'x, '93'x, '94'x, '95'x, '96'x, '97'x,`20
  812. X`094  '98'x, '99'x, '9A'x, '9B'x, '9C'x, '9D'x, '9E'x, '9F'x,`20
  813. X`095  'A0'x, 'A1'x, 'A2'x, 'A3'x, 'A4'x, 'A5'x, 'A6'x, 'A7'x,`20
  814. X`096  'A8'x, 'A9'x, 'AA'x, 'AB'x, 'AC'x, 'AD'x, 'AE'x, 'AF'x,`20
  815. X`097  'B0'x, 'B1'x, 'B2'x, 'B3'x, 'B4'x, 'B5'x, 'B6'x, 'B7'x,`20
  816. X`098  'B8'x, 'B9'x, 'BA'x, 'BB'x, 'BC'x, 'BD'x, 'BE'x, 'BF'x,`20
  817. X`099  'C0'x, 'C1'x, 'C2'x, 'C3'x, 'C4'x, 'C5'x, 'C6'x, 'C7'x,`20
  818. X`099  'C8'x, 'C9'x, 'CA'x, 'CB'x, 'CC'x, 'CD'x, 'CE'x, 'CF'x,`20
  819. X`091  'D0'x, 'D1'x, 'D2'x, 'D3'x, 'D4'x, 'D5'x, 'D6'x, 'D7'x,`20
  820. X`092  'D8'x, 'D9'x, 'DA'x, 'DB'x, 'DC'x, 'DD'x, 'DE'x, 'DF'x,`20
  821. X`093  'E0'x, 'E1'x, 'E2'x, 'E3'x, 'E4'x, 'E5'x, 'E6'x, 'E7'x,`20
  822. X`094  'E8'x, 'E9'x, 'EA'x, 'EB'x, 'EC'x, 'ED'x, 'EE'x, 'EF'x,`20
  823. X`095  'F0'x, 'F1'x, 'F2'x, 'F3'x, 'F4'x, 'F5'x, 'F6'x, 'F7'x,`20
  824. X`096  'F8'x, 'F9'x, 'FA'x, 'FB'x, 'FC'x, 'FD'x, 'FE'x, 'FF'x/
  825. XC
  826. XC   ------------------------------------------------------------------------
  827. V---
  828. XC
  829. XC   Translate the string.
  830. XC
  831. X`09TABS_TO_BLANKS = LIB$MOVTC ( SOURCE, BLANK, TBL_C, DESTINATION )
  832. XC
  833. XC   Return
  834. XC
  835. X`09RETURN
  836. X`09END
  837. $ CALL UNPACK TABS2BLNK.FOR;1 621369641
  838. $ create 'f'
  839. X$ del/sym/loc/all
  840. X$ set noon
  841. X$ dir = f$environment("default")
  842. X$ cvttime = "$"+dir+"time"
  843. X$ del/sym/loc dir
  844. X$ cpu_d = 1
  845. X$ cpu_1 = f$getjpi("","cputim")
  846. X$ cvttime/sym=comp1  today(-)thisyear(/)7-0:(*)7
  847. X$ cvttime/sym=comp2  thisweek(-)thisyear(/)7-0:(*)1(*)1-0:
  848. X$ cvttime/sym=this_year THISYEAR(+)0-0:
  849. X$ cvttime/sym=lastmonth LASTMONTH(+)0-0:
  850. X$ cvttime/sym=nextmonth NEXTMONTH(+)0-0:
  851. X$ cvttime/sym=thismonth THISMONTH(+)0-0:
  852. X$ cvttime/sym=last_week LASTWEEK(+)0-0:
  853. X$ cvttime/sym=next_week NEXTWEEK(+)0-0:
  854. X$ cvttime/sym=this_week THISWEEK(+)0-0:
  855. X$ cvttime/sym=yesterday YESTERDAY(+)0-0:
  856. X$ cvttime/sym=to_morrow TOMORROW(+)0-0:
  857. X$ cvttime/sym=today_dat TODAY(+)0-0:
  858. X$ cpu_d = f$getjpi("","cputim")-cpu_1
  859. X$ del/sym/loc cvttime
  860. X$ show sym/loc/all
  861. X$ time_convert:
  862. X$   tmp_day = cpu_d/(24*360000)
  863. X$   tmp_hrs = cpu_d/360000-24*tmp_day
  864. X$   tmp_min = cpu_d/6000-60*(24*tmp_day+tmp_hrs)
  865. X$   tmp_sec = cpu_d/100-60*(60*(24*tmp_day+tmp_hrs)+tmp_min)
  866. X$   tmp_hun = cpu_d - 100*(60*(60*(24*tmp_day+tmp_hrs)+tmp_min)+tmp_sec)
  867. X$   cpu_d = f$fao("!2ZL-!2ZL:!2ZL:!2ZL.!2ZL",-
  868. X`09`09 tmp_day,tmp_hrs,tmp_min,tmp_sec,tmp_hun)
  869. X$ write sys$output "TIMETEST-I-CPUTIME, cpu time consumed:  ",cpu_d
  870. $ CALL UNPACK TEST.COM;1 2002140304
  871. $ create 'f'
  872. XC   ------------------------------------------------------------------------
  873. V---
  874. XC   TIME.FOR - The function of this program is to perform time calculations
  875. XC`09for the DCL user. The functions which may be performed are:
  876. XC
  877. XC`09TIME - This will return the current time and the user's connect time.
  878. XC`09TIME absolute_time - This will return the current time and the delta
  879. XC`09`09`09     between the current time and the absolute_time
  880. XC`09`09`09     specified.
  881. XC`09TIME abs_time (-) abs_time --> gives delta_time.
  882. XC`09TIME abs_time (+) delat_time --> gives abs_time.
  883. XC`09TIME abs_time (-) delta_time --> gives abs_time.
  884. XC`09TIME abs_time (=) abs_time --> 'YES' or 'NO'`09also (EQ)
  885. XC`09TIME abs_time (<>) abs_time --> 'YES' or 'NO'`09also (NE)
  886. XC`09TIME abs_time (<) abs_time --> 'YES' or 'NO'`09also (LT)
  887. XC`09TIME abs_time (>) abs_time --> 'YES' or 'NO'`09also (GT)
  888. XC`09TIME abs_time (<=) abs_time --> 'YES' or 'NO'`09also (LE)
  889. XC`09TIME abs_time (>=) abs_time --> 'YES' or 'NO'`09also (GE)
  890. XC`09TIME abs_time (?) abs_time --> gives:
  891. XC`09`09`09`09`09`09a 'GREATER_THAN' than b
  892. XC`09`09`09`09`09`09a 'LESS_THAN' than b
  893. XC`09`09`09`09`09`09a 'EQUAL_TO' to b
  894. XC`09TIME delta_time (+) delta_time --> gives delta_time.
  895. XC`09TIME delta_time (-) delta_time --> gives delta_time.
  896. XC`09TIME delta_time (=) delta_time --> gives 'YES' or 'NO'`09also (EQ)
  897. XC`09TIME delta_time (<>) delta_time --> gives 'YES' or 'NO'`09also (NE)
  898. XC`09TIME delta_time (<) delta_time --> gives 'YES' or 'NO'`09also (LT)
  899. XC`09TIME delta_time (>) delta_time --> gives 'YES' or 'NO'`09also (GT)
  900. XC`09TIME delta_time (<=) delta_time --> gives 'YES' or 'NO'`09also (LE)
  901. XC`09TIME delta_time (>=) delta_time --> gives 'YES' or 'NO'`09also (GE)
  902. XC`09TIME delta_time (?) delta_time --> gives:
  903. XC`09`09`09`09`09`09a 'GREATER_THAN' than b
  904. XC`09`09`09`09`09`09a 'LESS_THAN' than b
  905. XC`09`09`09`09`09`09a 'EQUAL_TO' to b
  906. XC`09TIME delta_time (/) delta_time --> gives integer
  907. XC`09TIME delta_time (/) integer --> gives delta_time
  908. XC`09TIME delta_time (*) integer --> gives delta_time
  909. XC
  910. XC`09TIME integer (+) integer --> integer
  911. XC`09TIME integer (-) integer --> integer
  912. XC`09TIME integer (/) integer --> integer
  913. XC`09TIME integer (*) integer --> integer
  914. XC
  915. XC   Input formats:
  916. XC
  917. XC`09The absolute time input format may be either:
  918. XC
  919. XC`09`09dd-mmm-yyyy hh:mm:ss.hh
  920. XC`09or
  921. XC`09`09dd-mmm-yyyy:hh:mm:ss.hh
  922. XC
  923. XC`09or one of the keywords:
  924. XC
  925. XC`09`09YESTERDAY, TODAY, TOMORROW, THISMONTH, NEXTMONTH, LASTMONTH
  926. XC`09`09THISYEAR, THISWEEK, NEXTWEEK, LASTWEEK
  927. XC
  928. XC`09The colon between the year and the hour is optional.
  929. XC
  930. XC`09The delta time input format may be:
  931. XC
  932. XC`09`09dddd-hh:mm:ss.hh
  933. XC
  934. XC`09The dash between the days and the hour is optional.
  935. XC
  936. XC`09The operators must may be:
  937. XC
  938. XC`09`09(+)`09addition
  939. XC`09`09(-)`09subtraction
  940. XC`09`09(*)`09multiplication
  941. XC`09`09(/)`09division
  942. XC`09`09(=)`09compare for equal to
  943. XC`09`09(<>)`09compare for not equal to
  944. XC`09`09(<)`09compare for less than
  945. XC`09`09(>)`09compare for greater than
  946. XC`09`09(<=)`09compare for less than or equal to
  947. XC`09`09(>=)`09compare for greater than or equal to
  948. XC`09`09(?)`09comparsion
  949. XC
  950. XC`09The () must be included.
  951. XC
  952. XC   Output formats:
  953. XC
  954. XC`09If no /SYMBOL=symbol option is given then the results are sent to
  955. XC`09SYS$OUTPUT, otherwise the result is returned in the local symbol
  956. XC`09specified.
  957. XC
  958. XC`09The absolute time returned will be in the following format:
  959. XC
  960. XC`09`09dd-mmm-yyyy:hh:mm:ss.hh
  961. XC
  962. XC`09The delta time returned will be in the following format:
  963. XC
  964. XC`09`09dddd-hh:mm:ss.hh
  965. XC
  966. XC`09The comparison values returned will be,
  967. XC
  968. XC`09    for (?):
  969. XC`09`09GREATER_THAN
  970. XC`09`09LESS_THAN
  971. XC`09`09EQUAL_TO
  972. XC
  973. XC`09    and for (=), (<>), (<), (>), (<=), (>=):
  974. XC`09`09YES
  975. XC`09`09NO
  976. XC`09`09
  977. XC   ------------------------------------------------------------------------
  978. V---
  979. XC
  980. XC V2.0`0923-Mar-83`09FJN`09Converted to using TIME__xxx condition codes
  981. XC`09`09`09`09from TIMEMSG.MSG file.  Added TIMEKEY with
  982. XC`09`09`09`09keyword time names.
  983. XC V2.1`0902-Apr-83`09FJN`09Added LASTMONTH and LASTWEEK keywords
  984. XC
  985. X`09PROGRAM TIME
  986. XC
  987. X`09IMPLICIT INTEGER*4 (A-Z)
  988. XC
  989. X`09EXTERNAL`09SS$_INTOVF
  990. X`09EXTERNAL`09SS$_IVTIME
  991. XC
  992. X`09PARAMETER`09PARAMZ=255
  993. X`09PARAMETER`09RESULTZ=64
  994. X`09PARAMETER`09SYMBOLZ=64
  995. X`09PARAMETER`09ABSZ=23
  996. X`09PARAMETER`09DELTAZ=16
  997. X`09PARAMETER`09DASH='-'
  998. X`09PARAMETER`09SLASH='/'
  999. X`09PARAMETER`09EQUAL='='
  1000. X`09PARAMETER`09COLON=':'
  1001. X`09PARAMETER`09BLANK=' '
  1002. X`09PARAMETER`09PLUS='(+)'
  1003. X`09PARAMETER`09MINUS='(-)'
  1004. X`09PARAMETER`09MULTIPLY='(*)'
  1005. X`09PARAMETER`09DIVIDE='(/)'
  1006. X`09PARAMETER`09QUESTION='(?)'
  1007. X`09PARAMETER`09EQUAL_TO='(=)'
  1008. X`09PARAMETER`09NOT_EQUAL='(<>)'
  1009. X`09PARAMETER`09LESS_THAN='(<)'
  1010. X`09PARAMETER`09LESS_THAN_EQUAL_TO='(<=)'
  1011. X`09PARAMETER`09GREATER_THAN='(>)'
  1012. X`09PARAMETER`09GREATER_THAN_EQUAL_TO='(>=)'
  1013. X`09PARAMETER`09SYM='SYM'
  1014. XC
  1015. XC
  1016. X`09CHARACTER`09TIMECUR*40`09! Function subroutine.
  1017. XC
  1018. X`09CHARACTER`09PARAM*(PARAMZ) /' '/
  1019. X`09CHARACTER`09RESULT*(RESULTZ) /' '/
  1020. X`09CHARACTER`09SYMBOL*(SYMBOLZ) /' '/
  1021. X`09CHARACTER`09ABS_C*(ABSZ)
  1022. X`09CHARACTER`09DELTA_C*(DELTAZ)
  1023. XC
  1024. X`09INTEGER*4`09ABS_S, DELTA_S
  1025. X`09INTEGER*4`09BIN_0(2) /0,0/
  1026. X`09INTEGER*4`09BIN_1(2)
  1027. X`09INTEGER*4`09BIN_2(2)
  1028. X`09INTEGER*4`09BIN_SCR(2)
  1029. X`09INTEGER*4`09STATUS, STATUS_1, STATUS_2
  1030. X`09INTEGER*4`09PARAM_S
  1031. X`09INTEGER*4`09RESULT_S
  1032. X`09INTEGER*4`09SYMBOL_S /0/
  1033. X`09INTEGER*4`09P1 /0/, P2 /0/
  1034. X`09INTEGER*4`09Q1 /0/, Q2 /0/
  1035. X`09INTEGER*4`09R1 /0/, R2 /0/
  1036. X`09INTEGER*4`09S1 /0/, S2 /0/
  1037. X`09INTEGER*4`09OP1_1, OP1_2
  1038. X`09INTEGER*4`09OP2_1, OP2_2
  1039. X`09INTEGER*4`09OP3_1, OP3_2
  1040. XC
  1041. XC   ------------------------------------------------------------------------
  1042. V---
  1043. XC
  1044. X`09EXTERNAL  TIME__INVABSTIM`09!invalid absolute time format
  1045. X`09EXTERNAL  TIME__INVADD`09`09!invalid add
  1046. X`09EXTERNAL  TIME__INVCMP`09`09!invalid compare
  1047. X`09EXTERNAL  TIME__INVDELTIM`09!invalid delta time format
  1048. X`09EXTERNAL  TIME__INVDIV`09`09!invalid divide
  1049. X`09EXTERNAL  TIME__INVINT`09`09!invalid integer value format
  1050. X`09EXTERNAL  TIME__INVMUL`09`09!invalid multiply
  1051. X`09EXTERNAL  TIME__INVOPR`09`09!invalid operation
  1052. X`09EXTERNAL  TIME__INVSUB`09`09!invalid subtract
  1053. X`09EXTERNAL  TIME__MISPAR`09`09!time parameter missing
  1054. X`09EXTERNAL  TIME__OVRFLO`09`09!time calculation overflow
  1055. X`09EXTERNAL  TIME__TOOMNYOPR`09!too many operands
  1056. XC
  1057. XC   ------------------------------------------------------------------------
  1058. V---
  1059. XC
  1060. XC   Get the command line.
  1061. XC
  1062. X`09STATUS = LIB$GET_FOREIGN ( PARAM, , PARAM_S )
  1063. X`09IF (.NOT.status) CALL EXIT(status)
  1064. X`09STATUS = TABS_TO_BLANKS ( PARAM(1:PARAM_S), PARAM(1:PARAM_S) )
  1065. X`09IF (.NOT.status) CALL EXIT(status)
  1066. X`09STATUS = STR$UPCASE ( PARAM(1:PARAM_S), PARAM(1:PARAM_S) )
  1067. X`09IF (.NOT.status) CALL EXIT(status)
  1068. XC
  1069. XC   Scan for /DEBUG option.
  1070. XC
  1071. X`09DEBUG = Q_STRING( PARAM(1:PARAM_S), '/DEBUG', 4, SYMBOL )
  1072. XC
  1073. XC   Scan for /SYMBOL option.
  1074. XC
  1075. X`09SYMBOL_S = 0
  1076. X`09STATUS = Q_STRING( PARAM(1:PARAM_S), '/SYMBOL', 4, SYMBOL )
  1077. X`09IF ( STATUS .EQ. 1 ) THEN
  1078. X`09`09CALL STR$TRIM( SYMBOL, SYMBOL, SYMBOL_S )
  1079. X`09ENDIF
  1080. XC
  1081. XC   ------------------------------------------------------------------------
  1082. V---
  1083. XC
  1084. XC   Fetch the first parameter.
  1085. XC
  1086. X`09OP1_2 = 0
  1087. X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP1_1, OP1_2 )
  1088. X`09IF ( .NOT. STATUS ) THEN
  1089. XC
  1090. XC`09   No parameters specified; fetch the system time and connect time.
  1091. XC
  1092. X`09`09RESULT = TIMECUR ( BIN_0 )
  1093. X`09`09RESULT_S = LEN( RESULT )
  1094. X`09`09OP3_2 = OP1_2
  1095. X`09`09GOTO 1999
  1096. X`09ENDIF
  1097. XC
  1098. XC   Convert the first parameter into binary time format.
  1099. XC
  1100. X`09STATUS_1 = TIMECNV( PARAM(OP1_1:OP1_2), BIN_1 )
  1101. X`09IF ( STATUS_1 .EQ. 4 ) THEN
  1102. X`09`09CALL LIB$STOP(TIME__INVABSTIM)
  1103. X`09ELSEIF ( STATUS_1 .EQ. 6 ) THEN
  1104. X`09`09CALL LIB$STOP(TIME__INVDELTIM)
  1105. X`09ELSEIF ( STATUS_1 .EQ. 8 ) THEN
  1106. X`09`09CALL LIB$STOP(TIME__INVINT)
  1107. X`09ENDIF
  1108. XC
  1109. XC   ------------------------------------------------------------------------
  1110. V---
  1111. X      OP3_2 = OP1_2`09
  1112. X      LOOP = 0`09
  1113. X      DO WHILE (.TRUE.)`09
  1114. X`09LOOP = LOOP + 1
  1115. XC
  1116. XC   Fetch the next parameter (it should be an operator).
  1117. XC
  1118. X`09OP2_2 = OP3_2`09
  1119. X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP2_1, OP2_2 )
  1120. X`09IF ( .NOT. STATUS ) THEN
  1121. X`09`09IF ( LOOP .GT. 1 ) GOTO 1999`09
  1122. XC
  1123. XC`09   No operator present; do a delta time calculation with current time
  1124. XC`09`09and the first parameter already fetched.
  1125. XC
  1126. X`09`09IF ( STATUS_1 .NE. 3 ) THEN
  1127. X`09`09`09CALL LIB$STOP(TIME__INVABSTIM)
  1128. X`09`09ELSE
  1129. X`09`09`09RESULT = TIMECUR ( BIN_1 )
  1130. X`09`09`09RESULT_S = LEN( RESULT )
  1131. X`09`09`09GOTO 1999
  1132. X`09`09ENDIF
  1133. X`09ENDIF
  1134. XC
  1135. XC   ------------------------------------------------------------------------
  1136. V---
  1137. XC
  1138. XC   Fetch the last parameter (it should be present).
  1139. XC
  1140. X`09OP3_2 = OP2_2
  1141. X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP3_1, OP3_2 )
  1142. X`09IF ( .NOT. STATUS ) THEN
  1143. XC
  1144. XC`09   Third parameter must be present; error
  1145. XC
  1146. X`09`09CALL LIB$STOP(TIME__MISPAR)
  1147. X`09ENDIF
  1148. XC
  1149. XC   Convert the third parameter to binary time format.
  1150. XC
  1151. X`09STATUS_2 = TIMECNV( PARAM(OP3_1:OP3_2), BIN_2 )
  1152. X`09IF ( STATUS_2 .EQ. 4 ) THEN
  1153. X`09`09CALL LIB$STOP(TIME__INVABSTIM)
  1154. X`09ELSEIF ( STATUS_2 .EQ. 6 ) THEN
  1155. X`09`09CALL LIB$STOP(TIME__INVDELTIM)
  1156. X`09ELSEIF ( STATUS_1 .EQ. 8 ) THEN
  1157. X`09`09CALL LIB$STOP(TIME__INVINT)
  1158. X`09ENDIF
  1159. XC
  1160. XC   ------------------------------------------------------------------------
  1161. V---
  1162. XC
  1163. XC   Evaluate the operator and perform the necessary calculation.
  1164. XC
  1165. X`09IF ( PARAM(OP2_1:OP2_2) .EQ. PLUS ) THEN
  1166. XC
  1167. XC   ------------------------------------------------------------------------
  1168. V---
  1169. XC
  1170. XC`09   Add the two values together.
  1171. XC
  1172. X`09`09STATUS = LIB$ADDX( BIN_1, BIN_2, BIN_1, 2 )
  1173. X`09`09IF ( STATUS .EQ. %LOC(SS$_INTOVF) ) THEN
  1174. X`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1175. X`09`09ENDIF
  1176. XC
  1177. XC`09   Determine the output format and convert to the proper format.
  1178. XC
  1179. X`09`09A = STATUS_1 + STATUS_2
  1180. X`09`09S = STATUS_1 - STATUS_2
  1181. X`09`09IF ( A .EQ. 10 .AND. S .EQ. 0 ) THEN
  1182. XC
  1183. XC`09`09   Convert to delta time format.
  1184. XC
  1185. X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
  1186. X`09`09`09IF (.NOT.status) CALL EXIT(status)
  1187. X`09`09`09STATUS = SYS$ASCTIM
  1188. X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
  1189. X`09`09`09RESULT(5:5) = DASH
  1190. XC
  1191. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1192. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
  1193. XC
  1194. X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
  1195. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1196. X`09`09`09ENDIF
  1197. X`09`09`09STATUS_1 = 5
  1198. XC
  1199. X`09`09ELSEIF ( A .EQ. 8 ) THEN
  1200. XC
  1201. XC`09`09   Convert to absolute time format.
  1202. XC
  1203. X`09`09`09STATUS = SYS$ASCTIM
  1204. X`091`09`09`09( RESULT_S, RESULT, BIN_1, %VAL(0) )
  1205. X`09`09`09RESULT(12:12) = COLON
  1206. XC
  1207. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1208. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
  1209. XC
  1210. X`09`09`09STATUS_1 = 3
  1211. XC
  1212. X`09`09ELSEIF ( A .EQ. 14 ) THEN
  1213. XC
  1214. XC`09`09   Convert to integer time format.
  1215. XC
  1216. X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
  1217. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1218. X`09`09`09ENDIF`09`09`09
  1219. XC
  1220. X`09`09`09STATUS = OTS$CVT_L_TI
  1221. X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
  1222. X`09`09`09I = LIB$SKPC( BLANK, RESULT )
  1223. X`09`09`09RESULT = RESULT(I:)
  1224. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1225. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
  1226. X`09`09`09STATUS_1 = 7
  1227. XC
  1228. X`09`09ELSE
  1229. XC
  1230. XC`09`09   Invalid addition requested.
  1231. XC
  1232. X`09`09`09CALL LIB$STOP(TIME__INVADD)
  1233. X`09`09ENDIF
  1234. XC
  1235. XC   ------------------------------------------------------------------------
  1236. V---
  1237. XC
  1238. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. MINUS ) THEN
  1239. XC
  1240. XC`09   Subtract the two values.
  1241. XC
  1242. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_1, 2 )
  1243. X`09`09IF ( BIN_1(2) .LT. 0 ) THEN
  1244. X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_1, 2 )
  1245. X`09`09ENDIF
  1246. XC
  1247. XC`09   Perform the output conversion for display.
  1248. XC
  1249. X`09`09A = STATUS_1 + STATUS_2
  1250. X`09`09S = STATUS_1 - STATUS_2
  1251. X`09`09IF ( S .EQ. 0 .AND. ( A .EQ. 6 .OR. A .EQ. 10 ) ) THEN
  1252. XC
  1253. XC`09`09   Convert to delta time format.
  1254. XC
  1255. X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
  1256. X`09`09`09`09BIN_1(1) = '00000001'x
  1257. X`09`09`09ENDIF
  1258. XC
  1259. X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
  1260. X`09`09`09STATUS = SYS$ASCTIM
  1261. X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
  1262. X`09`09`09RESULT(5:5) = DASH
  1263. XC
  1264. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1265. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
  1266. XC
  1267. X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
  1268. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1269. X`09`09`09ENDIF
  1270. X`09`09`09STATUS_1 = 5
  1271. XC
  1272. X`09`09ELSEIF ( S .EQ. -2 .AND. A .EQ. 8 ) THEN
  1273. XC
  1274. XC`09`09   Convert to absolute time format.
  1275. XC
  1276. X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
  1277. X`09`09`09`09BIN_1(1) = '00000001'x
  1278. X`09`09`09ENDIF
  1279. XC
  1280. X`09`09`09STATUS = SYS$ASCTIM
  1281. X`091`09`09`09( RESULT_S, RESULT, BIN_1, %VAL(0) )
  1282. X`09`09`09RESULT(12:12) = COLON
  1283. XC
  1284. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1285. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
  1286. XC
  1287. X`09`09`09STATUS_1 = 3
  1288. XC
  1289. X`09`09ELSEIF ( A .EQ. 14 ) THEN
  1290. XC
  1291. XC`09`09   Convert to integer time format.
  1292. XC
  1293. X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
  1294. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1295. X`09`09`09ENDIF`09`09`09
  1296. XC
  1297. X`09`09`09STATUS = OTS$CVT_L_TI
  1298. X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
  1299. X`09`09`09I = LIB$SKPC( BLANK, RESULT )
  1300. X`09`09`09RESULT = RESULT(I:)
  1301. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1302. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
  1303. X`09`09`09STATUS_1 = 7
  1304. XC
  1305. X`09`09ELSE
  1306. XC
  1307. XC`09`09   Invalid subtraction requested.
  1308. XC
  1309. X`09`09`09CALL LIB$STOP(TIME__INVSUB)
  1310. X`09`09ENDIF
  1311. XC
  1312. XC   ------------------------------------------------------------------------
  1313. V---
  1314. XC
  1315. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. MULTIPLY ) THEN
  1316. XC
  1317. XC`09   Multiply the two values.
  1318. XC
  1319. X`09`09STATUS_M = TIMEEMUL( BIN_1, BIN_2, BIN_1 )
  1320. XC
  1321. XC`09   Determine the output format and convert to the proper format.
  1322. XC
  1323. X`09`09A = STATUS_1 + STATUS_2
  1324. X`09`09S = STATUS_1 - STATUS_2
  1325. X`09`09IF ( A .EQ. 12 ) THEN
  1326. XC
  1327. XC`09`09   Convert to delta time format.
  1328. XC
  1329. X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
  1330. X`09`09`09`09BIN_1(1) = '00000001'x
  1331. X`09`09`09ENDIF
  1332. XC
  1333. X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
  1334. X`09`09`09STATUS = SYS$ASCTIM
  1335. X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
  1336. X`09`09`09RESULT(5:5) = DASH
  1337. XC
  1338. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1339. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
  1340. XC
  1341. X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
  1342. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1343. X`09`09`09ENDIF
  1344. X`09`09`09STATUS_1 = 5
  1345. XC
  1346. X`09`09`09IF ( STATUS_M .EQ. 0 ) THEN
  1347. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1348. X`09`09`09ENDIF
  1349. XC
  1350. X`09`09ELSEIF ( A .EQ. 14 ) THEN
  1351. XC
  1352. XC`09`09   Convert to integer time format.
  1353. XC
  1354. X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
  1355. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1356. X`09`09`09ENDIF`09`09`09
  1357. XC
  1358. X`09`09`09STATUS = OTS$CVT_L_TI
  1359. X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
  1360. X`09`09`09I = LIB$SKPC( BLANK, RESULT )
  1361. X`09`09`09RESULT = RESULT(I:)
  1362. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1363. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
  1364. X`09`09`09STATUS_1 = 7
  1365. XC
  1366. X`09`09ELSE
  1367. XC
  1368. XC`09`09   Invalid multiplication requested.
  1369. XC
  1370. X`09`09`09CALL LIB$STOP(TIME__INVMUL)
  1371. X`09`09ENDIF
  1372. XC
  1373. XC   ------------------------------------------------------------------------
  1374. V---
  1375. XC
  1376. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. DIVIDE ) THEN
  1377. XC
  1378. XC`09   Divide the two values.
  1379. XC
  1380. X`09`09STATUS = TIMEEDIV( BIN_2, BIN_1, BIN_1, BIN_SCR )
  1381. XC
  1382. XC`09   Determine the output format and convert to the proper format.
  1383. XC
  1384. X`09`09A = STATUS_1 + STATUS_2
  1385. X`09`09S = STATUS_1 - STATUS_2
  1386. X`09`09IF ( A .EQ. 12 .AND. S .EQ. -2 ) THEN
  1387. XC
  1388. XC`09`09   Convert to delta time format.
  1389. XC
  1390. X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
  1391. X`09`09`09`09BIN_1(1) = '00000001'x
  1392. X`09`09`09ENDIF
  1393. XC
  1394. X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
  1395. X`09`09`09STATUS = SYS$ASCTIM
  1396. X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
  1397. X`09`09`09RESULT(5:5) = DASH
  1398. XC
  1399. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1400. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
  1401. XC
  1402. X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
  1403. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1404. X`09`09`09ENDIF
  1405. X`09`09`09STATUS_1 = 5
  1406. XC
  1407. X`09`09ELSEIF ( A .EQ. 14 .OR. ( A .EQ. 10 .AND. S .EQ. 0 ) ) THEN
  1408. XC
  1409. XC`09`09   Convert to integer time format.
  1410. XC
  1411. X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
  1412. X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
  1413. X`09`09`09ENDIF`09`09`09
  1414. XC
  1415. X`09`09`09STATUS = OTS$CVT_L_TI
  1416. X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
  1417. X`09`09`09I = LIB$SKPC( BLANK, RESULT )
  1418. X`09`09`09RESULT = RESULT(I:)
  1419. X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
  1420. X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
  1421. X`09`09`09STATUS_1 = 7
  1422. XC
  1423. X`09`09ELSE
  1424. XC
  1425. XC`09`09   Invalid division requested.
  1426. XC
  1427. X`09`09`09CALL LIB$STOP(TIME__INVDIV)
  1428. X`09`09ENDIF
  1429. XC
  1430. XC   ------------------------------------------------------------------------
  1431. V---
  1432. XC
  1433. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. QUESTION ) THEN
  1434. XC
  1435. XC`09   Compare the two operands.
  1436. XC
  1437. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
  1438. X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
  1439. X`09`09`09RESULT = 'LESS_THAN'
  1440. X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
  1441. X`09`09`09RESULT = 'EQUAL_TO'
  1442. X`09`09ELSE`20
  1443. X`09`09`09RESULT = 'GREATER_THAN'
  1444. X`09`09ENDIF
  1445. X`09`09GOTO 1999
  1446. XC
  1447. XC   ------------------------------------------------------------------------
  1448. V---
  1449. XC
  1450. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. EQUAL_TO .OR.
  1451. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(EQ)' ) THEN
  1452. XC
  1453. XC`09   Compare for equal.
  1454. XC
  1455. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
  1456. X`09`09IF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
  1457. X`09`09`09RESULT = 'YES'
  1458. X`09`09ELSE
  1459. X`09`09`09RESULT = 'NO'
  1460. X`09`09ENDIF
  1461. X`09`09GOTO 1999
  1462. XC
  1463. XC   ------------------------------------------------------------------------
  1464. V---
  1465. XC
  1466. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. NOT_EQUAL .OR.
  1467. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(NE)' ) THEN
  1468. XC
  1469. XC`09   Compare for not equal.
  1470. XC
  1471. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
  1472. X`09`09IF ( (BIN_SCR(2) + BIN_SCR(1)) .NE. 0 ) THEN
  1473. X`09`09`09RESULT = 'YES'
  1474. X`09`09ELSE
  1475. X`09`09`09RESULT = 'NO'
  1476. X`09`09ENDIF
  1477. X`09`09GOTO 1999
  1478. XC
  1479. XC   ------------------------------------------------------------------------
  1480. V---
  1481. XC
  1482. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. LESS_THAN .OR.
  1483. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(LT)' ) THEN
  1484. XC
  1485. XC`09   Compare for less than.
  1486. XC
  1487. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
  1488. X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
  1489. X`09`09`09RESULT = 'YES'
  1490. X`09`09ELSE
  1491. X`09`09`09RESULT = 'NO'
  1492. X`09`09ENDIF
  1493. X`09`09GOTO 1999
  1494. XC
  1495. XC   ------------------------------------------------------------------------
  1496. V---
  1497. XC
  1498. X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. LESS_THAN_EQUAL_TO .OR.
  1499. X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(LE)' ) THEN
  1500. XC
  1501. XC`09   Compare for less than or equal to.
  1502. XC
  1503. X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
  1504. X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
  1505. X`09`09`09RESULT = 'YES'
  1506. +-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-
  1507.