| PROGRAM FUTURE
C ------------------------------------------------------------------------
C This program calculates a future date from a given date. The
C user specifies a base date and how many days future to go.
C The program calculates this future date and reports what it
C will be.
C
C AUTHOR: Barry D. Dysert
C ------------------------------------------------------------------------
IMPLICIT INTEGER*4 (A-Z)
INTEGER*4 timadr_q(2), future_q(2), addend_q(2), offset_q(2)
INTEGER*4 srcdsc_l2, dstdsc_l2
INTEGER*2 srcdsc_w1, dstdsc_w1
BYTE srcdsc(8), dstdsc(8)
CHARACTER ndays_t*12, offset_t*12, prod_t*63, timbuf_t*23
LOGICAL*1 tenflag
EQUIVALENCE (srcdsc_w1, srcdsc(1)), (srcdsc_b3, srcdsc(3))
EQUIVALENCE (srcdsc_b4, srcdsc(4)), (srcdsc_l2, srcdsc(5))
EQUIVALENCE (dstdsc_w1, dstdsc(1)), (dstdsc_b3, dstdsc(3))
EQUIVALENCE (dstdsc_b4, dstdsc(4)), (dstdsc_l2, dstdsc(5))
EXTERNAL DSC$K_DTYPE_Q, DSC$K_DTYPE_T, DSC$K_CLASS_S
C ------------------------------------------------------------------------
offset_t='864000016384' ! there are 864000016384 units in 1 day
offset_q(1)=711573504
offset_q(2)=201
C ----- get base date
10 TYPE 400
400 FORMAT(/'$Enter date (dd-mmm-yyyy): ')
READ(*,401,END=99) timbuf_t
401 FORMAT(a)
C convert it to system time
status=STR$UPCASE(timbuf_t,timbuf_t)
IF (.not. status) CALL LIB$STOP(%val(status))
length=INDEX(timbuf_t,' ')-1
IF (length .le. 0) length=LEN(timbuf_t)
status=SYS$BINTIM(timbuf_t(1:length),timadr_q)
IF (.not. status) CALL LIB$STOP(%val(status))
C ----- get number of days future
TYPE 402
402 FORMAT('$How many days future? ')
READ(*,*,END=99) ndays
C -----
C ----- future_q date will be calculated as:
C
C Q_fut_date = Q_given_date + ndays*864000016384
C
C the kicker is that in order to use STR$MUL, ndays must be
C converted to a decimal string (via OTS$CVT_L_TI); then
C convert the product to a quadword (via LIB$CVT_DX_DX); then
C add this quadword to the given_date (via LIB$ADDX).
C -----
C ----- if ndays is a multiple of 5, CVT_L_TI won't tack the extra
C ----- zeros on the end; instead it will set prodexp; it would then be
C ----- a pain to tack the zeros on ourselves, so to get around it, just
C ----- make sure ndays isn't a multiple of 5. We'll add 1 to it if it
C ----- is, and then subtract the offset after everything's done, just
C ----- before the ASCTIM.
tenflag=.FALSE.
IF (MOD(ndays,5) .eq. 0) THEN
ndays=ndays+1
tenflag=.TRUE.
ENDIF
C ----- convert ndays to string
status=OTS$CVT_L_TI(ndays,ndays_t,%val(12))
IF (.not. status) CALL LIB$STOP(%val(status))
C ----- multiply ndays by offset
status=STR$MUL(0,0,ndays_t,0,0,offset_t,prodsign,prodexp,prod_t)
IF (.not. status) CALL LIB$STOP(%val(status))
C ----- convert the result string to a quadword
srcdsc_w1=63 ! length
srcdsc_b3=%LOC(DSC$K_DTYPE_T) ! data type T
srcdsc_b4=%LOC(DSC$K_CLASS_S) ! class S
srcdsc_l2=%LOC(prod_t) ! address to be converted
dstdsc_w1=8 ! length
dstdsc_b3=%LOC(DSC$K_DTYPE_Q) ! data type Q
dstdsc_b4=%LOC(DSC$K_CLASS_S) ! class S
dstdsc_l2=%LOC(addend_q) ! address of destination
status=LIB$CVT_DX_DX(srcdsc,dstdsc)
IF (.not. status) CALL LIB$STOP(%val(status))
C ----- now add the addend_q to the given date to produce future_q date
status=LIB$ADDX(addend_q,timadr_q,future_q)
IF (.not. status) CALL LIB$STOP(%val(status))
C ----- if ndays was a multiple of 5, we added an extra day so now we
C ----- must subtract off the offset to get back to what we should have
IF (tenflag) THEN
status=LIB$SUBX(future_q,offset_q,future_q)
IF (.not. status) CALL LIB$STOP(%val(status))
ENDIF
C -----
C ----- convert system time of future_q date back to ascii for output
C -----
status=SYS$ASCTIM(,timbuf_t,future_q,%val(0))
IF (.not. status) CALL LIB$STOP(%val(status))
TYPE 403, timbuf_t(1:11)
403 FORMAT(' future date is ',a)
GO TO 10
C ----- bye bye
99 CALL EXIT
END
|