% VAX-11 Librarian V03-00"ē/ӓ23(( BINTIMCANCELCTRLC0DOUBLE~GETMSGGETWORD :HMSHTIM0~MINDEX TPARSEPUTHELP1dQUADSCANTRIM)UIC,USERNAME USERSVAXDAT VAXTIM&VERIFY'zWAIT@-Ɠ' integer*4 function BINTIM (chr,timedb)cc Iowa State University&c Computation Center Accounting Officec?c To return a character string time value in a double precision c variable.c implicit integer (a-z)c character*(*) chr integer*4 timei(2) real*8 timedb integer*4 SYS$BINTIMc BINTIM = SYS$BINTIM (chr,timei) call DOUBLE (timei,timedb)c return endww-Ɠ subroutine CANCEL (ctrlc)c,c Set ctrlc to indicate control-c interrupt.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) logical*4 ctrlc ctrlc = .true. return endww.Ɠ subroutine CTRLC (extern,parm)c:c To enable program interception of a control_c interrupt.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) external extern6 integer*4 parm,ttchan,func,SYS$ASSIGN,SYS$QIOW,status data func /'0123'x/$ status = SYS$ASSIGN ('TT',ttchan,,)0 status = SYS$QIOW (,%VAL(ttchan),%VAL(func),,,, 1 extern,parm,%VAL(3),,,) return endww~.Ɠ. subroutine GETMSG (error,message,message_len)c4c To return information about the most recent error.cc Iowa State University&c Computation Center Accounting Officec implicit integer (A-Z)c2 integer*4 error,message_len,ascii,SYS$GETMSG,TRIM character*(*) messagec%c Get message from SYS$GETMSG Utilityc message = ' 'A call SYS$GETMSG (%VAL(error),message_len,message,%VAL('0001'X),)cc Find length of messagec4 message_len = INDEX (message(:message_len),'!') - 14 if (message_len .lt. 1) message_len = TRIM(message)c$c Capitalize first letter of messagec: if (message(:1) .ge. 'a' .and. message(:1) .le. 'z') then ascii = ICHAR (message(:1)) message(:1) = CHAR (ascii-32) endifcc Returnc 99 return endww`.Ɠ# subroutine GETWORD (string,i,word)c(c To get a word from a charact er string.;c A word is a string of characters from the first non-blank4c character to: 1) blank character 2) end of string.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) character*(*) string,word integer*4 i,j,l,TRIM l = TRIM (string) word = ' '%10 if (string (i:i) .ne. ' ') goto 20 i = i + 1 if (i .gt. l) goto 40 goto 1020 j = 130 word (j:j) = string (i:i) i = i + 1 if (i .gt. l) goto 40# if (string (i:i) .eq. ' ') go to 40 j = j + 1 goto 30 40 return endww`v/Ɠ subroutine HMSHTIM (time,hmsh)c9c To return the time in an integer array representing the2c hour, minute, seconds, and hundreths of seconds.cc Iowa State University&c Computation Center Accounting Officec implicit integer (A-Z)c! integer*4 time,hmsh(4),h,m,s,hmsc hms = time / 100 h = hms / 3600 m = (hms - (h * 3600)) / 60 s = hms - (h * 3600) - (m * 60)c hmsh(1) = h hmsh(2) = m hmsh( 3) = s hmsh(4) = time - (hms * 100)cc returnc return endww~/Ɠ8 integer*4 function PARSE (num,typ,key,parm,ans,pos,siz, 1 error_msg)cc Iowa State University&c Computation Center Accounting Officec Rodrick A Eldridgec implicit integer (A-Z)c- integer*4 num,ans(num),pos(num),siz(num),err integer*4 typ(2,num)( character*(*) key(2,num),parm,error_msgc character*1 quote/' '/ integer*4 i,j,k,l,m,n,t integer*4 TRIMc c initializec  l = TRIM (parm) i = 1 PARSE = 0cc find non-blankc 10 do while (parm(i:i) .eq. ' ') i = i + 1 if (i .gt. l) goto 99 enddocc type 0c if (parm(i:i) .ne. '/') then j = i i = i + 19 do while (parm(i:i) .ne. ' ' .and. parm(i:i) .ne. '/') i = i + 1 if (i .gt. l) goto 20 enddo20 do k = 1, num1 if (typ(1,k) .eq. 0 .and. .not. ans(k)) then ans(k) = 1 pos(k) = j siz(k) = i - 1 goto 10 endif enddo goto 91 endifcc type 1 or type 2c j = i + 1 i = j i = i + 1# do while (parm(i:i) .ne. ' ' .and./ 1 parm(i:i) .ne. '=' .and. parm(i:i) .ne. '/') i = i + 1 if (i .gt. l) goto 30 enddo 30 m = i - jcc find \qualifier\c do k = 1, num t = 1, if (key(t,k)(:m) .eq. parm(j:j+m-1)) then if (k .lt. num) then do n = k+1, num. if (key(1,n)(:m) .eq. parm(j:j+m-1)) goto 92. if (key(2,n)(:m) .eq. parm(j:j+m-1)) goto 92 enddo endif goto 40 endif t = 2, if (key(t,k)(:m) .eq. parm(j:j+m-1)) then if (k .lt. num) then do n = k+1, num. if (key(1,n)(:m) .eq. parm(j:j+m-1)) goto 92. if (key(2,n)(:m) .eq. parm(j:j+m-1)) goto 92 enddo endif goto 40 endif enddo goto 91cc found \qualifier\c40 m = i if (typ(t,k) .eq. 1) then do while (parm(i:i) .eq. ' ') i = i + 1 if (i .gt. l) goto 50 enddo if (parm(i:i) .eq. '=') then i = m goto 93 endif50 ans(k) = t pos(k) = 0 siz(k) = 0 goto 10 endifcc find \=value\c if (typ(t,k) .eq. 2) then do while (parm(i:i) .eq. ' ') i = i + 1 if (i .gt. l) then i = m goto 94 endif enddo if (parm(i:i) .eq. '=') then i = i + 1" do while (parm(i:i) .eq. ' ') i = i + 1 if (i .gt. l) then i = m goto 94 endif enddo endif if (parm(i:i) .eq. '/') then i = m  goto 94 endif if (parm(i:i) .eq. '''') then quote = ''''# elseif (parm(i:i) .eq. '"') then quote = '"'# elseif (parm(i:i) .eq. '\') then quote = '\'# elseif (parm(i:i) .eq. '(') then quote = ')'# elseif (parm(i:i) .eq. '[') then quote = ']'# elseif (parm(i:i) .eq. '{') then quote = '}'# elseif (parm(i:i) .eq. '<') then quote = '>' else quote = ' ' endifcc found non-quoted stringc if (quote .eq. ' ') then n = i; do while (parm(i:i) .ne. ' ' .and. parm(i:i) .ne. '/') i = i + 1 if (i .gt. l) goto 80 enddo80 ans(k) = t pos(k) = n siz(k) = i - 1 goto 10 endifcc found quoted stringc i = i + 1 n = i" do while (parm(i:i) .ne. quote) i = i + 1 if (i .gt. l) goto 95 enddo ans(k) = 1 pos(k) = n siz(k) = i - 1 i = i + 1 goto 10 endifc6c invalid type specification for qualifier \qualifier\c< error_msg = 'Invalid type specification for qualifier \' // 1 parm(j:i-1) // '\' PARSE = 1 goto 99c,c unrecognited qualifier keyword \qualifier\c491 error_msg = 'Unrecognited qualifier keyword \' // 1 parm(j:i-1) // '\' PARSE = 2 goto 99c)c ambiguous qualifier keyword \qualifier\c192 error_msg = 'Ambiguous qualifier keyword \' // 1 parm(j:i-1) // '\' PARSE = 3 goto 99c+c No value allowed on qualifier \qualifier\c393 error_msg = 'No value allowed on qualifier \' // 1 parm(j:i-1) // '\' PARSE = 4 goto 99c)c value required on qualifier \qualifier\c194 error_msg = 'Value required on qualifier \' // 1 parm(j:i-1) // '\' PARSE = 5 goto 99c3c quoted string missing end quote \qualifier=value\c595 error_msg = 'Quoted string missing end quote \' // 1 parm(j:i-1) // '\' PARSE = 6 goto 99cc returnc 99 return endww:0Ɠ9 integer*4 function PUTHELP (text,flags,output,key_l"evel)cc Iowa State University&c Computation Center Accounting Officecc Display help textc implicit integer (A-Z)c common /control_c/control_c logical*4 control_cc character*(*) text! integer*4 flags,output,key_levelc1 format (1x,a)c c write textc if (control_c) then PUTHELP = .false. else! write (unit=output,fmt=1) text PUTHELP = .true. endifcc returnc 99 continue return endwwL1Ɠ( character*(*) function SCAN (str,i,chr)cc Iowa State University&c Computation Center Accounting Officec=c Returns a character string consisting of all the characters>c in string "str" starting at position "i" until any characterAc in string "chr" is found in "str" or until end of string "str.">c Non of the characters in "chr" are returned, thus "i" points=c to the position in "str" of the a character found in "chr."c implicit integer (A-Z)c character*(*) str,chr integer*4 i,jc SCAN = ' ' j = 1c do i = i,LEN (str)+ if (INDEX (chr,str (i:i)) .ne. 0) return SCAN (j:j) = str (i:i) j = j + 1 enddoc return endww1Ɠ integer*4 function TRIM (str)cc Iowa State University&c Computation Center Accounting Officec=c Returns the length of string "str." The length is the last>c character that is not "blank", a "zero" character or a "tab"@c character. The length of 1 is returned if "str" contains onlyc "blanks", "zeros", or "tabs."c implicit integer (A-Z)c character*(*) str& character*1 blank/' '/,zero/0/,tab/9/c do TRIM = LEN (str),2,-1! if (str (TRIM:TRIM) .ne. blank" 1 .and. str (TRIM:TRIM) .ne. zero) 2 .and. str (TRIM:TRIM) .ne. tab) return enddoc return endww@2Ɠ+ integer*4 function USERS (range,error_msg)c implicit integer (A-Z)c character*(*) range,error_msgc! include 'LIB:ISUDEF(USER)/list'c integer*4 i,TRIMc USERS = 0c i = INDEX (range,'-') if (i .ne. 0) goto 5 i = INDEX (range,':') if (i .ne. 0) goto 5 i = INDEX (range,'.') if (i .ne. 0) goto 5 i = 0c5 if (i .eq. 0) then if (range(:1) .eq. '[') then- call UIC (range(:TRIM(range)),0,*10,*30) else2 call USERNAME (range(:TRIM(range)),0,*20,*30) endif else if (range(:1) .eq. '[') then& call UIC (range(:i-1),-1,*10,*30) else+ call USERNAME (range(:i-1),-1,*20,*30) endif$ if (range(i+1:i+1) .eq. '[') then0 call UIC (range(i+1:TRIM(range)),1,*10,*30) else5 call USERNAME (range(i+1:TRIM(range)),1,*20,*30) endif endif goto 99c<10 error_msg = 'Invalid uic \' // range(:TRIM(range)) // '\' USERS = 1 goto 99cA20 error_msg = 'Invalid username \' // range(:TRIM(range)) // '\' USERS = 2 goto 99c>30 error_msg = 'Invalid range \' // range(:TRIM(range)) // '\' USERS = 3 goto 99c 99 return endc include 'LIB:TOOLS(UIC)/list'$ include 'LIB:TOOLS(USERNAME)/list'ww`q2Ɠ) integer*4 function VAXDAT (date,vaxdate)cc Iowa State University&c Computation Center Accounting Officec,c Converts date format into VAX date format.;c Examples of date formats and their converted VAX formats:cc 1/16/81 16-JAN-1981c 1/16/1981 16-JAN-1981c 16-JAN-81 16-JAN-1981!c 16-JAN-1981 16-JAN-1981"c 16-JANUARY-81 16-JAN-1981$c 16-JANUARY-1981 16-JAN-1981 c JAN 16, 81 16-JAN-1981!c JAN 16, 1981 16-JAN-1981#c JANUARY 16, 81 16-JAN-1981%c JANUARY 16, 1981 16-JAN-1981c implicit integer (a-z)c character*(*) date,vaxdate character*2 day_chr character*4 year_chr character*9 months(12)2 integer*4 length,status,month,day,year,SYS$BINTIM/ integer*4 i,m,n,quadword(2),MINDEX,TRIM,VERIFY character*24 vax_date2 data months/'JANUARY','FEBRUARY','MARCH','APRIL',, 1 'MAY','JUNE','JULY','AUGUST','SEPTEMBER',# 2 'OCTOBER','NOVEMBER','DECEMBER'/c1 format (i) 2 format (i2) 3 format (i4)c call STR$UPCASE (date,date)c month = 0 day = 0 year = 0cc verifyc0 if (VERIFY (date,'0123456789/') .eq. 0) goto 10: if (VERIFY (date,'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-') 1 .eq. 0) goto 20; if (VERIFY (date,'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 ,') 1 .eq. 0) goto 30 goto 99c c mm/dd/yyc10 n = INDEX (date,'/') if (n .eq. 0) goto 99 length = n - 1- decode (length,1,date(:length),err=99) month i = n + 1 n = MINDEX (date,2,'/') if (n .eq. 0) goto 99 length = n - i0 decode (length,1,date(i:i+length-1),err=99) day i = n + 1 n = TRIM (date) + 1 length = n - i1 decode (length,1,date(i:i+length-1),err=99) year goto 40c c dd-month-yyc20 n = INDEX (date,'-') if (n .eq. 0) goto 99 length = n - 1+ decode (length,1,date(:length),err=99) day i = n + 1 n = MINDEX (date,2,'-') if (n .eq. 0) goto 99 length = n - i do month = 1,12> if (date(i:i+length-1) .eq. months(month)(:length)) goto 25 enddo goto 9925 if (month .lt. 12) then do m = month+1,12< if (date(i:i+length-1) .eq. months(m)(:length)) goto 99 enddo endif i = n + 1 n = TRIM (date) + 1 length = n - i1 decode (length,1,date(i:i+length-1),err=99) year goto 40cc month dd, yyc30 n = INDEX (date,' ') if (n .eq. 0) goto 99 length = n - 1 do month = 1,129 if (date(:length) .eq. months(month)(:length)) goto 35 enddo goto 9935 if (m onth .lt. 12) then do m = month+1,127 if (date(:length) .eq. months(m)(:length)) goto 99 enddo endif i = n + 1 n = INDEX (date,',') if (n .eq. 0) goto 99 length = n - i0 decode (length,1,date(i:i+length-1),err=99) day i = n + 1 n = TRIM (date) + 1 length = n - i1 decode (length,1,date(i:i+length-1),err=99) year goto 40cc check valuesc/40 if (month .lt. 1 .or. month .gt. 12) goto 99) if (day .lt. 1 .or. day .gt. 31) goto 99 encode (2,2,day_chr) day.! if (day_chr(1:1) .eq. ' ') day_chr(1:1) = '0' if (year .lt. 100) then year = year + 1900 elseif (year .gt. 1999) then goto 99 endif encode (4,3,year_chr) yearA vaxdate = day_chr // '-' // months(month)(:3) // '-' // year_chr% vax_date = vaxdate // ' 00:00:00.00'c( VAXDAT = SYS$BINTIM (vax_date,quadword) returncc invalid datec99 VAXDAT = .false. returnc endww?4Ɠ) integer*4 function VAXTIM (time,vaxtime)cc Iowa State University"&c Computation Center Accounting Officec1c Convert time format (HH:MM:SS.hh) into VAX timec format (HH:MM:SS.hh).<c If HH is greater then 23 hours, then convert into VAX timec format (DDDD-HH:MM:SS.hh)./c Normal time can be abbreviated as HH:MM, etc.c implicit integer (a-z)c character*(*) time,vaxtime; character*2 hours_chr,minutes_chr,seconds_chr,hseconds_chr character*4 days_chr( integer*4 length,i,n,MINDEX,TRIM,VERIFY. integer*4 days,hours,minutes,seconds,hseconds #c1 format (i) 2 format (i2) 3 format (i4)c days = 0 hours = 0 minutes = 0 seconds = 0 hseconds = 0c c verify timec1 if (VERIFY (time,'0123456789:.') .ne. 0) goto 99cc hoursc n = INDEX (time,':') if (n .eq. 0) then' if (INDEX (time,'.') .ne. 0) goto 10 n = TRIM (time) + 1 endif length = n - 1 if (length .gt. 0) then* read (time(:length),fmt=1,err=99) hours endifc c minutesc i = n + 1 n = MINDEX (time,2,':') if (n .$eq. 0) then' if (INDEX (time,'.') .ne. 0) goto 10 n = TRIM (time) + 1 endif length = n - i if (length .gt. 0) then1 read (time(i:i+length-1),fmt=1,err=99) minutes endifc c secondsc i = n + 1 n = INDEX (time,'.') if (n .eq. 0) then n = TRIM (time) + 1 endif length = n - i if (length .gt. 0) then1 read (time(i:i+length-1),fmt=1,err=99) seconds endifc c hsecondsc10 n = INDEX (time,'.') if (n .eq. 0) goto 20 l = TRIM (time) length = l %- n) read (time(n+1:l),fmt=1,err=99) hsecondscc check the valuesc20 if (hours .lt. 0) goto 991 if (minutes .gt. 59 .or. minutes .lt. 0) goto 991 if (seconds .gt. 59 .or. seconds .lt. 0) goto 993 if (hseconds .gt. 99 .or. hseconds .lt. 0) goto 99cc convert to vax timec if (hours .gt. 23) then days = hours / 24 hours = hours - (days * 24) write (days_chr,fmt=3) days endif write (hours_chr,fmt=2) hours2 if (hours_chr(1:1) .eq. ' ') hours_chr(1:1) = '0'" wri &te (minutes_chr,fmt=2) minutes6 if (minutes_chr(1:1) .eq. ' ') minutes_chr(1:1) = '0'" write (seconds_chr,fmt=2) seconds6 if (seconds_chr(1:1) .eq. ' ') seconds_chr(1:1) = '0'$ write (hseconds_chr,fmt=2) hseconds8 if (hseconds_chr(1:1) .eq. ' ') hseconds_chr(1:1) = '0' if (days .eq. 0) then6 vaxtime = hours_chr // ':' // minutes_chr // ':' //% 1 seconds_chr // '.' // hseconds_chr else0 vaxtime = days_chr(:TRIM(days_chr)) // ' ' //, 1 hours_chr // ':' // minutes_chr // ':' //% 2 sec'onds_chr // '.' // hseconds_chr endifc VAXTIM = .true. returncc invalid timec99 VAXTIM = .false. returnc endww4Ɠ$ integer*4 function VERIFY (str,chr)cc Iowa State Univeristy&c Computation Center Accounting Officec=c Returns the position in string "str" of the first character>c that is not in string "chr". If all characters in "str" arec in "chr", result is zero.c implicit integer (A-Z)c character*(*) str,chrc do VERIFY = 1,LEN (str)4 if (INDEX (chr,str(VERIFY:VERIFY)) .eq. 0) return enddoc VERIFY = 0 return endww!5Ɠ subroutine WAIT (timedb)c?c To wait a specified number of seconds, or to a specific time.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) real*8 timedb integer*2 timei(2) call QUAD (timei,timedb) call SYS$SCHDWK (,,timei,) call SYS$HIBER return endww{5Ɠ D005003 BINTIMCANCELCTRLCGETMSGGETWORDHMSHTIMPARSEPUTHELPSCANTRIMUSERSVAXDATVAXTIMVERIFYWAIT% ғ A005003 UICUSERNAME+@ӓ A005003 DOUBLEMINDEXQUAD*iғ" subroutine UIC (range,switch,*,*)c implicit integer (A-Z)c character*(*) range integer*4 switchc&c switch = 0 single user specification.c switch = -1 left side of range specification.c switch = 1 right side of range specificationc! include 'LIB:ISUDEF(USER)/list'c integer*2 member,group integer*4 i,j,length,TRIM,INDEXc4 format (o)c i = INDEX (range,',') if (i .eq. 0) goto 90 j = TRIM (range) if (range(j:) .ne. ']') goto 90+> if (range(2:i-1) .eq. '*' .and. range(i+1:j-1) .eq. '*') then if (switch .ne. 0) goto 80% from_group = 0 ! lowest uic [0,0] from_member = 0 from_flag = 18 to_group = '377'o ! highest uic [377,377] to_member = '377'o to_flag = 1& elseif (range(i+1:j-1) .eq. '*') then if (switch .eq. 1) goto 80 length = i - 2. decode (length,4,range(2:i-1),err=90) group6 if (group .gt. '377'o .or. group .lt. '0'o) goto 90 if (switch) 10,20,3010 from_,member = '0'o from_group = group from_flag = -1 goto 7020 from_member = '0'o to_member = '377'o from_group = group to_group = group from_flag = -1 to_flag = -1 goto 7030 to_member = '377'o to_group = group to_flag = -1 goto 70$ elseif (range(2:i-1) .eq. '*') then goto 80 else length = j - i - 11 decode (length,4,range(i+1:j-1),err=90) member8 if (member .gt. '377'o .or. member .lt. '0'o) goto 90 length = i - 2-. decode (length,4,range(2:i-1),err=90) group6 if (group .gt. '377'o .or. group .lt. '0'o) goto 90 if (switch) 40,50,6040 from_member = member from_group = group from_flag = 1 goto 7050 from_member = member to_member = member from_group = group to_group = group from_flag = 1 to_flag = 1 goto 7060 to_member = member to_group = group to_flag = 1 goto 70 endifc 70 returnc 80 return 2c 90 return 1 endww. Vғ' subroutine USERNAME (range,switch,*,*)c implicit integer (A-Z)c character*(*) range integer*4 switchc&c switch = 0 single user specification.c switch = -1 left side of range specification.c switch = 1 right side of range specificationc! include 'LIB:ISUDEF(USER)/list'c integer*4 i,TRIM,VERIFY> character*38 syntax/'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$'/c! if (TRIM(range) .gt. 12) goto 90' if (range(:TRIM(range)) .eq. '*') then if (switch /.ne. 0) goto 808 from_username = ' ' ! lowest username '20'x from_flag = 09 to_username = '~~~~~~~~~~~~' ! highest username '7E'x to_flag = 0 else i = VERIFY (range,syntax) if (i .ne. 0) goto 90 if (switch) 10,20,3010 from_username = range from_flag = 0 goto 7020 from_username = range to_username = range from_flag = 0 to_flag = 0 goto 7030 to_username = range to_flag = 0 goto 70 endifc 70 returnc 80 return 2c 90 return 1 endww1 6ӓ! subroutine DOUBLE (timei,timedb)c<c To return a VAX time value in a double precision variable.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) dimension timei(2) real*8 timedb timedb = 2.D0 ** 32 * timei(2) ti1 = ISHFT (timei(1),-1) timedb = timedb + ti1 * 2.D0 return endww`ӓ& integer*4 function MINDEX (str,n,chr)cc Iowa State University&c Computation Center Accounting Office2c/c Finds the "nth" occurrence of "chr" in "str".c implicit integer (A-Z)c character*(*) str,chr integer*4 i,j,kc i = n j = LEN (chr) k = LEN (str) - jc do MINDEX = 1,k0 if (str(MINDEX:MINDEX+j-1) .eq. chr(:j)) then i = i - 1 if (i .eq. 0) return endif enddoc MINDEX = 0 return endww/ӓ subroutine QUAD (timei,timedb)c>c To return a double precision time value in an integer array.cc Iowa State University&c Computation Center Accounting Officec implicit integer (a-z) dimension timei(2) real*8 temp,timedb' temp = timedb + SIGN (49999.D0,timedb)$ timei(2) = AINT (temp / 2.D0 ** 32)- if (timei(2) .lt. 0) timei(2) = timei(2) - 17 timei(1) = ABS ((temp - timei(2) * 2.D0 ** 32) / 8.D0) timei(1) = ISHFT (timei(1),3), if (timei(2) .eq. 0 .and. temp .lt. 0) then timei(1) = - timei(1) timei(2) = - 1 endif return endww