C PROGRAM SNPCAL(SNPDAT,OUTPUT,TAPE5=SNPDAT,TAPE6=OUTPUT) IMPLICIT INTEGER(A-Z) 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 TO BE READ IN ON UNIT 2 * 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 78A1,I2 * C * -4 LIST CARDS, TWO PER LINE, FORMAT 66A1/66A1,I2 * C * -5 LIST CARDS, TWO PER LINE, FORMAT 72A1/60A1,I2 * C * * C ****************************************************************** C REAL AMONTH,ANAM,ANUM,CNUM,CAL REAL BLANK,ONE,ALIN1,ALIN2,ALIN3,ALIN4 C CHARACTER*2 FF CHARACTER*1 BLANK_IT/' '/ CHARACTER*40 IAPPTMNT CHARACTER*12 BUFFER INTEGER IAPPT/-1/ DIMENSION AMONTH(12,7,26),ANAM(44),ANUM(2,20,5),CAL(60,44), 1ONE(2),ALIN1(2),ALIN2(2),ALIN3(2),ALIN4(2),NODS(12),CNUM(2,20,5), 2IAPPTYR(1000),IAPPTMON(1000),IAPPTDAY(1000),IAPPTHR(1000), 3IAPPTMNT(1000) C COMMON IN,OUT,CTL,ISET,IAPPT C C INITIALIZE THE INPUT AND OUTPUT UNIT ID'S C IN = 5 CTL = 2 OUT = 6 APPT = 8 SUMM = 9 FF(1:2)= ' '//CHAR(12) ! FORM FEED CCCC C C C C RESTART POINT FOR NEW CALENTARS CCCC 998 CONTINUE C C READ MONTHS INTO CORE C READ (IN,1) (((AMONTH(I,J,K),K=1,26),J=1,7),I=1,12) C C READ DAYS OF THE WEEK INTO CORE C READ (IN,2) (ANAM(I),I=1,44) C C READ THE LARGE NUMBERS INTO CORE C READ (IN,3) (((ANUM(I,J,K),J=1,20),K=1,5),I=1,2) C C READ THE DAY OF THE MONTH NUMBERS INTO CORE C READ (IN,3) (((CNUM(I,J,K),J=1,20),K=1,5),I=1,2) C C READ MUMBER OF DAYS IN EACH MONTH INTO CORE C READ (IN,4) (NODS(I),I=1,12) C C READ MATRIX CHARACTERS (GRID CHARACTERS) C READ (IN,199) BLANK,ONE,ALIN1,ALIN2,ALIN3,ALIN4 199 FORMAT(A3,3X,10A3) C C READ IN PARAMETERS TO GENERATE THE DESIRED CALENDER FORM DEVICE 2 C READ(CTL,4,END=999) MF,IYR,MTHLST,IYRLST,LNSW,IPICT C C READ IN THE APPOINTMENTS FILE C OPEN(UNIT=APPT,STATUS='OLD',ERR=2200) DO 2000 I=1,1000 2106 READ(APPT,2110,END=2200) IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), 1 IAPPTHR(I),IAPPTMNT(I) 2110 FORMAT(I4,I2,I2,I4,A40) IAPPTHR(I) = IAPPTHR(I) * 10 IF (index(IAPPTMNT(I),'"') .ne. 0) Goto 2106 IF (index(IAPPTMNT(I),'!>') .ne. 0) then Iappthr(I) = -Iappthr(I) idot = index(IAPPTMNT(I),'!>') ilen = len(IAPPTMNT(I)) Iapptmnt(I)(1:ilen-2) = Iapptmnt(I)(1:(idot-1))// & Iapptmnt(I)((idot+2):ilen) endif IAPPT = I C* WRITE(*,2120) I,IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), C* 1 IAPPTHR(I),IAPPTMNT(I) C* 2120 FORMAT(' I:',I2,' YR:',I4,' MON:',I2,' DAY:',I2,' HR:',I5,':',A40) 2000 CONTINUE C 2200 SUMMOPEN = 0 OPEN(UNIT=SUMM,STATUS='NEW',ERR=2550,CARRIAGECONTROL='FORTRAN') SUMMOPEN = 1 WRITE(SUMM,2545) 2545 FORMAT(' APPOINTMENT SCHEDULE SUMMARY ') C C SET PICTURE GENERATOR CNTL POINTER; SET SO NEW CNTL LINE FETCHED. C 2550 ISET=25 C C CLEAR THE CALENDER PRINT BUFFER C DO 10 I=1,60 C DO 10 J=1,44 10 CAL(I,J)= BLANK C C STORE DAYS OF THE WEEK IN CALENDER OUTPUT BUFFER C DO 20 J=1,44 20 CAL(11,J)=ANAM(J) C C C IF LNSW NON-ZERO (COL 30 OF PARAM CARD) SET UP CRID LINES C STORE HORZ GIRD LINES FIRST C IF (LNSW) 122,142,122 122 DO 125 I=20,60,8 C DO 125 J=1,22 JAAA1=2*J-1 JAAA2=2*J CAL(I,JAAA1)=ALIN2(1) 125 CAL(I,JAAA2)=ALIN2(2) C C STORE VERTICAL GRID LINES C DO 140 J=4,19,3 I=13 C 127 DO 130 L=1,7 JAAA1=2*J-1 JAAA2=2*J CAL(I,JAAA1)=ALIN1(1) CAL(I,JAAA2)=ALIN1(2) 130 I=I+1 C IF (I-55) 135,135,140 135 JAAA1=2*J-1 JAAA2=2*J CAL(I,JAAA1)=ALIN3(1) CAL(I,JAAA2)=ALIN3(2) I=I+1 GO TO 127 140 CONTINUE C C STORE HORZ GRID AT MARGINS C DO 141 I=20,60,8 CAL(I,1)=ALIN4(1) 141 CAL(I,2)=ALIN4(2) C C ----------------------------------------------------------------- C C DETERMINE CALENDAR YEAR/START DAYS/LEAP YEARS ETC... C C 142 IDOW=(IYR-1751)+(IYR-1753)/4-(IYR-1701)/100+(IYR-1601)/400 IDOW=IDOW-7*((IDOW-1)/7) C C DETERMINE IF END PROG/IF NEW YEAR/IF INPUT MONTH TO BE USED C 55 IF (IYR-IYRLST) 60,65,100 C C SET LASST MONTH = DEC BECAUSE CURRENT YEAR NOT = START YEAR C 60 ML=12 GO TO 70 C C SET LAST MONTH TO INPUT VALUE C 65 ML=MTHLST CCCC C DETERMINE WHAT DIGITS OF YEAR ARE CCCC C DETERMINE 1000'S OF YEARS C 70 IY1=IYR/1000 C C DETERMINE 100'S OF YEAR C NUMB=IYR-1000*IY1 IY2=NUMB/100 C C DETERMINE 10'S OF YEAR C NUMB=NUMB-100*IY2 IY3=NUMB/10 C C DETERMINE 1'S OF YEARS C NUMB=NUMB-10*IY3 IY4=NUMB DO 72 J=1,5 IY1X2 = IY1 * 2 IY2X2 = IY2 * 2 IY3X2 = IY3 * 2 IY4X2 = IY4 * 2 CAL(J+3,1) = ANUM(2,IY1X2+1,J) CAL(J+3,2) = ANUM(2,IY1X2+2,J) CAL(J+1,3) = ANUM(2,IY2X2+1,J) CAL(J+1,4) = ANUM(2,IY2X2+2,J) CAL(J+1,41) = ANUM(2,IY3X2+1,J) CAL(J+1,42) = ANUM(2,IY3X2+2,J) CAL(J+3,43) = ANUM(2,IY4X2+1,J) CAL(J+3,44) = ANUM(2,IY4X2+2,J) 72 CONTINUE 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,26 J=JM+8 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,2)=BLANK CAL(I,2*J-1)=BLANK CAL(I,2*J)=BLANK CAL(I,2*J+1)=BLANK 150 CAL(I,2*J+2)=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,2*J-1)=CNUM(1,2*N-1,K) IF (K .EQ. 1) THEN IPOSI = I IPOSK = 2*J-1 ENDIF CAL(I,2*J)=CNUM(1,2*N,K) 30 I=I+1 N=IDAY-10*N+11 J=J+1 I=II DO 35 K=1,5 CAL(I,2*J-1)=CNUM(2,2*N-1,K) CAL(I,2*J)=CNUM(2,2*N,K) 35 I=I+1 C* C* BHZ C* IF (IAPPT .GT. -1) THEN ILINES = 1 DO 2130 I = 1,IAPPT IF (IAPPTYR(I) .EQ. IYR .AND. IAPPTMON(I) .EQ. MONTH .AND. 1 IAPPTDAY(I) .EQ. IDAY) THEN IF (ILINES .GT. 4 ) GOTO 2145 IPOSI = IPOSI + 1 ENCODE(4,2600,BUFFER)ABS(IAPPTHR(I)) 2600 FORMAT (I4) IF (IAPPTHR(I) .LT. 0) BUFFER(1:4) = 'NOTE' BUFFER(1:12) = BUFFER(1:4) // ':' // IAPPTMNT(I)(1:7) C* WRITE (*,*) ' BUFFER:',BUFFER,'<' ENCODE(3,2610,CAL(IPOSI,IPOSK ))BUFFER(1:3) ENCODE(3,2610,CAL(IPOSI,IPOSK+1))BUFFER(4:6) ENCODE(3,2610,CAL(IPOSI,IPOSK+2))BUFFER(7:9) ENCODE(3,2610,CAL(IPOSI,IPOSK+3))BUFFER(10:12) 2610 FORMAT (A3) 2145 IF (SUMMOPEN .EQ. 1) THEN C* WRITE(*,2649)I,IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), C* 1 IAPPTHR(I),IAPPTMNT(I)(1:40) C* 2649 FORMAT('I: ',I2,' YEAR: ',I4,' MONTH: ',I2,' DAY: ',I2, C* 1 ' HOUR: ',I5,' To Do: ',A40) IF (IAPPTHR(I) .gt. 0) THEN WRITE(SUMM,2650)IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), 1 IAPPTHR(I),IAPPTMNT(I)(1:40) 2650 FORMAT(' YEAR: ',I4,' MONTH: ',I2,' DAY: ',I2, 1 ' HOUR: ',I4,' To Do: ',A40) ELSE WRITE(SUMM,2655)IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), 1 IAPPTMNT(I)(1:40) 2655 FORMAT(' YEAR: ',I4,' MONTH: ',I2,' DAY: ',I2, 1 ' ***** NOTE: **** ',A40) WRITE(SUMM,2657)IAPPTYR(I),IAPPTMON(I),IAPPTDAY(I), 1 IAPPTMNT(I)(1:40) 2657 FORMAT('+ YEAR: ',I4,' MONTH: ',I2,' DAY: ',I2, 1 ' ***** NOTE: **** ',A40) ENDIF ENDIF ILINES = ILINES + 1 ENDIF 2130 CONTINUE ENDIF C* C* BHZ C* 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,2*J-1)=BLANK CAL(I,2*J)=BLANK CAL(I,2*J+1)=BLANK CAL(I,2*J+2)=BLANK 210 I=I+1 IF (ID-7) 215,220,220 215 ID=ID+1 GO TO 205 220 IF ( II .EQ. 54 ) GO TO 230 ID=1 225 II=54 GO TO 205 230 IF (IPICT .GT. 0) THEN WRITE(OUT,7)FF,BLANK_IT,BLANK_IT,BLANK_IT,BLANK_IT CALL PICTUR 7 FORMAT(A,4(/,1X,A)) ENDIF C WRITE OUTPUT TAPE 1,5,((CAL(I,J),J=1,44),I=1,60) WRITE(OUT,7)FF,BLANK_IT,BLANK_IT,BLANK_IT,BLANK_IT WRITE(OUT,5) ((CAL(I,J),J=1,44),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 REWIND IN GO TO 998 999 CONTINUE IF (SUMMOPEN .EQ. 1) CLOSE(SUMM) STOP 1 FORMAT (26A3) 2 FORMAT (22A3) 3 FORMAT (20A3) 4 FORMAT (13I6) 5 FORMAT (44A3) END C ******************************************************************* C * * C * PICTURE GENERATOR SUBPROGRAM. ROSS HERBERT * C * * C * * C ******************************************************************* C C C ENTRY POINT --- PICTUR CCCC SUBROUTINE PICTUR C IMPLICIT INTEGER(A-Z) C DIMENSION KRD1(25),CRD2(25),ALIN(132) C COMMON IN,OUT,CTL,I C DATA PLUS /'+'/ DATA AMPSAN /'*'/ C C Put in a title C write(out,6) 6 format(57X,'--- SYMCAS INC. ---') CCCC C C C INITIALIZE OUTPUT BUFFEC COLUMN INDEX FOR NEW LINE CCCC 11 N=0 CCCC C INCREMENT CONTROL LINE POINTER TO PROCESS NEXT CNTL CMD CCCC 10 I=I+1 C C DETERMINE IF ALL CMDS ON CNTL CARD HAVE BEEN EXECUTED C IF SO READ NEXT CNTL CARD C IF( I .LE. 25 ) GO TO 14 13 I=1 READ (IN,1) (KRD1(K),CRD2(K),K=1,25) C C DETERMINE NEXT POSITION IN BUFFER TO STORE CHARACTERS C 14 M=N+1 CCCC C C DETERMINE WHAT THE CONTROL FUNCTION IS C =PLUS REPEAT THE CHARACTER FOLLOWING THE CNTL CODE THAT MANY TIMES C =-1 FILL REST OF LINE WITH CHAR FOLLOWING CNTL CODE & PRINT C =-2 END OF POCTURE; RETURN TO CALLING PROGRAM C =-3 PRINT FOLLOWING CARDS 1 PER LINE (SEE BELOW) C =-4 PRINT FOLLOWING CARD 2 PER LINE (SEE BELOW) C =-5 PRINT FOLLOWING CARDS 2 PER LINE (SEE BELOW) C = OTHER NO-OP C CCCC CC = KRD1(I) IF( CC .EQ. 0 ) GO TO 10 IF( CC .GT. 0 ) N = N + CC IF( CC .EQ. -1 ) N = 132 IF( CC .EQ. -2 ) GO TO 35 IF( CC .EQ. -3 ) GO TO 33 IF( CC .EQ. -4 ) GO TO 44 IF( CC .EQ. -5 ) GO TO 55 IF( CC .LT. -5 ) GO TO 10 C C SEE IF N IS PAST END OF BUFFER; IS SO SET TO END OF BUFFER C IF( N .GT. 132 ) N = 132 C C STORE CHARACTER CRD2(2) IN THE NEXT KRD1(I) POSITIONS OR END OF LINE C 20 DO 21 J=M,N 21 ALIN (J)=CRD2(I) C C DETERMINE IF LINE IS TO BE PRINTED; IF NOT PROCESS NEXT ENTRY C IF( N .LT. 132 ) GO TO 10 C C IF THE CHARAGE CONTROL CHARACTER IN THE BUFFER IS '*' MAKE IT A '+' C 31 IF (ALIN(1).EQ.AMPSAN) ALIN(1)=PLUS WRITE(OUT,904) (ALIN(J),J=1,132) C31 WRITE OUTPUT TAPE 1,2, (ALIN(J),J=1,132) GO TO 11 CCCC C C LIST THE FOLLOWING CARDS OONE PER LINE. COLUMNS 1-78 WILL BE C PRINTED. THE CARD WILL BE CENTERED ON THE PAGE (CARD COLUMN 1 C WILL BE PRINTED ON PAGE COLUMN 28) CCCC 33 CONTINUE READ(IN,905) (ALIN(J),J=1,78),ICHK 905 FORMAT (78A1,I2) C WRITE(OUT,907) (ALIN(J),J=1,78) 907 FORMAT (1X,27X,78A1,26X) C C COLUMNS 79-80 CONTAIN CONTROL INFORMATION C =-1 OR BLANK READ & PRINT NEXT CARD C =-2 END OF PICTURE; RETURN TO CALLING PROGRAM C =-3 PROCESS NEXT CONTROL LINE CARD C IF (ICHK+2) 77,35,33 CCCC C C LIST THE FOLLOWING CARDS TWO PER LINE. COLUMNS 2-66 OF CARD 1 IN C COLUMNS 1-65 OF LINE, COLUMNS 1-66 OF CARD 2 IN COLUMNS 66-131 C OF LINE. COLUMN 1 OF CARD 1 WILL CONTAIN THE CARRAGE CNTL CHAR CCCC 44 CONTINUE READ(IN,903) (ALIN(J),J=1,132),ICHK 903 FORMAT (66A1/66A1,I2) C WRITE(OUT,904) (ALIN(J),J=1,132) 904 FORMAT (132A1) C C COLUMNS 67-68 OF CARD 2 CONTAIN CONTROL INFORMATION C =-1 OR BLANK READ & PRINT NEXT TWO CARDS C =-2 END OF PICTURE; RETURN TO CALLING PROGRAM C =-3 PROCESS NEXT CONTROL LINE CARD C IF (ICHK+2) 77,35,44 CCCC C C LIST THE FOLLOWING CARDS TWO PER LINE. COLUMNS 2-72 OF CARD 1 IN C COLUMNS 1-71 OF LINE, COLUMNS 1-60 OF CARD 2 IN COLUMNS 72-131 C OF LINE. COLUMN 1 OF CARD 1 WILL CONTAIN THE CARRAGE CNTL CHAR. CCCC 55 CONTINUE READ(IN,906) (ALIN(J),J=1,132),ICHK 906 FORMAT (72A1/60A1,I2) C WRITE(OUT,904) (ALIN(J),J=1,132) C C COLUMNS 61-62 OF CARD 2 CONTAIN CONTROL INFORMATION C =-1 OR BLANK READ & PRINT NEXT TWO CARDS C =-2 END OF PICTURE; RETURN TO CALLING PROGRAM C =-3 PROCESS NEXT CONTROL LINE CARD. C IF (ICHK+2) 77,35,55 CCCC C SET FLAG TO READ NEW CONTROL LINE CARD, THEN GO TO TOP OF LOOP CCCC 77 I=25 GO TO 11 CCCC C C C EXIT CCCC 35 RETURN C C C C C 1 FORMAT (25(I2,A1)) END