home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB101 / timinc.for < prev    next >
Text File  |  1995-05-19  |  3KB  |  141 lines
  1. $STORAGE: 2
  2. $NOFLOATCALLS
  3.     Subroutine TIMINC(Line,Incmod)
  4. C ROUTINE TO ADD OR SUBTRACT TIME
  5.     character LINE(84)
  6.     INTEGER INCMOD
  7.     integer khar
  8. C INCMOD = 1 FOR DAY
  9. C     = 2 FOR WEEK
  10. C     = 3 FOR MONTH
  11. C     = 4 FOR YEAR
  12. C FORMAT IS
  13. C  +NN OR -NN : ADD/SUBTRACT NN DEFAULT UNITS
  14. C  +/- NNU (U=D,W,M,Y) TO ADD/SUBT THAT UNIT
  15.     INTEGER IDYR,IDMO,IDDY
  16.     COMMON/DEFDAT/IDYR,IDMO,IDDY
  17. C OUTPUT IN DEFDAT
  18.     INTEGER ML(14)
  19. C LENGTH OF MONTHS
  20.     INTEGER L(12)
  21.     EQUIVALENCE(L(1),ML(2))
  22.     DATA ML/31,31,28,31,30,31,30,31,31,30,31,30,31,31/
  23. C ML IS 14 LONG TO ALLOW REFS OUT OF BOUNDS TO L FOR NO.
  24. C DAYS IN MONTH...
  25.     ISIGN=1
  26.     IF(LINE(1).EQ.'-')ISIGN=-1
  27.     IF(LINE(1).EQ.'-'.OR.LINE(1).EQ.'+')LINE(1)=' '
  28. C SQUASH LINE DOWN AND MAKE SURE UPPER CASE
  29. C    DO 1 N=1,83
  30. C    LL=KHAR(LINE(N+1))
  31. C    IF(LL.GT.97.AND.LL.LT.255)LL=LL-32
  32. C1    LINE(N)=LL
  33.     LINE(84)=0
  34. C SCAN FOR D,W,M,Y FOR UNITS
  35.     DO 2 N=1,80
  36.     IF(LINE(N).EQ.'D'.OR.LINE(N).EQ.'d')THEN
  37.         INCMOD=1
  38.         LINE(N)=0
  39.         GOTO 3
  40.     ELSE IF (line(n).eq.'w'.or.LINE(N).EQ.'W')THEN
  41.         INCMOD=2
  42.         LINE(N)=0
  43.         GOTO 3
  44.     ELSE IF (line(n).eq.'m'.or.LINE(N).EQ.'M')THEN
  45.         INCMOD=3
  46.         LINE(N)=0
  47.         GOTO 3
  48.     ELSE IF (line(n).eq.'y'.or.LINE(N).EQ.'Y')THEN
  49.         INCMOD=4
  50.         LINE(N)=0
  51.         GOTO 3
  52.     END IF
  53. 2    CONTINUE
  54. 3    CONTINUE
  55. C NOW GRAB OFF DIGITS...
  56.     MAGN=0
  57. C MAGN GETS MAGNITUDE TO GRAB
  58.     DO 4 N=1,80
  59.     LL=KHAR(LINE(N))
  60.     IF(LL.EQ.32)GOTO 4
  61.     IF(LL.GE.48.AND.LL.LE.57) THEN
  62.         MAGN=10*MAGN+(LL-48)    
  63.     ELSE
  64.         GOTO 5
  65.     END IF
  66. 4    CONTINUE
  67. 5    CONTINUE
  68.     IF(MAGN.EQ.0)MAGN=1
  69. C MAGN NOW HAS MAGNITUDE, ISIGN HAS SIGN AND INCMOD HAS TYPE OF
  70. C INCREMENT.
  71.     IF(INCMOD.LE.2) THEN
  72.         INCTYP=1
  73.     ELSE
  74.         INCTYP=INCMOD-1
  75.     END IF
  76. C INCTYP IS 1 FOR DAY OR WEEK, 2 FOR MONTH, 3 FOR YEAR
  77.     IF(INCMOD.EQ.2)MAGN=MAGN*7
  78. C ADJUST WEEKS AS BEING 7 * DAYS AND TREAT TOGETHER
  79.     IF(INCTYP.EQ.1)THEN
  80.         IDDY=IDDY+ISIGN*MAGN
  81. C LOOP POINT IF WE MOVE FORWARD
  82. 100        IF(IDDY.GT.L(IDMO)) THEN
  83.           LYD=0
  84. C ACCOUNT FOR LEAP YEARS WHERE FEBRUARY IS 29 DAYS LONG...
  85.           IF(4*(IDYR/4).EQ.IDYR.AND.IDMO.EQ.2)LYD=1
  86.           IDDY=IDDY-L(IDMO)-LYD
  87.           IDMO=IDMO+1
  88.           IF(IDMO.GT.12)THEN
  89.             IDMO=1
  90.             IDYR=IDYR+1
  91.           END IF
  92.           GOTO 100
  93.         END IF
  94. C LOOP POINT IF WE MOVE BACK
  95. 110        IF(IDDY.LE.0)THEN
  96. C ACCOUNT FOR LEAP YEARS. NOTE ML IS PREV MONTH SO CHECK DEF MO=3
  97.           LYD=0
  98.           IF(4*(IDYR/4).EQ.IDYR.AND.IDMO.EQ.3)LYD=1
  99.           IDDY=IDDY+ML(IDMO)+LYD
  100.           IDMO=IDMO-1
  101.           IF(IDMO.LE.0)THEN
  102.             IDMO=12
  103.             IDYR=IDYR-1
  104.           END IF
  105.           GOTO 110
  106.         END IF
  107.     ELSE IF(INCTYP.EQ.2)THEN
  108.         IDMO=IDMO+ISIGN*MAGN
  109. 200        IF(IDMO.GT.12)THEN
  110.           IDMO=IDMO-12
  111.           IDYR=IDYR+1
  112.           GOTO 200
  113.         END IF
  114. 300        IF(IDMO.LE.0)THEN
  115.           IDMO=IDMO+12
  116.           IDYR=IDYR-1
  117.           GOTO 300
  118.         END IF
  119.     ELSE IF(INCTYP.EQ.3)THEN
  120.         IDYR=IDYR+ISIGN*MAGN
  121.     END IF
  122.     RETURN
  123.     END
  124.     FUNCTION KHAR(CHAR)
  125.     integer khar
  126.     CHARACTER CHAR
  127.     INTEGER*2 II,I255
  128.     LOGICAL*2 LL,L255
  129.     EQUIVALENCE(II,LL),(I255,L255)
  130.     DATA I255/127/
  131. c mask off all but 7 bits
  132. C RETURN INTEGER VALUE OF CHARACTER IN ARGUMENT
  133. C MASK OFF OTHER BYTE.
  134.     II=CHAR
  135.     LL=LL.AND.L255
  136.     KHAR=II
  137.     RETURN
  138.     END
  139.  
  140.  
  141.