From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CUSPIF.TN.CORNELL.EDU::BRIAN.T.CARCICH"  3-AUG-1989 14:14
To:	MRGATE::"ARISIA::EVERHART"
Subj:	ooops, i lied, they're v5 RTL routines, not system services - do you care?

Message-Id:  <8908031801.AA09688@crdgw1.ge.com>
Date: 3 Aug 1989 14:01:31 EST
From: Brian.T.Carcich@CUSPIF.TN.CORNELL.EDU
To: everhart@arisia.decnet
Subject: ooops, i lied, they're v5 RTL routines, not system services - do you care?
X-Vms-Original-To: INET%"everhart%arisia.decnet@crd.ge.com",CARCICH     


c
c pseudo VMS V4 RTL routines for Tim Cook's TAR package
c
c Submitted by: Brian Carcich, Galileo Project, 
c               Center for Radiophysics and Space Research,
c               Cornell University, Ithaca, NY, USA
c
c Operating System: VAX/VMS V4.? or higher (tested on VMS 4.5)
c Source Language: FORTRAN (What can I say?  I'm an engineer!)
c Memory Required: Not a lot.
c Keywords: TAR, tape, archive, UNIX, VMS Version 4
c
c CAVEAT:  THESE ROUTINES WERE WRITTEN TO SUPPORT TIM COOK'S TAR PROGRAM 
c          ONLY; NO VMS V5 MANUALS WERE CONSULTED (NO V4 MANUALS EITHER,
c          FOR THAT MATTER).  ONLY THE TAR CODE WAS EXAMINED TO MAKE MY BEST
c          GUESS AS TO WHAT THE TAR CODE WANTED THE RTLR's TO DO.
c          IN PARTICULAR LIB$CVT_FROM_INTERNAL_TIME ESSENTIALLY IGNORES ITS
c          FIRST ARGUMENT WHICH SEEMS TO BE A CONVERSION-TYPE SPECIFIER.
c          I.E. THIS LIB$CVT_FROM_INTERNAL_TIME() ONLY DOES ONE TYPE OF 
c          CONVERSION WHEN IT SEEMS THE REAL VMS V5 RTLR IS MEANT TO DO MANY.
c
c          IN ADDITION TO THESE FUNCTIONS, YOU NEED TO MODIFY TAR.PAS AS
c          FOLLOWS TO DEFINE THAT ARGUMENT (LIB$K_DELTA_SECONDS) TO PASS TO 
c          LIB$CVT_FROM_INTERNAL_TIME:
C
C FILE:  TAR.PAS
C ==============
C ...
C   FUNCTION VMS_to_UNIX_time ( ...
C      VAR ...
C         LIB$K_DELTA_SECONDS : unsigned ;        { btc fixup for vms v4 }
C
C          THE VALUE DOES NOT MATTER BECAUSE LIB$CVT_FROM_INTERNAL_TIME ONLY
C          DOES ONE TYPE OF CONVERSION.
C
C          IN GENERAL THESE ROUTINES RETURN EITHER 1 FOR SUCCESS OR 4 FOR
C          FAILURE (I KNOW I SHOULD HAVE USED SS$NORMAL FOR SUCCESS ) UNLESS 
C          THEY CAN RETURN A CODE FROM ANOTHER RLTR OR SYSTEM SERVICE.
c***********************************************************************
C FUNCTION:  LIB$CVT_VECTIM (POOR MAN'S VMS V5 RTL ROUTINE)
C PURPOSE:  CONVERT FROM VECTOR TIME (7 BY I*2) TO QUADWORD BINTIM
C APPLICATION:  FOR USE WITH TIM COOK'S TAR PACKAGE IN VMS V4.X ***ONLY***
C
	integer*4 function lib$cvt_vectim( i, j)
	IMPLICIT NONE
	integer*4 j(2)		!out:  bintim
	integer*2 i(7)		!in:  numtim
	INTEGER*4 IYEAR, IMONTH,IDAY, IHOUR, IMINUTE, ISECOND
     &			, ICENTISECOND
	parameter ( iyear=1 )
	parameter ( imonth=2 )
	parameter ( iday=3 )
	parameter ( ihour=4 )
	parameter ( iminute=5 )
	parameter ( isecond=6 )
	parameter ( icentisecond=7 )
	character*3 mon(12) /
     &		'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
     &		'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' /
c			       123456789012345678901234567890
C
C PROBABLY SHOULD FORCE ASCTIM NON-VOLATILE TO PRESERVE "-"'S
	character*23 asctim / 'dd-mmm-yyyy hh:mm:ss.cc' /
	integer*4 sys$bintim
c
	write( asctim( 1:2), fmt='(i2.2)') i(iday)
	write( asctim( 4:6), fmt='(a3)') mon(i(imonth))
	write( asctim( 8:11), fmt='(i4.4)') i(iyear)
	write( asctim( 13:14 ), fmt='( i2.2 )') i( ihour )
	write( asctim( 16:17 ), fmt='( i2.2 )') i( iminute )
	write( asctim( 19:20 ), fmt='( i2.2 )') i( isecond )
	write( asctim( 22:23 ), fmt='( i2.2 )') i( icentisecond )
	lib$cvt_vectim = sys$bintim( asctim, j)
	return
	end
C***********************************************************************
C FUNCTION:  LIB$SUB_TIMES (POOR MAN'S VMS V5 RTL ROUTINE)
C PURPOSE:  SUBTRACT TWO ABSOLUTE SYSTEM TIMES TO GET A DELTA SYSTEM TIME
C APPLICATION:  FOR USE WITH TIM COOK'S TAR PACKAGE IN VMS V4.X ***ONLY***
c
	integer*4 function lib$sub_times( i, j, k)
	IMPLICIT NONE
	integer*2 i21, i22, i2
	integer*2 i(4), j(4), k(4)	!INPUT T2, T1; OUTPUT (T2-T1)
	integer*4 i41, i42, i4, i4c /'00010000'x/
	equivalence ( i41, i21), ( i42, i22), ( i4, i2)
	logical*4 carry
	INTEGER*4 ICOU
D
D	character*25 timch
D	integer*2 timlen
D	INTEGER*4 SYS$ASCTIM
c***********************************************************************
d	call sys$asctim( timlen, timch, i, 0)
d	type *, timch(:timlen)
d	call sys$asctim( timlen, timch, j, 0)
d	type *, timch(:timlen)
D
	i41=0
	i42=0
	i4=0
C
C PERFORM DIGIT SUBTRACTION BASE 2**16 USING I*4'S TO PREVENT OVERFLOW AND
C SIMULATE UNSIGNED ARITHMETIC
C
	carry = .false.		!INITIALIZE CARRY FLAG CLEAR
	do icou=1,4
	  i22=i(icou)		!I*2 TO I*2/I*4 EQUIVALENCE (ZEXT IS SAME)
	  i21=j(icou)
	  if ( carry) i42=i42-1	!ADJUST FOR CARRY OF PREVIOUS DIGIT
	  i4 = i42 - i41	!HERE'S THE BEEF!
C
	  if ( i4 .lt. 0) then	!CARRY:  FORCE 'DIGIT' >0; SET FLAG 
	    carry = .true.
C
	    i4=i4+i4c
	  else			!NO CARRY: CLEAR FLAG
	    carry = .false.
	  endif
C
	  k(icou) =i2		!SAVE I*2 RESULT
	enddo
C
C ERROR ON NEGATIVE RESULT
	if ( carry) then
	  lib$sub_times = 4
	else
C
C SET SIGN BIT ON QUADWORD OUTPUT TO INDICATE DELTA TIME
	  if ( k(1) .ne. '8000'x) then
	    k(1)=-k(1)
	  else
	    k(1)='8000'x
	  endif
	  k(2)=.not.k(2)
	  k(3)=.not.k(3)
	  k(4)=.not.k(4)
C
	  lib$sub_times = 1
D
d	call sys$asctim( timlen, timch, k, 0)
d	type *, timch(:timlen)
D
	endif
	return
	end
C***********************************************************************
c FUNCTION:  LIB$CVT_FROM_INTERNAL_TIME (POOR MAN'S VMS V5 RTL ROUTINE)
c PURPOSE:  convert BINTIM to delta seconds (assume i=lib$k_delta_seconds)
C APPLICATION:  FOR USE WITH TIM COOK'S TAR PACKAGE IN VMS V4.X ***ONLY***
c
	integer*4 function LIB$CVT_FROM_INTERNAL_TIME ( i, j, kk)
	IMPLICIT NONE
	integer*2 kk(4), k(4)	!INPUT AND LOCAL DELTA QUAD TIME
	integer*4 i, j, k4(2)	!I IS IGNORED, J IS OUTPUT DELTA SECONDS
	equivalence ( k, k4)	!
	real*8 jr		!LOCAL DELTA SECONDS, R*4 IS PROBABLY ENOUGH,
	REAL*8 scale		!		USE R*8 ANYWAY
	parameter ( scale = 1D7 )	!100ns-ticks / s
c
c INPUT delta time must look negative
c
	if ( kk(4) .ge. 0) then
	  lib$cvt_from_internal_time = 4
	  return
	endif
c
c convert (-) delta TWO'S COMPLEMENT QUAD to (+) delta QUAD
c
	if ( kk(1) .ne. '8000'x) then
	  k(1)=-kk(1)
	else
	  k(1)='8000'x
	endif
	k(2)=.not.kk(2)
	k(3)=.not.kk(3)
	k(4)=.not.kk(4)
c
c high order longword must scale to 0, calculate scaled remainder
c
	if ( DBLE( k4(2)) .gt. scale) then
	  lib$cvt_from_internal_time = 4
	  return
	endif
	jr = ( (2D0 **32) *k4(2)) / scale
c
c if necessary, add in scaled low-order-high/sign-bit and mask it out
c
	if ( k4(1) .lt. 0) then
	  jr = ( (2D0**31) / scale ) + jr
	  k4(1) = k4(1) .and. '7FFFFFFF'x
	endif
c
c add in rest of low order and convert to i*4 result
c
	j = ( k4(1) / scale) + jr
c
	lib$cvt_from_internal_time = 1
	return
	end
