SUBROUTINE SNPPIC
C THIS SUBROUTINE WILL ANALYZE THE INPUT DATA AND PRINT A PICTURE
C YOU CAN EXPECT TO GET 1 WARNING MESSAGE DURING COMPILATION
DIMENSION ILINE(133),INUM(50),ICHR(50)
COMMON ISET
DATA IBLNK/1H /
DO 4 I=1,133
4 ILINE(I)=IBLNK
5 K=1
10 READ (2,1000) (INUM(I),ICHR(I),I=1,ISET)
DO 40 I=1,ISET
IF (INUM(I) .NE. -1) GOTO 100
C HERE WE WRITE A LINE TO THE PRINTER AND GO BUILD ANOTHER
DO 15 L=K,133
15 ILINE(L)=ICHR(I)
WRITE (7,2000) (ILINE(K),K=1,133)
ILINE(1)=IBLNK
DO 20 K=2,133
20 ILINE(K)=ICHR(I)
K=1
C I=I+1
100 IF (INUM(I) .EQ. -2) GOTO 200
IF (INUM(I) .EQ. 0) GOTO 40
DO 30 J=1,INUM(I)
ILINE(K)=ICHR(I)
K=K+1
30 CONTINUE
40 CONTINUE
GOTO 10
C HERE WE EXIT THE PICTURE AND RETURN TO THE CALLING PROGRAM
200 RETURN
C FORMAT STATEMENTS
1000 FORMAT (25(I2,A1))
2000 FORMAT (133A1)
END
C SNOOPY CALENDAR PROGRAM FOR PDP-11 FORTRAN
C TAKEN FROM (NON-WORKING) IBM FORTRAN+BAL VERSION
C MODIFICATIONS BY T. M. KENNEDY 29-DEC-84
C
C COMPONENTS NEEDED ARE:
C SNPCAL.FOR (THIS FILE)
C SNPPIC.FOR - PICTURE DATA INTERPRETER
C -or-
C NULPIC.FOR - NULL PICTURE NON-INTERPRETER
C SNPCAL.DAT - DATA FILE FOR PICTURES
C
C OUTPUT PRODUCED:
C SNPCAL.OUT - PRINTER IMAGE OF THE DESIRED CALENDAR
C
C HOW TO COMPILE AND LINK IT:
C FORT/F77 SNPCAL.FOR/NOCK/NOTR
C FORT/F77 SNPPIC.FOR/NOCK/NOTR
C LINK/F77 SNPCAL,SNPCAL
C
C THIS PROGRAM IS DESIGNED TO BE COMPILED UNDER THE PDP-11 FORTRAN-77
C COMPILER VERSION 5.0-14 OR LATER. HOWEVER, IT DOES NOT UTILIZE ANY
C FORTRAN-77 EXTENSIONS, THEREFORE YOU SHULD BE ABLE TO COMPILE IT
C WITH ANY ANSI 66 FORTRAN-IV, SIMPLY BY CHANGING THE OPEN STATEMENTS.
C COMMENTED-OUT CODE FOR THE DEC RT-11 FORTRAN-IV COMPILER IS PROVIDED.
C
C ******************************************************************
C * *
C * PRINTS CALENDAR, ONE MONTH PER PAGE WITH PICTURES OPTIONAL. *
C * *
C * BEGINNING MONTH AND YEAR, ENDING MONTH AND YEAR MUST BE PRO- *
C * VIDED IN 4(I6) FORMAT ON A CARD IMMEDIATELY FOLLOWING *
C * CARD 98 OF DECK. *
C * *
C * IF GRID LINES ARE DESIRED, A 1 MUST APPEAR IN COLUMN 30 OF *
C * ABOVE CARD. A BLANK OR ZERO WILL SUPPRESS GRID LINES. *
C * *
C * ALL PICTURE DATA DECKS MUST BE TERMINATED WITH CODE -2. *
C * CONSECUTIVE -2*S WILL RESULT IN NO PICTURE BEING PRINTED *
C * FOR THAT MONTH. *
C * *
C * PICTURE FORMAT CODES -- *
C * -1 END OF LINE *
C * -2 END OF PICTURE *
C * -3 LIST CARDS, ONE PER LINE, FORMAT 13A6 *
C * -4 LIST CARDS, TWO PER LINE, FORMAT 11A6/11A6 *
C * -5 LIST CARDS, TWO PER LINE, FORMAT 12A6/10A6 *
C * *
C ******************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION AMONTH (12,7,13), ANAM(22), ANUM(2,10,5), NODS(12),
1 CAL(60,22)
COMMON ISET
C CALL OPEN (2,'SNPCAL.DAT',0,'RDO')
C OPEN (UNIT=2,FILE='U:SNPCAL.DAT',READONLY,STATUS='OLD')
OPEN (2,FILE='SNPCAL.DAT')
C CALL OPEN (7,'SNPCAL.OUT',0,'NEW')
C OPEN (UNIT=7,FILE='U:SNPCAL.OUT',STATUS='UNKNOWN')
C OPEN (UNIT=7,FILE='SNPCAL.OUT')
C CLOSE (UNIT=7,DISPOSE='DELETE')
C OPEN (UNIT=7,FILE='SNPCAL.OUT',STATUS='NEW')
OPEN (7,FILE='SNPCAL.OUT')
READ (2,1) (((AMONTH(I,J,K),K=1,13),J=1,7),I=1,12)
READ (2,2) (ANAM(I),I=1,22)
READ (2,3) (((ANUM(I,J,K),J=1,10),K=1,5),I=1,2)
READ (2,4) (NODS(I),I=1,12)
READ (2,1) BLANK,ONE,ALIN1,ALIN2,ALIN3,ALIN4
READ (2,4) MF,IYR,MTHLST,IYRLST,LNSW
ISET=25
DO 10 I=1,60
DO 10 J=1,22
10 CAL(I,J)= BLANK
CAL(1,1)= ONE
DO 20 J=1,22
20 CAL(11,J)=ANAM(J)
IF (LNSW) 122,142,122
122 DO 125 I=20,60,8
DO 125 J=1,22
125 CAL(I,J)=ALIN2
DO 140 J=4,19,3
I=13
127 DO 130 L=1,7
CAL(I,J)=ALIN1
130 I=I+1
IF (I-55) 135,135,140
135 CAL(I,J)=ALIN3
I=I+1
GO TO 127
140 CONTINUE
DO 141 I=20,60,8
141 CAL(I,1)=ALIN4
142 IDOW=(IYR-1751)+(IYR-1753)/4-(IYR-1701)/100+(IYR-1601)/400
IDOW=IDOW-7*((IDOW-1)/7)
55 IF (IYR-IYRLST) 60,65,100
60 ML=12
GO TO 70
65 ML=MTHLST
70 IY1=IYR/1000
NUMB=IYR-1000*IY1
IY2=NUMB/100
NUMB=NUMB-100*IY2
IY3=NUMB/10
NUMB=NUMB-10*IY3
IY4=NUMB
DO 72 J=1,5
CAL(J+3,1)=ANUM(2,IY1+1,J)
CAL(J+1,2)=ANUM(2,IY2+1,J)
CAL(J+1,21)=ANUM(2,IY3+1,J)
72 CAL(J+3,22)=ANUM(2,IY4+1,J)
LPYRSW=0
IF (IYR-4*(IYR/4)) 90,75,90
75 IF (IYR-100*(IYR/100)) 85,80,85
80 IF (IYR-400*(IYR/400)) 90,85,90
85 LPYRSW=1
90 NODS(2)=NODS(2)+LPYRSW
IF (MF-1) 100,110,95
95 MF=MF-1
DO 105 MONTH=1,MF
105 IDOW=IDOW+NODS(MONTH)
IDOW=IDOW-7*((IDOW-1)/7)
MF=MF+1
110 DO 51 MONTH=MF,ML
LSTDAY=NODS(MONTH)
DO 115 I=1,7
DO 115 JM=1,13
J=JM+4
115 CAL(I,J)=AMONTH(MONTH,I,JM)
IF (IDOW-1) 160,160,120
120 ID=IDOW-1
J=2
DO 155 K=1,ID
DO 150 I=14,18
CAL (I,J)= BLANK
150 CAL(I,J+1)= BLANK
J=J+3
155 CONTINUE
160 IDAY=1
II=14
25 J=3*IDOW-1
N=IDAY/10+1
I=II
DO 30 K=1,5
CAL(I,J)=ANUM(1,N,K)
30 I=I+1
N=IDAY-10*N+11
J=J+1
I=II
DO 35 K=1,5
CAL(I,J)=ANUM(2,N,K)
35 I=I+1
IDOW=IDOW+1
IF (IDOW-7) 45,45,40
40 IDOW=1
II=II+8
45 IDAY=IDAY+1
IF (IDAY-LSTDAY) 25,25,50
50 ID=IDOW
205 I=II
J=3*ID-1
DO 210 K=1,5
CAL(I,J)= BLANK
CAL(I,J+1)= BLANK
210 I=I+1
IF (ID-7) 215,220,220
215 ID=ID+1
GO TO 205
220 IF (II-54) 225,230,230
225 II=54
ID=1
GO TO 205
230 CALL SNPPIC
C WRITE OUTPUT TAPE 1,5,((CAL(I,J),J=1,22),I=1,60)
WRITE (7,5) ((CAL(I,J),J=1,22),I=1,60)
51 CONTINUE
IF (IYR-IYRLST) 235,100,100
235 NODS(2)=NODS(2)-LPYRSW
IYR=IYR+1
MF=1
GO TO 55
100 STOP
1 FORMAT (13A6)
2 FORMAT (11A6)
3 FORMAT (10A6)
4 FORMAT (12I6)
5 FORMAT (22A6)
6 FORMAT(/,1X)
END
|