🚀 go-pugleaf

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

          [ No description or Readme file was provided with this
           submission.  It appears to provide various time
           calculation and comparison functions.  It includes both
           DCL and Fortran code. ]

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-010  25-Jun-1992
$!   On  3-SEP-1992 22:08:57.78   By user BERRYMAN 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$!+ THIS PACKAGE DISTRIBUTED IN 2 PARTS, TO KEEP EACH PART
$!  BELOW 100 BLOCKS
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. CVTIME.COM;1
$!       2. DAYMONTH.COM;2
$!       3. DESCRIP.MMS;1
$!       4. GET_STRING.FOR;1
$!       5. JPILGINTM.FOR;1
$!       6. LIB_NARGS.MAR;1
$!       7. Q_STRING.FOR;1
$!       8. TABS2BLNK.FOR;1
$!       9. TEST.COM;1
$!      10. TIME.FOR;1
$!      11. TIME.HLP;2
$!      12. TIMECNV.FOR;1
$!      13. TIMECUR.FOR;1
$!      14. TIMEEDIV.MAR;1
$!      15. TIMEEMUL.MAR;1
$!      16. TIMEGET.FOR;1
$!      17. TIMEKEY.FOR;1
$!      18. TIME_MESSAGES.MSG;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ x = P1 - f$parse(P1,,,"version")
$ y = f$search(x)
$ if y .eqs. "" then $ goto file_absent
$ x = f$integer(f$parse(P1,,,"version")-";")
$ y = f$integer(f$parse(y,,,"version")-";")
$ if x .gt. y then $ goto file_absent
$ if f$mode() .eqs. "INTERACTIVE" then $ goto file_interactive
$ if x .eq. y then e "-W-EXISTS, File ''P1' exists. Skipped."
$ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists. Skipped."
$file_delete:
$ delete 'f'*
$ exit
$file_interactive:
$ if x .eq. y then e "-W-EXISTS, File ''P1' exists."
$ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists."
$ read/error=file_delete/end=file_delete-
  /prompt="Create new version [y/n]: " -
  sys$command x
