C***************************************************************************** C C Test of Date Support Syslib Routines. C Importable Functions C C----------------------------------- DATES ----------------------------------- C C TstDates --- Test Program For The DATE, IDATE, DATE4Y, C and IWEEKD Syslib Routines. C C This program tests the DATE, IDATE, DATE4Y, IWEEKD, and IDCOMP C SYSLIB routines for RT-11 Version 5.5 C C Adopted From Rob Hamilton's Test Program (30-Oct-87) C C Program : Date Support/ Dates.For C Adopted By: I. B. Sokari C Date: August 1988 C Last Edited: July 17, 1989 C Date Edited: July 29, 1989, RHH C Language: Fortran 77 C Note: Uses subroutines imported from both syslib and RTNS C libraries. C C***************************************************************************** C C List of functions: C DATE, IDATE, DATE4Y, IWEEKD, IDCOMP C C NOTE: C Four ( DATE, IDATE, DATE4Y, AND IWEEKD ) of the five Date C functions are tested inside one function TSTDATES C instead of four different functions as would normally be done. C This is to maximize the connectivity of these routines and minimize C the use of redundant/superflous variables. C C The fifth (IDCOMP) Date function is implemented as a separate C function DUE TO MEMORY RESTRICTIONS. C C***************************************************************************** Function TstDates C -------------------- DECLARATION OF VARIABLES -------------------- Integer*4 TstDates Integer*4 iydig4, iyx2 Integer*4 dayst4(3) Integer*4 monnam(12) ! Names of months Integer*2 iydigt(2) Integer*2 dayst2(6) Integer*2 monlen(12) ! length of months Integer*2 iwdy( 3, 8) ! IWEEKD out-of-range values Integer*2 ckflag Integer*2 iday, month, iyear, iwday, ndaym, styear, endyear Integer*2 TstCnt(16), iwflag Real*8 weekdy(7) Byte daystr(12), iddigt(2), outstr(80) Equivalence (iydigt, iydig4) Equivalence (daystr, dayst2, dayst4) c -------------------- INITIALIZATIONS -------------------- DATA weekdy / 'Sunday', 'Monday', 'Tuesday', 'Wednesdy', 1 'Thursday', 'Friday', 'Saturday' / c DATA monlen / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / c DATA monnam / 'JAN-', 'FEB-', 'MAR-', 'APR-', 'MAY-', 'JUN-', 1 'JUL-', 'AUG-', 'SEP-', 'OCT-', 'NOV-', 'DEC-' / c DATA iwdy / 0, 1, 87, ! month too low 1 1, 0, 87, ! day too low 2 13, 1, 87, ! month too high 3 1, 32, 87, ! day too high 4 1, 1, 71, ! year too low 5 1, 1, 200, ! year too high 4 1, 1, 1971, ! year too low 5 1, 1, 2100 / ! year too high c TstDates = 0 iwflag = 0 styear = 1972 ! Start testing from 1/1/1972 endyear = 2099 ! End test on 12/31/2099 Call CentLn( ' --- Testing IDATE ---\') c c Test IDATE for current system day c iday = 0 month = 0 iyear = 0 Call IDATE( month, iday, iyear) Encode( 63, 1001, outstr) month, iday, iyear 1001 format(' IDATE returns month=',I6,', day=',I6,' year=',I6, 1 ' << INSPECT\') Call CentLn( outstr) Call WriteLn Call ChkDate( month, iday, iyear, ckflag ) ! Check date IF (ckflag .ne. 0 .or. iyear .gt. 199) THEN Call MTFail( 'IDATE', 1) Call WriteLn Call CentLn( 1 ' ?IDATE-E-Returned values out of range\') Call WriteLn TstDates = TstDates .OR. 2**1 ENDIF Call CentLn( ' --- Testing DATE ---\') c c Test DATE for current system day c Do 100 k=1,12 100 daystr(k) = ' ' ! Blank out daystr daystr(10) = '?' ! To check for correct ! end of daystr Call DATE ( daystr) Encode( 39, 1003, outstr) (daystr(k),k=1,9) 1003 format(' DATE returns: "',9A1,'" << INSPECT\') Call CentLn( outstr) Call WriteLn C Check for correct end of daystr IF (daystr(10) .ne. '?') THEN Call MtFail( 'DATE', 1) Call WriteLn Call CentLn( 1 ' ?DATE-E-Returned characters exceeded 9-character limit\') Call WriteLn TstDates = TstDates .OR. 2**2 END IF Call CentLn( ' --- Testing DATE4Y ---\') c c Test DATE4Y for current system day c Do 120 k=1,11 120 daystr(k) = ' ' ! Blank out daystr daystr(12) = '$' ! To check for correct ! end of daystr Call DATE4Y ( daystr) Encode( 43, 1013, outstr) (daystr(k),k=1,11) 1013 format(' DATE4Y returns: "',11A1,'" << INSPECT\') Call CentLn( outstr) Call WriteLn IF (daystr(12) .ne. '$') THEN Call MtFail( 'DATE4Y', 1 ) Call WriteLn Call CentLn( 1 ' ?DATE4Y-E-Returned characters exceeded 11-character limit\') TstDates = TstDates .OR. 2**3 END IF Call CentLn( ' --- Testing IWEEKD ---\') c c Test IWEEKD for invalid arguments c Call CentLn( ' Testing IWEEKD for invalid arguments\') DO 125 i=1,8 iwday = IWEEKD( iwdy( 1,i), iwdy( 2,i), iwdy( 3,i)) IF (iwday .ne. -1) THEN Call MtFail( 'IWEEKD', 1 ) Call Write2Int( -1, 10 ) Call Write2Int( iwday, 10 ) Call WriteLn c write (5, 1016) iwday c 1016 format(' IWEEKD returned ',I6,'; expected -1') TstDates = TstDates .OR. 2**4 END IF 125 CONTINUE c c Test IWEEKD for current system day c Call CentLn( ' Testing IWEEKD for current System day\') iwday = IWEEKD( month, iday, iyear) Encode( 43, 1017, outstr) iwday, weekdy(iwday) 1017 format(' IWEEKD returns ',I2,' ( ',A8,') << INSPECT\') Call CentLn( outstr) Call WriteLn IF ( iwday .EQ. -1 ) THEN Call MtFail( 'IWEEKD', 2 ) Call Write2Int( -1, 10 ) Call Write2Int( iwday, 10 ) Call WriteLn TstDates = TstDates .OR. 2**5 END IF C C Test the Optional RT-11 DATE WORD for IDATE, DATE, and DATE4Y C for specified days C Call CentLn( 'Testing the optional date word argument\') Call CentLn( 'for IDATE, DATE, IWEEKD, and DATE4Y\') iexpct = 7 ! initialize on 1-Jan-72 = Saturday DO 160 iy=styear,endyear ! Test from Jan. 1972nt system day iwtest = 1 ! turn ON weekday test iyxx = iy-1900 Encode ( 4, 1033, iydigt ) iy 1033 format( I4) c Display the range of years currently under test. Assumes first year c is 1972, display ranges of eight years, and that 1972-4 (1968) is c evenly divisible by 8 ("(iy-4).and.7) .eq.0)") iyr2 = iy + 7 IF (iyr2 .gt. 2099) iyr2 = 2099 IF (((iy-4) .and. 7) .eq. 0) THEN encode ( 34, 1035, outstr) iy, iyr2 1035 format(' Testing for years ', I4,' - ',I4, '...\') Call CentLn( outstr) ENDIF c Loop for each month... DO 150 im=1,12 ! For 12 months ndaym = monlen(im) IF ((im .eq. 2) .AND. 1 (iy .and. 3) .eq. 0) ndaym = ndaym+1 ! Extra day in Feb. ! for leap year c Loop for each day in the month... DO 140 id=1,ndaym IF (( TstDates .and. 2**6) .eq. 0) THEN c determine the RT-11 date for use in the tests irt = IRTDAT( im, id, iy) c Test the OPTIONAL RT-11 DATE WORD parameter in IDATE Call IDATE( month, iday, iyear, irt) IF ( 1 (id .ne. iday) .or. (im .ne. month) .or. (iyxx .ne. iyear) D 2 .OR. (irt .eq. "11111) ! Test the test 3 ) THEN Call MtFail( 'IDATE', 2 ) encode ( 27, 1042, outstr) id, im, iyxx, 1 iday, month, iyear 1042 format( ' ',I2,'/',I2,'/',I4,'; ',I2,'/',I2,'/',I6 ) Call WriteString( outstr, 0, 27) Call WriteLn TstDates = TstDates .OR. 2**6 ENDIF ENDIF Encode ( 2, 1034, iddigt) id 1034 format( I2 ) IF ( iddigt(1) .EQ. ' ' ) iddigt(1) = '0' ! For leading ! blank in date C C Test the OPTIONAL RT-11 DATE WORD parameter in DATE C IF ((TstDates .and. 2**7) .eq. 0) THEN Call DATE( daystr(2), irt) C C Testing the Month Argument in DATE Routine C IF (dayst4(2) .NE. monnam(im) D 1 .OR. irt .eq. "11122 ! Test the test 1 ) THEN ! Is month name same ! as that in RT-11 ! Date Word? Call MtFail( 'DATE', 2 ) Call WriteString( monnam(im), 2, 4 ) Call WriteString( dayst4(2), 2, 4 ) Call WriteLn TstDates = TstDates .OR. 2**7 ENDIF ENDIF C C Test the Year Argument in DATE Routine C IF ((TstDates .and. 2**8) .eq. 0) THEN IF (dayst2(5) .ne. iydigt(2) D 1 .OR. irt .eq. "11133 ! Test the test 1 ) THEN ! Is year same as that ! in RT-11 Date Word? Call MtFail( 'DATE', 3 ) Call WriteString( iydigt(2), 2, 2 ) Call WriteString( dayst2(5), 2, 2 ) Call WriteLn TstDates = TstDates .OR. 2**8 ENDIF ENDIF C C Test the Day Argument in DATE Routine C IF ((TstDates .and. 2**9) .eq. 0) THEN IF ( (daystr(2) .NE. iddigt(1)) 1 .OR. (daystr(3) .NE. iddigt(2)) D 1 .OR. irt .eq. "11144 ! Test the test 1 ) THEN ! Is day of month same ! as that in RT-11 ! Date Word? Call MtFail( 'DATE', 4 ) Encode ( 39, 1055, outstr) iddigt, (daystr(k),k=2,10) 1055 format( ' Expected day: ',2A1, 1 '; Got string ',9A1) Call WriteString( outstr, 0, 39) Call WriteLn TstDates = TstDates .OR. 2**9 ENDIF ENDIF C C Test the OPTIONAL RT-11 DATE WORD parameter in DATE4Y C IF ((TstDates .and. (2**10+2**11+2**12)) .eq. 0) THEN Call DATE4Y( daystr(2), irt) C C Test the Month Argument in DATE4Y Routine C IF (dayst4(2) .ne. monnam(im) D 1 .OR. irt .eq. "11155 ! Test the test 1 ) THEN ! Is month same as ! that in RT-11 Date Word? Call CentLn( ' Failed month comparison in DATE4Y\') Call WriteLn Call MtFail( 'DATE4Y', 2 ) Call WriteString( monnam(im), 2, 4 ) Call WriteString( dayst4(2), 2, 4 ) Call WriteLn TstDates = TstDates .OR. 2**10 END IF C C Test the Year Argument in DATE4Y Routine C IF (dayst4(3) .ne. iydig4 D 1 .OR. irt .eq. "11166 ! Test the test 1 ) THEN ! Is year same as that ! in RT-11 Date Word? Call CentLn( ' Failed year comparison in DATE4Y\') Call WriteLn Call MtFail( 'DATE4Y', 3 ) Call WriteString( iydig4, 2, 4 ) Call WriteString( dayst4(3), 2, 4 ) Call WriteLn TstDates = TstDates .OR. 2**11 END IF IF (iwtest .ne. 0) THEN iwday = IWEEKD( im, id, iy) ! get day of week IF (iwday .ne. iexpct D 1 .OR. irt .eq. "11177 ! Test the test 1 ) THEN Call MtFail( 'IWEEKD', 3) Call WriteLn Encode( 50, 1067, outstr) (daystr(k),k=2,12), 1 iwday, iexpct 1067 format(' For ',11A1,', IWEEKD returned ',I2, 1 '; expected ',I2,'\') Call CentLn( outstr) Call Writeln iwtest = 0 ! turn test OFF for remainder END IF ! of year END IF ! iwtest END IF ! TstDates .and. xxx iexpct = iexpct + 1 ! next day of week if (iexpct .gt. 7) iexpct = 1 ! wrap to 1st of week 140 CONTINUE ! next day, 150 CONTINUE ! next month, 160 CONTINUE ! next year c Display a summary Call TestFail( TstDates) Call Writeln Call CentLn( ' --- Testing IDATE completed ---\') Call CentLn( ' --- Testing DATE completed ---\') Call CentLn( ' --- Testing DATE4Y completed ---\') Call CentLn( ' --- Testing IWEEKD completed ---\') Call WriteLn RETURN END C C============================== IDCOMP ====================================== C Function TstIdcomp Integer*4 TstIdcomp Integer*2 ckflag Integer*2 idco( 7, 15) ! IDCOMP test values Integer*2 TstCnt(16) Byte outstr(80) Character*3 expct1, expct2 C C -------------------- INITIALIZATIONS -------------------- C DATA idco / 1, 1, 72, 1, 2, 72, -1, ! change day only 1 1, 31, 72, 2, 31, 72, -1, ! change month only 2 2, 28, 72, 3, 1, 72, -1, ! cross month 3 12, 31, 72, 1, 1, 72, 1, ! change day and month 4 12, 31, 72, 1, 1, 73, -1, ! cross year 5 10, 31, 87, 11, 1, 87, -1, ! cross month 6 10, 31, 87, 10, 1, 87, 1, ! backwards by days 6 10, 31, 87, 10, 30, 87, 1, ! backwards by days 6 10, 25, 87, 9, 25, 87, 1, ! backward by month 6 10, 25, 87, 10, 25, 86, 1, ! backward by year 6 10, 25,104, 10, 25,103, 1, ! backward by age 7 1, 1, 72, 1, 1, 99, -1, ! advance years 7 1, 1, 72, 1, 1, 104, -1, ! advance ages 8 1, 1, 72, 1, 1, 136, -1, ! advance ages 9 2, 2, 99, 1, 1, 168, -1 / ! advance ages c TstIdcomp = 0 nerror = 0 expct1(1:3) = '> 0' expct2(1:3) = '< 0' C C Test IDCOMP routine (against the current date). C Call CentLn( ' --- Testing IDCOMP ---\') 1999 Call CentLn( 1 ' Enter integer MONTH, DAY, and YEAR for a date 2 in the FUTURE: \') Call CentLn( ' Separate month, day, and year with a blank\') read( 5, *) im, id, iy Call ChkDate( im, id, iy, ckflag ) ! Check to ensure date ! supplied is within RT-11 ! date range. IF ( ckflag .ne. 0 ) GO TO 1999 irt1 = IRTDAT( im, id, iy) idcval = IDCOMP( irt1) ! Compare date against current ! system date. IF ( idcval .LE. 0 ) THEN Call MtFail( 'IDCOMP', 1 ) Call WriteString( expct1, 3, 3 ) Call Write2Int( idcval, 10) Call WriteLn Call WriteLn c write (5, 1024) idcval, 1 c 1024 format(' IDCOMP returned ',I2,'; expected ',I2) TstIdcomp = TstIdcomp .OR. 2**1 END IF 2020 Call CentLn( 1 ' Enter integer MONTH, DAY, and YEAR for a date 2 in the PAST: \') Call CentLn( ' Separate month, day, and year with a blank\') read( 5, *) im, id, iy Call ChkDate( im, id, iy, ckflag ) ! Check to ensure date ! supplied is within RT-11 ! date range. IF ( ckflag .ne. 0 ) GO TO 2020 irt1 = IRTDAT( im, id, iy) idcval = IDCOMP( irt1) ! Compare against current ! current system date. IF ( idcval .GE. 0 ) THEN Call MtFail( 'IDCOMP', 2 ) Call WriteString( expct2, 3, 3 ) Call Write2Int( idcval, 10) Call WriteLn Call WriteLn TstIdcomp = TstIdcomp .OR. 2**2 END IF Call IDATE (im, id, iy) irt1 = IRTDAT( im, id, iy) Call CentLn( ' Calling IDCOMP with today''s date (DEFAULT)\') idcval = IDCOMP( irt1) IF (idcval .ne. 0) THEN Call MtFail( 'IDCOMP', 3 ) Call Write2Int( 0, 10 ) Call Write2Int( idcval, 10 ) Call WriteLn TstIdcomp = TstIdcomp .OR. 2**3 END IF c c Test IDCOMP for dates in "idco" c Call CentLn( 'Calling IDCOMP on date unit boundaries\') DO 130 i=1,15 irt1 = IRTDAT( idco(1,i), idco(2,i), idco(3,i)) irt2 = IRTDAT( idco(4,i), idco(5,i), idco(6,i)) idcval = IDCOMP( irt1, irt2) IF (idcval .ne. idco(7, i) D 1 .OR. (i .eq. 4) ! Test the test 2 ) THEN Encode ( 66, 1031, outstr) (idco( j,i),j=1,6), 1 idcval, idco( 7, i) 1031 format( ' IDCOMP of ',6I4, ' returned ', I2, 1 '; expected ',I2,'\') Call CentLn( outstr) Call WriteLn nerror = nerror + 1 END IF 130 CONTINUE IF (nerror .gt. 0) THEN Call MtFail( 'IDCOMP', 4) Call WriteLn TstIdcomp = TstIdcomp .OR. 2**4 END IF c Display summary for IDCOMP tests Call TestFail( TstIdcomp) Call WriteLn Call CentLn( ' --- Testing IDCOMP completed ---\') Call WriteLn RETURN END C C------------------------------ IRTDAT --------------------------------------- C Integer Function IRTDAT( month, iday, iyear) c c Given a month, day and year, create an RT-11 date word. c iylocl = iyear IF (iyear .lt. 199) iylocl = iyear + 1900 iage = (iylocl-1972)/32 iyrlow = MOD( iylocl-1972, 32) IRTDAT = (iage*"40000) + (month*"2000) + (iday*"40) + iyrlow RETURN END C C------------------------------ ChkDate -------------------------------------- C Subroutine ChkDate( im1, id1, iy1, ckflag ) Integer*2 im1, id1, iy1, ckflag Integer*2 monlen(12) ! length of months Data monlen / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / C C Check if date supplied is within RT-11 date range C ckflag = 0 IF ( iy1 .LT. 72) go to 910 IF ( iy1 .GT. 199 .AND. iy1 .LT. 1972) go to 910 IF ( iy1 .GT. 2099) go to 910 IF (( im1 .LE. 0 ) .OR. ( im1 .GT. 12 )) go to 930 ndaym = monlen(im1) IF (im1.eq.2 .and. ((iy1.and.3).eq.0)) ndaym = ndaym+1 IF (( id1 .LE. 0 ) .OR. ( id1 .GT. ndaym)) go to 920 RETURN 910 Call CentLn( 1 ' ?IDCOMP-E-Year is not within proper range \') Go to 980 920 Call CentLn( 1 ' ?IDCOMP-E-Day is not within proper range \') Go to 980 930 Call CentLn( 1 ' ?IDCOMP-E-Month is not within proper range \') 980 Call WriteLn ckflag = 1 990 RETURN END