home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol281 / snoopy.for < prev    next >
Encoding:
Text File  |  1986-06-11  |  6.0 KB  |  205 lines
  1.  
  2. C       **********************************************************************
  3. C       *                                                                    *
  4. C       * PRINTS CALENDAR, ONE MONTH PER PAGE WITH PICTURES OPTIONAL.        *
  5. C       *                                                                    *
  6. C       * DIVIDED IN 4(I6) FORMAT ON A CARD IMMEDIATELY FOLLOWING            *
  7. C       * CARD 98 OF DECR.                                                   *
  8. C       *                                                                    *
  9. C       * IF GRID LINES ARE DESIRED, A 1 MUST APPEAR IN COLUMN 30 OF         *
  10. C       * ABOVE CARD,  A BLANK OR ZERO WILL SUPPRESS GRID LINES.             *
  11. C       *                                                                    *
  12. C       * ALL PICTURE DATA DECKS MUST BE TERMINATED WITH CODE -2.            *
  13. C       * CONSECUTIVE -2'S WILL RESULT IN NO PICTURE BEING PRINTED           *
  14. C       * FOR THAT MONTH.                                                    *
  15. C       *                                                                    *
  16. C       * PICTURE FORMAT CODES --                                            *
  17. C       *       -1      END OF LINE                                          *
  18. C       *       -2      END OF PICTURE                                       *
  19. C       *       -3      LIST CARDS, ONE PER LINE, FORMAT 13A6                *
  20. C       *       -4      LIST CARDS, TWO PER LINE, FORMAT 11A6/11A6           *
  21. C       *       -5      LIST CARDS, TWO PER LINE, FORMAT 12A6/10A6           *
  22. C       *                                                                    *
  23. C       **********************************************************************
  24.  
  25.         PROGRAM SNOOPY
  26.         IMPLICIT REAL*8 (A-H,O-Z)
  27.         DIMENSION AMONTH (12,7,13), ANAM(22), ANUM(2,10,5),
  28.      1             NODS(12), CAL(60,22)
  29.         COMMON ISET
  30.  
  31. C       GIVE THE FILES NAMES!!
  32.         CALL OPEN(6,'CALENDARPRN',0)
  33.  
  34.         READ (7,1) (((AMONTH(I,J,K),K=1,13),J=1,7),I=1,12)
  35.         READ (7,2) (ANAM(I),I=1,22)
  36.         READ (7,3) (((ANUM(I,J,K),J=1,10),K=1,5),I=1,2)
  37.         READ (7,4)  (NODS(I),I=1,12)
  38.         READ (7,1) BLANK,ONE,ALIN1,ALIN2,ALIN3,ALIN4
  39.         READ (7,4) MF,IYR,MTHLST,IYRLST,LNSW
  40.         ISET=25.
  41.         DO 10 I=1,60
  42.         DO 10 J=1,22
  43. 10      CAL(I,J)=BLANK
  44.         CAL(1,1)=ONE
  45.         DO 20 J=1,22
  46. 20      CAL(11,J)=ANAM(J)
  47.         IF (LNSW) 122,142,122
  48. 122     DO 125 I=20,60,8
  49.         DO 125 J=1,22
  50. 125     CAL(I,J)=ALIN2
  51.         DO 140 J=4,19,3
  52.         I=13.
  53. 127     DO 130 L=1,7
  54.         CAL(I,J)=ALIN1
  55. 130     I=I+1
  56.         IF (I-55) 135,135,140
  57. 135     CAL(I,J)=ALIN3
  58.         I=I+1
  59.         GO TO 127
  60. 140     CONTINUE
  61.         DO 141 I=20,60,8
  62. 141     CAL(I,1)=ALIN4
  63. 142     IDOW=(IYR-1751)+(IYR-1753)/4-(IYR-1701)/100+(IYR-1601)/400
  64.         IDOW=IDOW-7*((IDOW-1)/7)
  65. 55      IF (IYR-IYRLST) 60,65,100
  66. 60      ML=12.
  67.         GO TO 70
  68. 65      ML=MTHLST
  69. 70      IY1=IYR/1000
  70.         NUMB=IYR-1000*IY1
  71.         IY2=NUMB/100
  72.         NUMB=NUMB-100*IY2
  73.         IY3=NUMB/10
  74.         NUMB=NUMB-10*IY3
  75.         IY4=NUMB
  76.         DO 72 J=1,5
  77.         CAL(J+3,1)=ANUM(2,IY1+1,J)
  78.         CAL(J+1,2)=ANUM(2,IY2+1,J)
  79.         CAL(J+1,21)=ANUM(2,IY3+1,J)
  80. 72      CAL(J+3,22)=ANUM(2,IY4+1,J)
  81.         LPYRSW=0
  82.         IF (IYR-4*(IYR/4)) 90,75,90
  83. 75      IF (IYR-100*(IYR/100)) 85,80,85
  84. 80      IF (IYR-400*(IYR/400)) 90,85,90
  85. 85      LPYRSW=1
  86. 90      NODS(2)=NODS(2)+LPYRSW
  87.         IF (MF-1) 100,110,95
  88. 95      MF=MF-1
  89.         DO 105 MONTH=1,MF
  90. 105     IDOW=IDOW+NODS(MONTH)
  91.         IDOW=IDOW-7*((IDOW-1)/7)
  92.         MF=MF+1
  93. 110     DO 51 MONTH=MF,ML
  94.         LSTDAY=NODS(MONTH)
  95.         DO 115 I=1,7
  96.         DO 115 JM=1,13
  97.         J=JM+4
  98. 115     CAL(I,J)=AMONTH(MONTH,I,JM)
  99.         IF (IDOW-1) 160,160,120
  100. 120     ID=IDOW-1
  101.         J=2
  102.         DO 155 K=1,ID
  103.         DO 150 I=14,18
  104.         CAL(I,J)= BLANK
  105. 150     CAL(I,J+1)= BLANK
  106.         J=J+3
  107. 155     CONTINUE
  108. 160     IDAY=1
  109.         II=14
  110. 25      J=3*IDOW-1
  111.         N=IDAY/10+1
  112.         I=II
  113.         DO 30 K=1,5
  114.         CAL(I,J)=ANUM(1,N,K)
  115. 30      I=I+1
  116.         N=IDAY-10*N+11
  117.         J=J+1
  118.         I=II
  119.         DO 35 K=1,5
  120.         CAL(I,J)=ANUM(2,N,K)
  121. 35      I=I+1
  122.         IDOW=IDOW+1
  123.         IF (IDOW-7) 45,45,40
  124. 40      IDOW=1
  125.         II=II+8
  126. 45      IDAY=IDAY+1
  127.         IF (IDAY-LSTDAY) 25,25,50
  128. 50      ID=IDOW
  129. 205     I=II
  130.         J=3*ID-1
  131.         DO 210 K=1,5
  132.         CAL(I,J)= BLANK
  133.         CAL(I,J+1)= BLANK
  134. 210     I=I+1
  135.         IF (ID-7) 215,220,220
  136. 215     ID=ID+1
  137.         GO TO 205
  138. 220     IF (II-54) 225,230,230
  139. 225     II=54
  140.         ID=1
  141.         GO TO 205
  142. 230     CALL PICTUR
  143. C       PRINT PICTURE!!! TO AN OUTPUT FILE !!!!!
  144.         WRITE (6,5)  ((CAL(I,J),J=1,22),I=1,60)
  145. 51      CONTINUE
  146.         IF (IYR-IYRLST) 235,100,100
  147. 235     NODS(2)=NODS(2)-LPYRSW
  148.         IYR=IYR+1
  149.         MF=1
  150.         GO TO 55
  151. 100     STOP
  152. 1       FORMAT (13A6)
  153. 2       FORMAT (11A6)
  154. 3       FORMAT (10A6)
  155. 4       FORMAT (12I6)
  156. 5       FORMAT (22A6)
  157.         END
  158. C
  159. C
  160. C       THIS IS THE SUBROUTINE SECTION
  161. C
  162. C
  163.         SUBROUTINE PICTUR
  164.         DIMENSION KRD1(25),CRD2(25),ALIN(132)
  165.         COMMON I
  166.         DATA PLUS,AMPSAN/1H+,1H+/
  167. 11      N=0
  168. 10      I=I+1
  169.         IF (I-25) 14,14,13
  170. 13      I=1
  171.         READ (7,1,END=15) (KRD1(K),CRD2(K),K=1,25)
  172. 14      M=N+1
  173.         IF (KRD1(I)) 15,10,16
  174. 15      IF (KRD1(I)+2) 18,35,17
  175. 18      IF (KRD1(I)+4) 55,44,33
  176. 17      N=132.
  177.         GO TO 20
  178. 16      N=N+KRD1(I)
  179. 20      DO 21 J=M,N
  180. 21      ALIN(J)=CRD2(I)
  181.         IF (N-132) 10,31,31
  182. 31      IF (ALIN(1).EQ.AMPSAN) ALIN(1)=PLUS
  183.         WRITE (6,2) (ALIN(J),J=1,132)
  184.         GO TO 11
  185. 33      READ (7,5) (ALIN(J),J=1,13),ICHK
  186.         WRITE (6,7) (ALIN(J),J=1,13)
  187.         IF (ICHK+2) 77,35,33
  188. 44      READ (7,3) (ALIN(J),J=1,22),ICHK
  189.         WRITE (6,4) (ALIN(J),J=1,22)
  190.         IF (ICHK+2) 77,35,44
  191. 55      READ (7,6) (ALIN(J),J=1,22),ICHK
  192.         WRITE (6,4) (ALIN(J),J=1,22)
  193.         IF (ICHK+2) 77,35,55
  194. 77      I=25
  195.         GO TO 11
  196. 35      RETURN
  197. 1       FORMAT (25(I2,A1))
  198. 2       FORMAT (132A1)
  199. 3       FORMAT (11A6/11A6,I2)
  200. 4       FORMAT (22A6)
  201. 5       FORMAT (13A6,I2)
  202. 6       FORMAT (12A6/10A6,I2)
  203. 7       FORMAT (30X,13A6)
  204.         END
  205.