$ if .not. x then $ e "-W-SKIPPED, File ''P1' skipped."
$ if .not. x then $ goto file_delete
$ P1 = P1 - f$parse(P1,,,"version")
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X$ vfl = f$VERIFY(0+f$trnlnm("debug$dcl"))
X$! do LASTMONTH, NEXTMONTH, THISYEAR, NEXTYEAR, LASTYEAR
X$! p1 -- keyword`20
X$! p2 -- global symbol to pass value to
X$! p3 -- target date to use as input
X$! p4 -- week type: GE /HARRIS
X$ p3 = f$cvtime(p3,"absolute","date")
X$ VALID_KEYWORDS = ",THISMONTH,LASTMONTH,NEXTMONTH,THISYEAR,NEXTYEAR,LASTYEA
VR"
X$ valid_keywords = valid_keywords+",THISWEEK,NEXTWEEK,LASTWEEK"
X$ if f$LOC(","+p1,valid_keywords).lt.f$LEN(valid_keywords) then $ goto 'p1'
X$ write sys$output "%CVTIME-E-INVKEYWORD, ",p1," is an invalid keyword"
X$ exit "%X00038060"
X$NEXTMONTH:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
X$ time = f$CVTIME("1-"+p3+"-"+"+32-0","ABSOLUTE","DATE")
X$ time = "1-"+f$cvtime(time,"absolute","month")+"-"+f$cvtime(time,"absolute"
V,"year")
X$ goto exit
X$THISMONTH:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
X$ time = f$CVTIME("1-"+p3+"-","ABSOLUTE","DATE")
X$ goto exit
X$LASTMONTH:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","MONTH")
X$ last_month = "1-"+p3+"-:-1-0:"
X$ time = "1-"+f$CVTIME(last_month,"ABSOLUTE","MONTH")+"-"+ -
X`09f$CVTIME(last_month,"ABSOLUTE","YEAR")
X$ goto exit
X$LASTYEAR:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","year")
X$ last_year = "1-JAN-"+p3+":-1-0:"
X$ time = "1-JAN-"+f$CVTIME(last_year,"ABSOLUTE","YEAR")
X$ goto exit
X$THISYEAR:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","YEAR")
X$ time = f$CVTIME("1-JAN-"+p3,"ABSOLUTE","DATE")
X$ goto exit
X$NEXTYEAR:
X$ if p3.nes."" then $ p3 = f$cvtime(p3,"absolute","YEAR")
X$ time = f$CVTIME("31-DEC-"+p3+":+1-0:","ABSOLUTE","DATE")
X$ goto exit
X$EXIT:
X$ if p2.nes."" then $ 'p2' == time
X$ if p2.eqs."" then $ write sys$output "CVTIME: ",p1," = ",time
X$ exit !'f$VER(vfl)'
X$THISWEEK: ! Monday is beginning of week
X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
X$then
X$ sunday = 1
X$ monday = 2
X$ tuesday = 3
X$ wednesday = 4
X$ thursday = 5
X$ friday = 6
X$ saturday = 0
X$else
X$ sunday = 6
X$ monday = 0
X$ tuesday = 1
X$ wednesday = 2
X$ thursday = 3
X$ friday = 4
X$ saturday = 5
X$endif
X$ today = 'f$CVTIME(p3,,"WEEKDAY")'
X$ time = f$CVTIME(p3+":0:0:0.0-"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
X$ goto exit
X$NEXTWEEK: ! Monday is beginning of week
X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
X$then
X$ sunday = 1
X$ monday = 2
X$ tuesday = 3
X$ wednesday = 4
X$ thursday = 5
X$ friday = 6
X$ saturday = 0
X$else
X$ sunday = 6
X$ monday = 0
X$ tuesday = 1
X$ wednesday = 2
X$ thursday = 3
X$ friday = 4
X$ saturday = 5
X$endif
X$ today = 7-'f$CVTIME(p3,,"WEEKDAY")'
X$ time = f$CVTIME(p3+":0:0:0.0+"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
X$ goto exit
X$LASTWEEK: ! Monday is beginning of week
X$ if f$edit(f$ext(0,1,p4),"UPCASE").eqs."H"
X$then
X$ sunday = 1
X$ monday = 2
X$ tuesday = 3
X$ wednesday = 4
X$ thursday = 5
X$ friday = 6
X$ saturday = 0
X$else
X$ sunday = 6
X$ monday = 0
X$ tuesday = 1
X$ wednesday = 2
X$ thursday = 3
X$ friday = 4
X$ saturday = 5
X$endif
X$ today = 7+'f$CVTIME(p3,,"WEEKDAY")'
X$ time = f$CVTIME(p3+":0:0:0.0-"+f$STRING(today)+"-0:","ABSOLUTE","DATE")
X$ goto EXIT
X$!Last Modified:  29-JUN-1989 17:09:29.50, By: RLB`20
$ CALL UNPACK CVTIME.COM;1 2137918295
$ create 'f'
X$!Last Modified:  6-JUL-1992 12:33:46 by RFORSTER : DAYMONTH.COM
X$ vfl = f$ver(0)
X$! determine days in this month
X$! and month_day, month_name, and year
X$`20
X$ time = ""
X$ if p1.nes."" then   time = p1
X$ if time.eqs."" then time = f$time()
X$ month_day  == f$extract(0,2,time)
X$ month_name == f$extract(3,3,time)
X$ year       == f$extract(7,4,time)
X$ other_time = f$cvtime(time)
X$ month_number == f$extract(5,2,other_time)
X$ cvttime = "$sys_utilities:time"
X$ cvttime/sym=tmp LASTMONTH(+)0-0:
X$ i1 = f$loc(":",tmp)
X$ tmp = f$ext(0,i1,tmp)+" "+f$ext(i1+1,999,tmp)
X$ prev_month_name == f$extract(3,3,tmp)
X$ prev_year       == f$extract(7,4,tmp)
X$ other_time      = f$cvtime(tmp)
X$ prev_month_no   == f$extract(5,2,other_time)
X$ cvttime/sym=tmp THISMONTH(-)1-0:
X$ prev_month_days == f$extract(0,2,tmp)
X$ exit ! 'f$ver(vfl)'
$ CALL UNPACK DAYMONTH.COM;2 40240505
$ create 'f'
X!Last Modified:   3-JUN-1992 14:04:48.77, By: DECMCC`20
X
Xolb_elements = -
X`09time,-
X`09timeget,-
X`09timecnv,-
X`09timecur,-
X`09timekey,-
X`09timeediv,-
X        timeemul,-
X`09get_string,-
X`09lib_nargs,-
X`09jpi_logintim=jpilgintm.obj,-
X`09q_string,-
X`09tabs_to_blanks=tabs2blnk.obj,-
X`09time_messages`20
X
X!.obj.olb :`09!
X!`09@ IF F$SEARCH(F$PARSE("$(MMS$TARGET)")).nes.F$SEARCH("$(MMS$TARGET)") -
X!`09  Then $ copy/log $(MMS$TARGET) $(MMS$TARGET)
X!`09@ if f$search("$(mms$target)").eqs."" then $ $(libr)/create $@
X!`09$(libr) $(librflags) $(MMS$TARGET) $(MMS$SOURCE)
X!
Xtime.exe : time.olb($(OLB_elements))`20
X`09$ set noon
X`09$ pURGE = ""
X`09$ LINK/NODEBUG/NOTRACE/exe=$@  -
X`09`09time.olb/inc=(TIME,time_messages),-
X`09`09time.olb/lib !`20
X`09$ purge *.obj,*.exe
X
Xtime.olb : time.olb($(OLB_elements))
X
Xkit_elements = GET_STRING.FOR,  JPILGINTM.FOR, Q_STRING.FOR, -
XTABS2BLNK.FOR, TIME.FOR, TIMECNV.FOR, TIMECUR.FOR, TIMEGET.FOR, -
XTIMEKEY.FOR, LIB_NARGS.MAR, TIMEEDIV.MAR, TIMEEMUL.MAR, -
XTIME_MESSAGES.MSG, DESCRIP.MMS, CVTIME.COM, DAYMONTH.COM, -
XTEST.COM, TIME.HLP
X
Xtime_kit : $(kit_elements)
X        $ set noon
X        $ mftu = "$utl_root:`5Bmftu`5Dmftu "
X        $ kit_list = f$edit("$(kit_elements)","collapse,trim")
X        $ mftu pack 'kit_list'/output=time_kit.pack
X        $ mftu encode time_kit.pack/output=time_kit.mftu_encoded
X        $ @utl:vms_share 'kit_list' time_kit
$ CALL UNPACK DESCRIP.MMS;1 55479058
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   GETSTRING.FOR - The function of this routine is to find the next charact
Ver
XC`09string and return pointers to the First and Last characters of the
XC`09string.
XC   ------------------------------------------------------------------------
V---
XC
X`09INTEGER*4 FUNCTION GET_STRING ( STRING, FIRST, LAST )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09EXTERNAL`09SS$_NORMAL
XC
X`09PARAMETER`09BLANK=' '
XC
X`09CHARACTER`09STRING*(*)
XC
X`09INTEGER*4`09FIRST, LAST, TMP
XC   ------------------------------------------------------------------------
V---
XC
XC   Translate all tabs to blanks.
XC
X`09STATUS = TABS_TO_BLANKS ( STRING, STRING )
XC
XC   Find the beginning of the string.
XC
X`09GET_STRING = %LOC(SS$_NORMAL)
X`09STRING_S = LEN( STRING )
XC
X`09FIRST = LAST + 1
X`09TMP = LIB$SKPC ( BLANK, STRING(FIRST:STRING_S) ) + (FIRST-1)
X`09IF ( TMP .EQ. (FIRST-1) ) THEN
X`09`09GET_STRING = 0
X`09END IF
X`09FIRST = TMP
XC
XC   Find the end of the string.
XC
X`09LAST = INDEX ( STRING(FIRST:STRING_S), BLANK ) + (FIRST-1)
X`09IF ( LAST .EQ. (FIRST-1) ) LAST = STRING_S + 1
X`09LAST = LAST - 1
XC
XC   Return
XC
X`09RETURN
X`09END
$ CALL UNPACK GET_STRING.FOR;1 185589850
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   JPILGINTM.FOR - The function of this routine is return the time that the
XC`09the current process logged in to the system as a character string.
XC
XC`09dd-mmm-yyyy:hh:mm:ss.cc
XC   ------------------------------------------------------------------------
V---
X`09CHARACTER*(*) FUNCTION JPI_LOGINTIM ( LOGINTIM, LOGINTIM_S )
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09PARAMETER`09ITEMLIST_2Z=8
X`09PARAMETER`09ITEMLIST_4Z=ITEMLIST_2Z/2
X`09PARAMETER`09BLANK=' ', COLON=':'
XC
X`09INTEGER*4`09LOGINTIM(2), LOGINTIM_S
XC
X`09INTEGER*2`09ITEMLIST_2(ITEMLIST_2Z)
X`09INTEGER*4`09ITEMLIST_4(ITEMLIST_4Z)
XC
X`09EQUIVALENCE`09(ITEMLIST_2, ITEMLIST_4)
XC
X`09INCLUDE`09'SYS$LIBRARY:FORSYSDEF($JPIDEF)/NOLIST'
XC
XC   ------------------------------------------------------------------------
V---
XC`09`09      ITEMLIST
XC`09+----------------+----------------+
XC`09: JPI$_LOGINTIM  :        8       :
XC`09+----------------+----------------+
XC`09:        ADDRESS OF BUFFER        :
XC`09+----------------+----------------+
XC`09:                0                :
XC`09+----------------+----------------+
XC`09:                0                :
XC`09+----------------+----------------+
XC   ------------------------------------------------------------------------
V---
XC
XC   Build the Item list.
XC
X`09ITEMLIST_2(1) = 8
X`09ITEMLIST_2(2) = JPI$_LOGINTIM
XC
X`09ITEMLIST_4(2) = %LOC(LOGINTIM)
X`09ITEMLIST_4(3) = 0
X`09ITEMLIST_4(4) = 0
XC
XC   Get the processes login time.
XC
X`09STATUS = SYS$GETJPI (,,,ITEMLIST_4,,,)
XC
XC   Format for return.
XC
X`09LOGINTIM_S = LEN( JPI_LOGINTIM )
X`09STATUS = SYS$ASCTIM`20
X`091`09( LOGINTIM_S, JPI_LOGINTIM(1:LOGINTIM_S), LOGINTIM, )
XC
X`09JPI_LOGINTIM(12:12) = COLON
XC
XC   Return.
XC
X`09RETURN
X`09END
$ CALL UNPACK JPILGINTM.FOR;1 2068076096
$ create 'f'
X;Last Modified:  14-MAY-1990 20:14:56.49, By: RLB`20
X`09.title lib_nargs
X;
X;  Count the number of arguments of a subroutine/function
X;
X`09.ENTRY`09LIB_NARGS,`5EM<>
X; get the previous frame pointer
X`09MOVZBL`09@B`5E8(FP),R0
X`09TSTB`09(AP)
X; If there's no previous caller then return
X`09BEQL`09$10
X`09TSTL`09B`5E4(AP)
X; If there's no arguments then return
X`09BEQL`09$10
X`09MOVL`09R0,@B`5E4(AP)
X$10:
X`09RET
X;
X;  See if 2 arguments are same or different
X;
X`09.ENTRY`09LIB_TST_ARG_DFT,`5EM<R2>
X`09CLRL`09R0
X`09MOVL`09B`5E8(FP),R1
X`09MOVZBL`09@B`5E4(AP),R2
X`09CMPB`09R2,(R1)
X`09BGTRU`09$20
X`09TSTL`09(R1)`5BR2`5D
X`09BEQL`09$20
X`09MCOML`09S`5E#0,R0
X$20:
X`09RET
X`09.END
$ CALL UNPACK LIB_NARGS.MAR;1 1129670880
$ create 'f'
X`09INTEGER*4 FUNCTION Q_STRING
X`091`09( STRING, QUALIFIER, ABBREV_S, QUAL_STRING, QUAL_STR_S )
XC   ------------------------------------------------------------------------
V---
XC   Q_STRING - The function of this subroutine is to search the specified
XC`09string for the specified slash qualifier.  If a match is found the
XC`09qualifier is removed from the string and replaced with blanks.  If`20
XC`09there was a string attached to the qualifier (via '=' or ':'), then
XC`09the qualifier string is returned.
XC
XC`09If mulitple occurences of the qualifier appear in the passed string
XC`09then the last occurence will be returned and the previous entries
XC`09blanked out.
XC
XC`09It is assumed that the qualifier has a negative value associated with
XC`09it, which is be express as /NOqualifier.  This form of the qualifier
XC`09is also considered a match and proper status to indicate if positive
XC`09or negative response was returned.
XC
XC`09If an ambiguous qualifier is found (abbreviation match but wrong`20
XC`09spelling after abbrev limit) an ambiguous error status is returned,
XC`09the entire qualifier string and substring are returned in the qualifier
XC`09string return parameter, and the ambiguous qualifier is blanked from
XC`09the input string.
XC
XC`09  Input string:
XC`09    rrrrrrrrrrrrrrrr/QUALIFIER=QUAL_STRING rrrrrrrrrrrrrrrr
XC`09  Qutput string:
XC`09    RRRRRRRRRRRRRRRR                       RRRRRRRRRRRRRRRR
XC
XC`09Special Note:  The input string will be translated to all upper case
XC`09`09       and all tabs will be replaced with a single blank.
XC
XC   Calling Procedure:
XC
XC`09status = Q_STRING
XC`091`09( string, qualifier, abbrev_size, qual_string `5B,qual_str_s`5D )
XC
XC   Entry Conditions:
XC
XC`09string - must be the address of a string descriptor which contains
XC`09`09the input string to be scanned for the qualifier.  String will
XC`09`09be translated to upper case and all tabs will be replaced with
XC`09`09a single blank.  Any qualifiers found will be blanked out of
XC`09`09the string.
XC
XC`09qualifier - must be the address of a string descriptor which contains
XC`09`09the qualifier (including the '/').  The qualifier must be
XC`09`09passed as an upper case string.
XC
XC`09abbrev_size - must be the address of a numeric value (integer*4) which
XC`09`09specifies how many characters of the qualifier are required
XC`09`09to make a match.
XC
XC   Exit conditions:
XC
XC`09qual_string - Must be the address of a string descriptor pointing to
XC`09`09a string storage area large enough to hold the qualifier
XC`09`09associated string value.  The string associated with the
XC`09`09qualifier will be stored there if it is found.
XC
XC`09`09If an ambiguous qualifier is found both the qualifier and`20
XC`09`09the qualifier string will be returned in this parameter.
XC
XC`09qual_str_s - Optional address of an Integer*4 variable where the
XC`09`09length of the qual_string stored will be returned.
XC
XC`09status - will contain the completion status of the function.
XC`09`09= 0 -- qualifier not found.
XC`09`09= 1 -- good completion; qualifier string returned.
XC`09`09= 2 -- ambiguous qualifier found.  The entire qualifier and`20
XC`09`09       qualifier string are returned in the qualifier string
XC`09`09       return parameter.
XC`09`09= 3 -- qualifier found; no qualifier string available to`20
XC`09`09       return.
XC`09`09= 11 - good completion; negative form of qualifier w/qualifier
XC`09`09       string returned.
XC`09`09= 13 - negative form of qualifier found; no qualifier string
XC`09`09       available to return.
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09PARAMETER`09NEG_QUAL_Z=67`09`09! Maximum number of characters
XC`09`09`09`09`09`09!  allowed in the negative form
XC`09`09`09`09`09`09!  of the qualifier including
XC`09`09`09`09`09`09!  the '/'.
XC
X`09CHARACTER`09STRING*(*)`09`09! Input string to search.
X`09CHARACTER`09QUALIFIER*(*)`09`09! Positive form of qualifier`20
XC`09`09`09`09`09`09!  passed as input to search
XC`09`09`09`09`09`09!  the input string for.  This
XC`09`09`09`09`09`09!  must include the '/' at the
XC`09`09`09`09`09`09!  beginning.
X`09CHARACTER`09QUAL_STRING*(*)`09`09! Return parameter where the
XC`09`09`09`09`09`09!  qualifier string is returned
XC
X`09CHARACTER`09NEG_QUAL*(NEG_QUAL_Z)`09! Temp string used to form the
XC`09`09`09`09`09`09!  the negative form of the
XC`09`09`09`09`09`09!  qualifier ('/NOqualifier').
XC
X`09INTEGER*4`09ABBREV_S`09`09! Number of characters in the
XC`09`09`09`09`09`09!  qualifier which must be`20
XC`09`09`09`09`09`09!  present to indicate a match
XC`09`09`09`09`09`09!  This includes the '/'.
XC
X`09INTEGER*4`09STATUS`09`09`09! General return status area.
X`09INTEGER*4`09Q_STRING_NEG`09`09! 1/2 of return status.  used
XC`09`09`09`09`09`09!  to indicate that a negative
XC`09`09`09`09`09`09!  form of the qualifier was
XC`09`09`09`09`09`09!  found.  later added to
XC`09`09`09`09`09`09!  Q_STRING_TMP
X`09INTEGER*4`09Q_STRING_TMP`09`09! 1/2 of return status.  used
XC`09`09`09`09`09`09!  to indicate if qualifier
XC`09`09`09`09`09`09!  was found and if qualifier
XC`09`09`09`09`09`09!  string was returned.
X`09INTEGER*4`09P1, P2`09`09`09! Substring pointers used to
XC`09`09`09`09`09`09!  isolate the qualifier
XC`09`09`09`09`09`09!  return string.
X`09INTEGER*4`09Q1, Q2, Q3`09`09! Substring pointers used to
XC`09`09`09`09`09`09!  indicate the beginning of
XC`09`09`09`09`09`09!  found qualifier, the end
XC`09`09`09`09`09`09!  of the found qualifier, and
XC`09`09`09`09`09`09!  the end of the qualifer`20
XC`09`09`09`09`09`09!  return string.
X`09INTEGER*4`09N1`09`09`09! Substring pointer to indicate
XC`09`09`09`09`09`09!  the location of a found`20
XC`09`09`09`09`09`09!  negative form of the`20
XC`09`09`09`09`09`09!  qualifer.
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Translate all characters to upper case.
XC
X`09STATUS = STR$UPCASE( STRING, STRING )
XC
XC   Initialize return status.
XC
X`09Q_STRING = 0
XC
XC   Determine how many return qualifiers have been passed and init return ar
Vgs
XC
X`09ARGS = LIB_NARGS()
X`09IF ( ARGS .GE. 5 ) THEN
X`09    QUAL_STR_S = 0
X`09ENDIF
X`09QUAL_STRING = ' '
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Determine what the negative form of the qualifier looks like.
XC
X`09Q_S = LEN( QUALIFIER )
XC
XC   If qualifier is only 1 char long; form negative as '/NO'
XC
X`09IF ( Q_S .EQ. 1 ) THEN
X`09    NEG_QUAL = QUALIFIER(1:1) // 'NO'
XC
XC   If qualifier is too large to fit negative form tmp space; build to fit.
XC
X`09ELSEIF ( Q_S .GT. (NEG_QUAL_Z - 2) ) THEN
X`09`09NEG_QUAL = QUALIFIER(1:1) // 'NO' // QUALIFIER(2:NEG_QUAL_Z-2)
XC
XC   Build negative form of qualifier using entier passed qualifier.
XC
X`09ELSE
X`09`09NEG_QUAL = QUALIFIER(1:1) // 'NO' // QUALIFIER(2:Q_S)
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Establish the loop to find all occurences of the qualifier.
XC
X`09DO WHILE (.TRUE.)
X`09    Q_STRING_TMP = 0`09`09`09`09! Init 1/2 rtn status
X`09    Q_STRING_NEG = 0`09`09`09`09! Init 1/2 rtn status
XC
XC`09  Determine if there are any occurences of the qualifier in the string.
XC
X`09    Q1 = INDEX( STRING, QUALIFIER(1:ABBREV_S) )`09`09! check pos
X`09    N1 = INDEX( STRING, NEG_QUAL(1:ABBREV_S+2) )`09! check neg
XC
XC`09  If neither positive form or negative form; exit loop and return.
XC
X`09    IF ( (Q1 + N1) .EQ. 0 ) GOTO 1999
XC
XC`09  Determine if the string is positive or negative form of qualifier.
XC
X`09    IF ( Q1 .EQ. 0 ) Q1 = 99999999
X`09    IF ( N1 .EQ. 0 ) N1 = 99999999
X`09    IF ( Q1 .GT. N1 ) THEN
X`09`09Q_STRING_NEG = 10`09`09`09! set return status
X`09`09Q1 = N1`09`09`09`09`09! store start loc
X`09    ENDIF
XC
XC`09  Isolate the qualifier ( space, tab, '/', end-of-string).
XC
X`09    Q3 = Q1 - 1
X`09    STATUS = GET_STRING( STRING, Q1, Q3 )   ! look for space, tab, eol
X`09    Q2 = INDEX( STRING(Q1+1:Q3), QUALIFIER(1:1) ) ! look for '/'
XC
XC`09  Determine if '/' or space,tab,eol is first found.
XC
X`09    IF ( Q2 .NE. 0 ) THEN
X`09`09    Q2 = Q2 + Q1
X`09`09    IF ( Q2 .LT. Q3 ) THEN
X`09`09`09    Q3 = Q2 - 1
X`09`09    ENDIF
X`09    ENDIF
XC
XC`09  See if the qualifier has a value attached.
XC
X`09    P1 = INDEX( STRING(Q1:Q3), '=' )`09! look for '='
X`09    P2 = INDEX( STRING(Q1:Q3), ':' )`09! look for ':'
X`09    IF ( P1 .EQ. 0 ) P1 = P2`09`09! adjust for '=' not found
X`09    IF ( P2 .EQ. 0 ) P2 = P1`09`09! adjust for ':' not found
X`09    P1 = MIN( P1, P2 )`09`09`09! determine which is closest.
X`09    IF ( P1 .NE. 0 ) THEN`09`09! see if either found
X`09`09P1 = P1 + (Q1-1)`09`09! calc delimiter loc in string
X`09`09P2 = Q3`09`09`09`09! get end string position
X`09`09Q2 = P1 - 1`09`09`09! calc end of qualifier
X`09`09P1 = P1 + 1`09`09`09! calc begin qual str loc.
X`09`09IF ( P1 .GT. P2 ) THEN`09`09! if no string, then
X`09`09    Q_STRING_TMP = 3`09`09!   set return status w/no str
X`09`09ELSE`09`09`09`09! else
X`09`09    Q_STRING_TMP = 1`09`09!   set return status w/string
X`09`09ENDIF`09`09`09`09! endif
X`09    ELSE`09
XC
XC`09      No string attached to qualifier; no string to return.
XC
X`09`09Q2 = Q3`09`09`09`09! set end of qualifier loc
X`09`09Q_STRING_TMP = 3`09`09! set return status w/ no str
X`09    ENDIF
XC
XC`09  Verify that the qualifier matches the spelling.
XC
X`09    IF ( Q_STRING_NEG .EQ. 0 ) THEN
X`09`09IF ( STRING(Q1:Q2) .NE. QUALIFIER(1:Q2-Q1+1) ) THEN
X`09`09    Q_STRING_TMP = 2
X`09`09ENDIF
X`09    ELSE
X`09`09IF ( STRING(Q1:Q2) .NE. NEG_QUAL(1:Q2-Q1+1) ) THEN
X`09`09    Q_STRING_TMP = 2
X`09`09    Q_STRING_NEG = 0
X`09`09ENDIF
X`09    ENDIF
XC
XC`09  Store the associated qualifier string for return if present.
XC
X`09    IF ( Q_STRING_TMP .EQ. 1 ) THEN`09! If qual string found, then
X`09`09QUAL_STRING = STRING(P1:P2)`09!   Store qualifier string.
X`09`09Q_S_S = P2 - (P1-1)`09`09!   Store length of string.
X`09    ELSEIF ( Q_STRING_TMP .EQ. 2 ) THEN ! If ambiguous qualifier,`20
X`09`09QUAL_STRING = STRING(Q1:Q3)`09!   Store qual and qual str.
X`09`09Q_S_S = Q3 - (Q1-1)`09`09!   Store length of string.
X`09    ELSE`09`09`09`09! Else
X`09`09QUAL_STRING = ' '`09`09!   Store blank.
X`09`09Q_S_S = 0`09`09`09!   Store length zero.
X`09    ENDIF
XC
XC`09  Store the length of the qualifier string.
XC
X`09    IF ( ARGS .GE. 5 ) THEN
X`09`09QUAL_STR_S = Q_S_S
X`09`09IF ( LEN( QUAL_STRING ) .LT. Q_S_S ) THEN
X`09`09    QUAL_STR_S = LEN( QUAL_STRING )
X`09`09ENDIF
X`09    ENDIF
XC
XC`09  Remove the qualifier and qualifier string from the input string.
XC
X`09    STRING(Q1:Q3) = ' '
XC
XC`09  Update the return status.
XC
X`09    Q_STRING = Q_STRING_TMP + Q_STRING_NEG
XC
XC`09  If ambiguous string found exit from loop.
XC
X`09    IF ( Q_STRING_TMP .EQ. 2 ) GOTO 1999
X`09ENDDO
X1999`09CONTINUE
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Return.
XC
X`09RETURN
X`09END
$ CALL UNPACK Q_STRING.FOR;1 1400278957
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   TABS2BLNK.FOR - The function of this routine is to translate all tabs to
XC`09to blanks using a translation table.
XC   ------------------------------------------------------------------------
V---
X`09INTEGER*4 FUNCTION TABS_TO_BLANKS ( SOURCE, DESTINATION )
XC
X`09PARAMETER`09BLANK=' '
XC
X`09CHARACTER`09SOURCE*(*), DESTINATION*(*)
XC
X`09CHARACTER*(1)`09TBL_C(256)
X`09BYTE`09`09TBL_B1(128)
X`09BYTE`09`09TBL_B2(128)
XC
X`09EQUIVALENCE`09( TBL_C(1), TBL_B1(1) ), ( TBL_C(129), TBL_B2(1) )
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Define the translation table.
XC
X`09DATA TBL_B1
X`091 /'00'x, '01'x, '02'x, '03'x, '04'x, '05'x, '06'x, '07'x,`20
X`092  '08'x, '20'x, '0A'x, '0B'x, '0C'x, '0D'x, '0E'x, '0F'x,`20
X`093  '10'x, '11'x, '12'x, '13'x, '14'x, '15'x, '16'x, '17'x,`20
X`094  '18'x, '19'x, '1A'x, '1B'x, '1C'x, '1D'x, '1E'x, '1F'x,`20
X`095  '20'x, '21'x, '22'x, '23'x, '24'x, '25'x, '26'x, '27'x,`20
X`096  '28'x, '29'x, '2A'x, '2B'x, '2C'x, '2D'x, '2E'x, '2F'x,`20
X`097  '30'x, '31'x, '32'x, '33'x, '34'x, '35'x, '36'x, '37'x,`20
X`098  '38'x, '39'x, '3A'x, '3B'x, '3C'x, '3D'x, '3E'x, '3F'x,`20
X`099  '40'x, '41'x, '42'x, '43'x, '44'x, '45'x, '46'x, '47'x,`20
X`099  '48'x, '49'x, '4A'x, '4B'x, '4C'x, '4D'x, '4E'x, '4F'x,`20
X`091  '50'x, '51'x, '52'x, '53'x, '54'x, '55'x, '56'x, '57'x,`20
X`092  '58'x, '59'x, '5A'x, '5B'x, '5C'x, '5D'x, '5E'x, '5F'x,`20
X`093  '60'x, '61'x, '62'x, '63'x, '64'x, '65'x, '66'x, '67'x,`20
X`094  '68'x, '69'x, '6A'x, '6B'x, '6C'x, '6D'x, '6E'x, '6F'x,`20
X`095  '70'x, '71'x, '72'x, '73'x, '74'x, '75'x, '76'x, '77'x,`20
X`096  '78'x, '79'x, '7A'x, '7B'x, '7C'x, '7D'x, '7E'x, '7F'x/
XC
X`09DATA TBL_B2
X`091 /'80'x, '81'x, '82'x, '83'x, '84'x, '85'x, '86'x, '87'x,`20
X`092  '88'x, '89'x, '8A'x, '8B'x, '8C'x, '8D'x, '8E'x, '8F'x,`20
X`093  '90'x, '91'x, '92'x, '93'x, '94'x, '95'x, '96'x, '97'x,`20
X`094  '98'x, '99'x, '9A'x, '9B'x, '9C'x, '9D'x, '9E'x, '9F'x,`20
X`095  'A0'x, 'A1'x, 'A2'x, 'A3'x, 'A4'x, 'A5'x, 'A6'x, 'A7'x,`20
X`096  'A8'x, 'A9'x, 'AA'x, 'AB'x, 'AC'x, 'AD'x, 'AE'x, 'AF'x,`20
X`097  'B0'x, 'B1'x, 'B2'x, 'B3'x, 'B4'x, 'B5'x, 'B6'x, 'B7'x,`20
X`098  'B8'x, 'B9'x, 'BA'x, 'BB'x, 'BC'x, 'BD'x, 'BE'x, 'BF'x,`20
X`099  'C0'x, 'C1'x, 'C2'x, 'C3'x, 'C4'x, 'C5'x, 'C6'x, 'C7'x,`20
X`099  'C8'x, 'C9'x, 'CA'x, 'CB'x, 'CC'x, 'CD'x, 'CE'x, 'CF'x,`20
X`091  'D0'x, 'D1'x, 'D2'x, 'D3'x, 'D4'x, 'D5'x, 'D6'x, 'D7'x,`20
X`092  'D8'x, 'D9'x, 'DA'x, 'DB'x, 'DC'x, 'DD'x, 'DE'x, 'DF'x,`20
X`093  'E0'x, 'E1'x, 'E2'x, 'E3'x, 'E4'x, 'E5'x, 'E6'x, 'E7'x,`20
X`094  'E8'x, 'E9'x, 'EA'x, 'EB'x, 'EC'x, 'ED'x, 'EE'x, 'EF'x,`20
X`095  'F0'x, 'F1'x, 'F2'x, 'F3'x, 'F4'x, 'F5'x, 'F6'x, 'F7'x,`20
X`096  'F8'x, 'F9'x, 'FA'x, 'FB'x, 'FC'x, 'FD'x, 'FE'x, 'FF'x/
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Translate the string.
XC
X`09TABS_TO_BLANKS = LIB$MOVTC ( SOURCE, BLANK, TBL_C, DESTINATION )
XC
XC   Return
XC
X`09RETURN
X`09END
$ CALL UNPACK TABS2BLNK.FOR;1 621369641
$ create 'f'
X$ del/sym/loc/all
X$ set noon
X$ dir = f$environment("default")
X$ cvttime = "$"+dir+"time"
X$ del/sym/loc dir
X$ cpu_d = 1
X$ cpu_1 = f$getjpi("","cputim")
X$ cvttime/sym=comp1  today(-)thisyear(/)7-0:(*)7
X$ cvttime/sym=comp2  thisweek(-)thisyear(/)7-0:(*)1(*)1-0:
X$ cvttime/sym=this_year THISYEAR(+)0-0:
X$ cvttime/sym=lastmonth LASTMONTH(+)0-0:
X$ cvttime/sym=nextmonth NEXTMONTH(+)0-0:
X$ cvttime/sym=thismonth THISMONTH(+)0-0:
X$ cvttime/sym=last_week LASTWEEK(+)0-0:
X$ cvttime/sym=next_week NEXTWEEK(+)0-0:
X$ cvttime/sym=this_week THISWEEK(+)0-0:
X$ cvttime/sym=yesterday YESTERDAY(+)0-0:
X$ cvttime/sym=to_morrow TOMORROW(+)0-0:
X$ cvttime/sym=today_dat TODAY(+)0-0:
X$ cpu_d = f$getjpi("","cputim")-cpu_1
X$ del/sym/loc cvttime
X$ show sym/loc/all
X$ time_convert:
X$   tmp_day = cpu_d/(24*360000)
X$   tmp_hrs = cpu_d/360000-24*tmp_day
X$   tmp_min = cpu_d/6000-60*(24*tmp_day+tmp_hrs)
X$   tmp_sec = cpu_d/100-60*(60*(24*tmp_day+tmp_hrs)+tmp_min)
X$   tmp_hun = cpu_d - 100*(60*(60*(24*tmp_day+tmp_hrs)+tmp_min)+tmp_sec)
X$   cpu_d = f$fao("!2ZL-!2ZL:!2ZL:!2ZL.!2ZL",-
X`09`09 tmp_day,tmp_hrs,tmp_min,tmp_sec,tmp_hun)
X$ write sys$output "TIMETEST-I-CPUTIME, cpu time consumed:  ",cpu_d
$ CALL UNPACK TEST.COM;1 2002140304
$ create 'f'
XC   ------------------------------------------------------------------------
V---
XC   TIME.FOR - The function of this program is to perform time calculations
XC`09for the DCL user. The functions which may be performed are:
XC
XC`09TIME - This will return the current time and the user's connect time.
XC`09TIME absolute_time - This will return the current time and the delta
XC`09`09`09     between the current time and the absolute_time
XC`09`09`09     specified.
XC`09TIME abs_time (-) abs_time --> gives delta_time.
XC`09TIME abs_time (+) delat_time --> gives abs_time.
XC`09TIME abs_time (-) delta_time --> gives abs_time.
XC`09TIME abs_time (=) abs_time --> 'YES' or 'NO'`09also (EQ)
XC`09TIME abs_time (<>) abs_time --> 'YES' or 'NO'`09also (NE)
XC`09TIME abs_time (<) abs_time --> 'YES' or 'NO'`09also (LT)
XC`09TIME abs_time (>) abs_time --> 'YES' or 'NO'`09also (GT)
XC`09TIME abs_time (<=) abs_time --> 'YES' or 'NO'`09also (LE)
XC`09TIME abs_time (>=) abs_time --> 'YES' or 'NO'`09also (GE)
XC`09TIME abs_time (?) abs_time --> gives:
XC`09`09`09`09`09`09a 'GREATER_THAN' than b
XC`09`09`09`09`09`09a 'LESS_THAN' than b
XC`09`09`09`09`09`09a 'EQUAL_TO' to b
XC`09TIME delta_time (+) delta_time --> gives delta_time.
XC`09TIME delta_time (-) delta_time --> gives delta_time.
XC`09TIME delta_time (=) delta_time --> gives 'YES' or 'NO'`09also (EQ)
XC`09TIME delta_time (<>) delta_time --> gives 'YES' or 'NO'`09also (NE)
XC`09TIME delta_time (<) delta_time --> gives 'YES' or 'NO'`09also (LT)
XC`09TIME delta_time (>) delta_time --> gives 'YES' or 'NO'`09also (GT)
XC`09TIME delta_time (<=) delta_time --> gives 'YES' or 'NO'`09also (LE)
XC`09TIME delta_time (>=) delta_time --> gives 'YES' or 'NO'`09also (GE)
XC`09TIME delta_time (?) delta_time --> gives:
XC`09`09`09`09`09`09a 'GREATER_THAN' than b
XC`09`09`09`09`09`09a 'LESS_THAN' than b
XC`09`09`09`09`09`09a 'EQUAL_TO' to b
XC`09TIME delta_time (/) delta_time --> gives integer
XC`09TIME delta_time (/) integer --> gives delta_time
XC`09TIME delta_time (*) integer --> gives delta_time
XC
XC`09TIME integer (+) integer --> integer
XC`09TIME integer (-) integer --> integer
XC`09TIME integer (/) integer --> integer
XC`09TIME integer (*) integer --> integer
XC
XC   Input formats:
XC
XC`09The absolute time input format may be either:
XC
XC`09`09dd-mmm-yyyy hh:mm:ss.hh
XC`09or
XC`09`09dd-mmm-yyyy:hh:mm:ss.hh
XC
XC`09or one of the keywords:
XC
XC`09`09YESTERDAY, TODAY, TOMORROW, THISMONTH, NEXTMONTH, LASTMONTH
XC`09`09THISYEAR, THISWEEK, NEXTWEEK, LASTWEEK
XC
XC`09The colon between the year and the hour is optional.
XC
XC`09The delta time input format may be:
XC
XC`09`09dddd-hh:mm:ss.hh
XC
XC`09The dash between the days and the hour is optional.
XC
XC`09The operators must may be:
XC
XC`09`09(+)`09addition
XC`09`09(-)`09subtraction
XC`09`09(*)`09multiplication
XC`09`09(/)`09division
XC`09`09(=)`09compare for equal to
XC`09`09(<>)`09compare for not equal to
XC`09`09(<)`09compare for less than
XC`09`09(>)`09compare for greater than
XC`09`09(<=)`09compare for less than or equal to
XC`09`09(>=)`09compare for greater than or equal to
XC`09`09(?)`09comparsion
XC
XC`09The () must be included.
XC
XC   Output formats:
XC
XC`09If no /SYMBOL=symbol option is given then the results are sent to
XC`09SYS$OUTPUT, otherwise the result is returned in the local symbol
XC`09specified.
XC
XC`09The absolute time returned will be in the following format:
XC
XC`09`09dd-mmm-yyyy:hh:mm:ss.hh
XC
XC`09The delta time returned will be in the following format:
XC
XC`09`09dddd-hh:mm:ss.hh
XC
XC`09The comparison values returned will be,
XC
XC`09    for (?):
XC`09`09GREATER_THAN
XC`09`09LESS_THAN
XC`09`09EQUAL_TO
XC
XC`09    and for (=), (<>), (<), (>), (<=), (>=):
XC`09`09YES
XC`09`09NO
XC`09`09
XC   ------------------------------------------------------------------------
V---
XC
XC V2.0`0923-Mar-83`09FJN`09Converted to using TIME__xxx condition codes
XC`09`09`09`09from TIMEMSG.MSG file.  Added TIMEKEY with
XC`09`09`09`09keyword time names.
XC V2.1`0902-Apr-83`09FJN`09Added LASTMONTH and LASTWEEK keywords
XC
X`09PROGRAM TIME
XC
X`09IMPLICIT INTEGER*4 (A-Z)
XC
X`09EXTERNAL`09SS$_INTOVF
X`09EXTERNAL`09SS$_IVTIME
XC
X`09PARAMETER`09PARAMZ=255
X`09PARAMETER`09RESULTZ=64
X`09PARAMETER`09SYMBOLZ=64
X`09PARAMETER`09ABSZ=23
X`09PARAMETER`09DELTAZ=16
X`09PARAMETER`09DASH='-'
X`09PARAMETER`09SLASH='/'
X`09PARAMETER`09EQUAL='='
X`09PARAMETER`09COLON=':'
X`09PARAMETER`09BLANK=' '
X`09PARAMETER`09PLUS='(+)'
X`09PARAMETER`09MINUS='(-)'
X`09PARAMETER`09MULTIPLY='(*)'
X`09PARAMETER`09DIVIDE='(/)'
X`09PARAMETER`09QUESTION='(?)'
X`09PARAMETER`09EQUAL_TO='(=)'
X`09PARAMETER`09NOT_EQUAL='(<>)'
X`09PARAMETER`09LESS_THAN='(<)'
X`09PARAMETER`09LESS_THAN_EQUAL_TO='(<=)'
X`09PARAMETER`09GREATER_THAN='(>)'
X`09PARAMETER`09GREATER_THAN_EQUAL_TO='(>=)'
X`09PARAMETER`09SYM='SYM'
XC
XC
X`09CHARACTER`09TIMECUR*40`09! Function subroutine.
XC
X`09CHARACTER`09PARAM*(PARAMZ) /' '/
X`09CHARACTER`09RESULT*(RESULTZ) /' '/
X`09CHARACTER`09SYMBOL*(SYMBOLZ) /' '/
X`09CHARACTER`09ABS_C*(ABSZ)
X`09CHARACTER`09DELTA_C*(DELTAZ)
XC
X`09INTEGER*4`09ABS_S, DELTA_S
X`09INTEGER*4`09BIN_0(2) /0,0/
X`09INTEGER*4`09BIN_1(2)
X`09INTEGER*4`09BIN_2(2)
X`09INTEGER*4`09BIN_SCR(2)
X`09INTEGER*4`09STATUS, STATUS_1, STATUS_2
X`09INTEGER*4`09PARAM_S
X`09INTEGER*4`09RESULT_S
X`09INTEGER*4`09SYMBOL_S /0/
X`09INTEGER*4`09P1 /0/, P2 /0/
X`09INTEGER*4`09Q1 /0/, Q2 /0/
X`09INTEGER*4`09R1 /0/, R2 /0/
X`09INTEGER*4`09S1 /0/, S2 /0/
X`09INTEGER*4`09OP1_1, OP1_2
X`09INTEGER*4`09OP2_1, OP2_2
X`09INTEGER*4`09OP3_1, OP3_2
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09EXTERNAL  TIME__INVABSTIM`09!invalid absolute time format
X`09EXTERNAL  TIME__INVADD`09`09!invalid add
X`09EXTERNAL  TIME__INVCMP`09`09!invalid compare
X`09EXTERNAL  TIME__INVDELTIM`09!invalid delta time format
X`09EXTERNAL  TIME__INVDIV`09`09!invalid divide
X`09EXTERNAL  TIME__INVINT`09`09!invalid integer value format
X`09EXTERNAL  TIME__INVMUL`09`09!invalid multiply
X`09EXTERNAL  TIME__INVOPR`09`09!invalid operation
X`09EXTERNAL  TIME__INVSUB`09`09!invalid subtract
X`09EXTERNAL  TIME__MISPAR`09`09!time parameter missing
X`09EXTERNAL  TIME__OVRFLO`09`09!time calculation overflow
X`09EXTERNAL  TIME__TOOMNYOPR`09!too many operands
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Get the command line.
XC
X`09STATUS = LIB$GET_FOREIGN ( PARAM, , PARAM_S )
X`09IF (.NOT.status) CALL EXIT(status)
X`09STATUS = TABS_TO_BLANKS ( PARAM(1:PARAM_S), PARAM(1:PARAM_S) )
X`09IF (.NOT.status) CALL EXIT(status)
X`09STATUS = STR$UPCASE ( PARAM(1:PARAM_S), PARAM(1:PARAM_S) )
X`09IF (.NOT.status) CALL EXIT(status)
XC
XC   Scan for /DEBUG option.
XC
X`09DEBUG = Q_STRING( PARAM(1:PARAM_S), '/DEBUG', 4, SYMBOL )
XC
XC   Scan for /SYMBOL option.
XC
X`09SYMBOL_S = 0
X`09STATUS = Q_STRING( PARAM(1:PARAM_S), '/SYMBOL', 4, SYMBOL )
X`09IF ( STATUS .EQ. 1 ) THEN
X`09`09CALL STR$TRIM( SYMBOL, SYMBOL, SYMBOL_S )
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Fetch the first parameter.
XC
X`09OP1_2 = 0
X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP1_1, OP1_2 )
X`09IF ( .NOT. STATUS ) THEN
XC
XC`09   No parameters specified; fetch the system time and connect time.
XC
X`09`09RESULT = TIMECUR ( BIN_0 )
X`09`09RESULT_S = LEN( RESULT )
X`09`09OP3_2 = OP1_2
X`09`09GOTO 1999
X`09ENDIF
XC
XC   Convert the first parameter into binary time format.
XC
X`09STATUS_1 = TIMECNV( PARAM(OP1_1:OP1_2), BIN_1 )
X`09IF ( STATUS_1 .EQ. 4 ) THEN
X`09`09CALL LIB$STOP(TIME__INVABSTIM)
X`09ELSEIF ( STATUS_1 .EQ. 6 ) THEN
X`09`09CALL LIB$STOP(TIME__INVDELTIM)
X`09ELSEIF ( STATUS_1 .EQ. 8 ) THEN
X`09`09CALL LIB$STOP(TIME__INVINT)
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
X      OP3_2 = OP1_2`09
X      LOOP = 0`09
X      DO WHILE (.TRUE.)`09
X`09LOOP = LOOP + 1
XC
XC   Fetch the next parameter (it should be an operator).
XC
X`09OP2_2 = OP3_2`09
X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP2_1, OP2_2 )
X`09IF ( .NOT. STATUS ) THEN
X`09`09IF ( LOOP .GT. 1 ) GOTO 1999`09
XC
XC`09   No operator present; do a delta time calculation with current time
XC`09`09and the first parameter already fetched.
XC
X`09`09IF ( STATUS_1 .NE. 3 ) THEN
X`09`09`09CALL LIB$STOP(TIME__INVABSTIM)
X`09`09ELSE
X`09`09`09RESULT = TIMECUR ( BIN_1 )
X`09`09`09RESULT_S = LEN( RESULT )
X`09`09`09GOTO 1999
X`09`09ENDIF
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Fetch the last parameter (it should be present).
XC
X`09OP3_2 = OP2_2
X`09STATUS = TIMEGET( PARAM(1:PARAM_S), OP3_1, OP3_2 )
X`09IF ( .NOT. STATUS ) THEN
XC
XC`09   Third parameter must be present; error
XC
X`09`09CALL LIB$STOP(TIME__MISPAR)
X`09ENDIF
XC
XC   Convert the third parameter to binary time format.
XC
X`09STATUS_2 = TIMECNV( PARAM(OP3_1:OP3_2), BIN_2 )
X`09IF ( STATUS_2 .EQ. 4 ) THEN
X`09`09CALL LIB$STOP(TIME__INVABSTIM)
X`09ELSEIF ( STATUS_2 .EQ. 6 ) THEN
X`09`09CALL LIB$STOP(TIME__INVDELTIM)
X`09ELSEIF ( STATUS_1 .EQ. 8 ) THEN
X`09`09CALL LIB$STOP(TIME__INVINT)
X`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
XC   Evaluate the operator and perform the necessary calculation.
XC
X`09IF ( PARAM(OP2_1:OP2_2) .EQ. PLUS ) THEN
XC
XC   ------------------------------------------------------------------------
V---
XC
XC`09   Add the two values together.
XC
X`09`09STATUS = LIB$ADDX( BIN_1, BIN_2, BIN_1, 2 )
X`09`09IF ( STATUS .EQ. %LOC(SS$_INTOVF) ) THEN
X`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09ENDIF
XC
XC`09   Determine the output format and convert to the proper format.
XC
X`09`09A = STATUS_1 + STATUS_2
X`09`09S = STATUS_1 - STATUS_2
X`09`09IF ( A .EQ. 10 .AND. S .EQ. 0 ) THEN
XC
XC`09`09   Convert to delta time format.
XC
X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
X`09`09`09IF (.NOT.status) CALL EXIT(status)
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
X`09`09`09RESULT(5:5) = DASH
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
XC
X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF
X`09`09`09STATUS_1 = 5
XC
X`09`09ELSEIF ( A .EQ. 8 ) THEN
XC
XC`09`09   Convert to absolute time format.
XC
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_1, %VAL(0) )
X`09`09`09RESULT(12:12) = COLON
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
XC
X`09`09`09STATUS_1 = 3
XC
X`09`09ELSEIF ( A .EQ. 14 ) THEN
XC
XC`09`09   Convert to integer time format.
XC
X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF`09`09`09
XC
X`09`09`09STATUS = OTS$CVT_L_TI
X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
X`09`09`09I = LIB$SKPC( BLANK, RESULT )
X`09`09`09RESULT = RESULT(I:)
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
X`09`09`09STATUS_1 = 7
XC
X`09`09ELSE
XC
XC`09`09   Invalid addition requested.
XC
X`09`09`09CALL LIB$STOP(TIME__INVADD)
X`09`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. MINUS ) THEN
XC
XC`09   Subtract the two values.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_1, 2 )
X`09`09IF ( BIN_1(2) .LT. 0 ) THEN
X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_1, 2 )
X`09`09ENDIF
XC
XC`09   Perform the output conversion for display.
XC
X`09`09A = STATUS_1 + STATUS_2
X`09`09S = STATUS_1 - STATUS_2
X`09`09IF ( S .EQ. 0 .AND. ( A .EQ. 6 .OR. A .EQ. 10 ) ) THEN
XC
XC`09`09   Convert to delta time format.
XC
X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
X`09`09`09`09BIN_1(1) = '00000001'x
X`09`09`09ENDIF
XC
X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
X`09`09`09RESULT(5:5) = DASH
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
XC
X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF
X`09`09`09STATUS_1 = 5
XC
X`09`09ELSEIF ( S .EQ. -2 .AND. A .EQ. 8 ) THEN
XC
XC`09`09   Convert to absolute time format.
XC
X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
X`09`09`09`09BIN_1(1) = '00000001'x
X`09`09`09ENDIF
XC
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_1, %VAL(0) )
X`09`09`09RESULT(12:12) = COLON
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
XC
X`09`09`09STATUS_1 = 3
XC
X`09`09ELSEIF ( A .EQ. 14 ) THEN
XC
XC`09`09   Convert to integer time format.
XC
X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF`09`09`09
XC
X`09`09`09STATUS = OTS$CVT_L_TI
X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
X`09`09`09I = LIB$SKPC( BLANK, RESULT )
X`09`09`09RESULT = RESULT(I:)
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
X`09`09`09STATUS_1 = 7
XC
X`09`09ELSE
XC
XC`09`09   Invalid subtraction requested.
XC
X`09`09`09CALL LIB$STOP(TIME__INVSUB)
X`09`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. MULTIPLY ) THEN
XC
XC`09   Multiply the two values.
XC
X`09`09STATUS_M = TIMEEMUL( BIN_1, BIN_2, BIN_1 )
XC
XC`09   Determine the output format and convert to the proper format.
XC
X`09`09A = STATUS_1 + STATUS_2
X`09`09S = STATUS_1 - STATUS_2
X`09`09IF ( A .EQ. 12 ) THEN
XC
XC`09`09   Convert to delta time format.
XC
X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
X`09`09`09`09BIN_1(1) = '00000001'x
X`09`09`09ENDIF
XC
X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
X`09`09`09RESULT(5:5) = DASH
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
XC
X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF
X`09`09`09STATUS_1 = 5
XC
X`09`09`09IF ( STATUS_M .EQ. 0 ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF
XC
X`09`09ELSEIF ( A .EQ. 14 ) THEN
XC
XC`09`09   Convert to integer time format.
XC
X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF`09`09`09
XC
X`09`09`09STATUS = OTS$CVT_L_TI
X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
X`09`09`09I = LIB$SKPC( BLANK, RESULT )
X`09`09`09RESULT = RESULT(I:)
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
X`09`09`09STATUS_1 = 7
XC
X`09`09ELSE
XC
XC`09`09   Invalid multiplication requested.
XC
X`09`09`09CALL LIB$STOP(TIME__INVMUL)
X`09`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. DIVIDE ) THEN
XC
XC`09   Divide the two values.
XC
X`09`09STATUS = TIMEEDIV( BIN_2, BIN_1, BIN_1, BIN_SCR )
XC
XC`09   Determine the output format and convert to the proper format.
XC
X`09`09A = STATUS_1 + STATUS_2
X`09`09S = STATUS_1 - STATUS_2
X`09`09IF ( A .EQ. 12 .AND. S .EQ. -2 ) THEN
XC
XC`09`09   Convert to delta time format.
XC
X`09`09`09IF ( BIN_1(1) .EQ. 0 .AND. BIN_1(2) .EQ. 0 ) THEN
X`09`09`09`09BIN_1(1) = '00000001'x
X`09`09`09ENDIF
XC
X`09`09`09STATUS = LIB$SUBX( BIN_0, BIN_1, BIN_SCR, 2 )
X`09`09`09STATUS = SYS$ASCTIM
X`091`09`09`09( RESULT_S, RESULT, BIN_SCR, %VAL(0) )
X`09`09`09RESULT(5:5) = DASH
XC
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT(:result_s)
XC
X`09`09`09IF ( STATUS .EQ. %LOC(SS$_IVTIME) ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF
X`09`09`09STATUS_1 = 5
XC
X`09`09ELSEIF ( A .EQ. 14 .OR. ( A .EQ. 10 .AND. S .EQ. 0 ) ) THEN
XC
XC`09`09   Convert to integer time format.
XC
X`09`09`09IF ( BIN_1(1) .LT. 0 .OR. BIN_1(2) .NE. 0 ) THEN
X`09`09`09`09CALL LIB$STOP(TIME__OVRFLO)
X`09`09`09ENDIF`09`09`09
XC
X`09`09`09STATUS = OTS$CVT_L_TI
X`091`09`09`09( BIN_1(1), RESULT, %VAL(1), %VAL(4) )
X`09`09`09I = LIB$SKPC( BLANK, RESULT )
X`09`09`09RESULT = RESULT(I:)
X`09`09`09IF ( DEBUG .NE. 0 ) WRITE(*,*)`20
X`091`09`09`09PARAM(1:OP3_2), '=', RESULT
X`09`09`09STATUS_1 = 7
XC
X`09`09ELSE
XC
XC`09`09   Invalid division requested.
XC
X`09`09`09CALL LIB$STOP(TIME__INVDIV)
X`09`09ENDIF
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. QUESTION ) THEN
XC
XC`09   Compare the two operands.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
X`09`09`09RESULT = 'LESS_THAN'
X`09`09ELSEIF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
X`09`09`09RESULT = 'EQUAL_TO'
X`09`09ELSE`20
X`09`09`09RESULT = 'GREATER_THAN'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. EQUAL_TO .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(EQ)' ) THEN
XC
XC`09   Compare for equal.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
X`09`09IF ( (BIN_SCR(2) + BIN_SCR(1)) .EQ. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. NOT_EQUAL .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(NE)' ) THEN
XC
XC`09   Compare for not equal.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
X`09`09IF ( (BIN_SCR(2) + BIN_SCR(1)) .NE. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. LESS_THAN .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(LT)' ) THEN
XC
XC`09   Compare for less than.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
X`09`09`09RESULT = 'YES'
X`09`09ELSE
X`09`09`09RESULT = 'NO'
X`09`09ENDIF
X`09`09GOTO 1999
XC
XC   ------------------------------------------------------------------------
V---
XC
X`09ELSEIF ( PARAM(OP2_1:OP2_2) .EQ. LESS_THAN_EQUAL_TO .OR.
X`091`09 PARAM(OP2_1:OP2_2) .EQ. '(LE)' ) THEN
XC
XC`09   Compare for less than or equal to.
XC
X`09`09STATUS = LIB$SUBX( BIN_1, BIN_2, BIN_SCR, 2 )
X`09`09IF ( BIN_SCR(2) .LT. 0 ) THEN
X`09`09`09RESULT = 'YES'
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-