.MCALL	.MODULE
.MODULE	IDATE,VERSION=06,COMMENT=<IDATE/SYSLIB>,IDENT=NO,LIB=YES

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  with  the
; inclusion of the above copyright notice.  This software,  or
; any other copies thereof, may not be provided  or  otherwise
; made available to any other person except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
;+
; RT-11 SYSTEM LIBRARY (SYSLIB) SUBROUTINE
;
;	IDATE
;
; FUNCTIONAL DESCRIPTION:
;
;   Subroutine IDATE converts the current RT-11 system date or a passed 
;   optional RT-11 date word to the equivalent integer values of MONTH, 
;   DAY and YEAR.
;
; CALLING SEQUENCE:
; 
;	CALL IDATE( MONTH, IDAY, IYEAR [,DATEWD])
;
;   where
;
;	MONTH, IDAY and IYEAR are returned INTEGER*2 values
;
;   and
;
;	DATEWD is an optionally supplied RT-11 date word.
;	If DATEWD is NOT supplied, the month, day and year
;	returned will be that of the current system date.
;
; PASSED ARGUMENTS:
;
;	MONTH	- }
;	IDAY	- } INTEGER*2 variables with random contents
;	IYEAR	- }
;	DATEWD	- INTEGER*2 RT-11 date word
;
; RETURNED ARGUMENT VALUES:
;
;	MONTH	- INTEGER*2 month in range of 1 through 12
;	IDAY	- INTEGER*2 day in range of 1 through 31
;	IYEAR	- INTEGER*2 year in range of 72 through 199
;
; RETURNED FUNCTION VALUE:
;
;	<none>
;
; MACROS REFERENCED:
;
;	.GTIM
;	.DATE
;-
;
	.SBTTL	IDATE - FORTRAN-callable system subroutine

	.MCALL	.DATE,	.GTIM

	.GLOBL	$SYSLB
	.GLOBL	$NXADR
	.WEAK	$MSARG

	.PSECT	SYS$I,I

	.ENABL	LSB

IDATE::	MOV	(R5)+,R4		; get argument count
	MOV	R5,R1			; save address of arg addresses
	MOV	#3,R2			; init arg count-down
10$:	CALL	$NXADR
	BCS	20$			; branch if no arg
	DEC	R2			; count argument
	BR	10$			; and keep going

20$:	TST	R2			; 3 args?
	BEQ	30$			; branch if so.
	INC	R2			; exactly 4 args?
	BNE	60$			; branch if so.
	MOV	@R0,R0			; Get optional date word argument
	BR	40$			; and use it

30$:	CMP	-(SP),-(SP)		; set up dummy block for .GTIM
	.GTIM	SP,SP			; dummy .GTIM to roll over date
	CMP	(SP)+,(SP)+		; restore stack
	.DATE				; get current system date into R0
40$:	MOV	#^c37,R2		; R2=0000000000011111 mask constant
	MOV	R0,R5			; R5=aammmmdddddyyyyy
	BIC	R2,R5			; R5=00000000000yyyyy year field
	MOV	R0,R3			; R3=aammmmdddddyyyyy
	ASR	R3			; R3=?aammmmdddddxxxx
	SWAB	R3			; R3=xxxxxxxx?aammmmx
	MOV	R3,R4			; R4=xxxxxxxx?aammmmx save for month
	BEQ	50$			; Zero, don't adjust year count
	BIC	#^c140,R3		; R3=000000000aa00000 age field
	ADD	R3,R5			; R5=000000000aayyyyy age + year
	ADD	#72.,R5			; real year = age + year + 72.
50$:	BIC	R2,R4			; R4=00000000000mmmmx
	ASR	R4			; R4=000000000000mmmm month
	ASL	R0			; R0=xxxxxdddddyyyyy0
	ASL	R0			; R0=xxxxdddddyyyyy00
	ASL	R0			; R0=xxxdddddyyyyy000
	SWAB	R0			; R0=yyyyyxxxxxxddddd
	BIC	R2,R0			; R0=00000000000ddddd day
	MOV	R4,@(R1)+		; return month value
	MOV	R0,@(R1)+		; return day value
	MOV	R5,@(R1)+		; return year value
	CLR	R0			; indicate no error
	RETURN
60$:	TRAP	$MSARG			; inadequate arg list
	RETURN

	.DSABL	LSB

	.END