* CALENDAR FOR REAL PROGRAMMERS 05/03/2017 CALENDAR CSECT USING CALENDAR,R13 BASE REGISTER B 72(R15) SKIP MY SAVEAREA DC 17F'0' MY SAVEAREA STM R14,R12,12(R13) SAVE CALLER'S REGISTERS ST R13,4(R15) LINK BACKWARD ST R15,8(R13) LINK FORWARD LR R13,R15 SET ADDRESSABILITY L R4,YEAR YEAR SRDA R4,32 . D R4,=F'4' YEAR//4 LTR R4,R4 IF YEAR//4=0 BNZ LYNOT L R4,YEAR YEAR SRDA R4,32 . D R4,=F'100' YEAR//100 LTR R4,R4 IF YEAR//100=0 BNZ LY L R4,YEAR YEAR SRDA R4,32 . D R4,=F'400' IF YEAR//400 LTR R4,R4 IF YEAR//400=0 BNZ LYNOT LY MVC ML+2,=H'29' ML(2)=29 LEAPYEAR LYNOT SR R10,R10 LTD1=0 LA R6,1 I=1 LOOPI1 C R6,=F'31' DO I=1 TO 31 BH ELOOPI1 XDECO R6,XDEC EDIT I LA R14,TD1 TD1 AR R14,R10 TD1+LTD1 MVC 0(3,R14),XDEC+9 SUB(TD1,LTD1+1,3)=PIC(I,3) LA R10,3(R10) LTD1+3 LA R6,1(R6) I=I+1 B LOOPI1 ELOOPI1 LA R6,1 I=1 LOOPI2 C R6,=F'12' DO I=1 TO 12 BH ELOOPI2 ST R6,M M=I MVC D,=F'1' D=1 MVC YY,YEAR YY=YEAR L R4,M M C R4,=F'3' IF M<3 BNL GE3 L R2,M M LA R2,12(R2) M+12 ST R2,M M=M+12 L R2,YY YY BCTR R2,0 YY-1 ST R2,YY YY=YY-1 GE3 L R2,YY YY LR R1,R2 YY SRA R1,2 YY/4 AR R2,R1 YY+(YY/4) L R4,YY YY SRDA R4,32 . D R4,=F'100' YY/100 SR R2,R5 YY+(YY/4)-(YY/100) L R4,YY YY SRDA R4,32 . D R4,=F'400' YY/400 AR R2,R5 YY+(YY/4)-(YY/100)+(YY/400) A R2,D R2=YY+(YY/4)-(YY/100)+(YY/400)+D LA R5,153 153 M R4,M 153*M LA R5,8(R5) 153*M+8 D R4,=F'5' (153*M+8)/5 AR R5,R2 ((153*M+8)/5+R2 LA R4,0 . D R4,=F'7' R4=MOD(R5,7) 0=SUN 1=MON ... 6=SAT LTR R4,R4 IF J=0 BNZ JNE0 LA R4,7 J=7 JNE0 BCTR R4,0 J-1 MH R4,=H'3' J*3 LR R10,R4 J1=J*3 LR R1,R6 I SLA R1,1 *2 LH R11,ML-2(R1) ML(I) MH R11,=H'3' J2=ML(I)*3 MVC TD2,BLANK TD2=' ' LA R4,TD1 @TD1 LR R5,R11 J2 LA R2,TD2 @TD2 AR R2,R10 @TD2+J1 LR R3,R5 J2 MVCL R2,R4 SUB(TD2,J1+1,J2)=SUB(TD1,1,J2) LR R1,R6 I MH R1,=H'144' *144 LA R14,DA-144(R1) @DA(I) MVC 0(144,R14),TD2 DA(I)=TD2 LA R6,1(R6) I=I+1 B LOOPI2 ELOOPI2 XPRNT SNOOPY,132 PRINT SNOOPY L R1,YEAR YEAR XDECO R1,PG+56 EDIT YEAR XPRNT PG,L'PG PRINT YEAR MVC WDLINE,BLANK WDLINE=' ' LA R10,1 LWDLINE=1 LA R8,1 K=1 LOOPK3 C R8,=F'6' DO K=1 TO 6 BH ELOOPK3 LA R4,WDLINE @WDLINE AR R4,R10 +LWDLINE MVC 0(20,R4),WDNA SUB(WDLINE,LWDLINE+1,20)=WDNA LA R10,20(R10) LWDLINE=LWDLINE+20 C R8,=F'6' IF K<6 BNL ITERK3 LA R10,2(R10) LWDLINE=LWDLINE+2 ITERK3 LA R8,1(R8) K=K+1 B LOOPK3 ELOOPK3 LA R6,1 I=1 LOOPI4 C R6,=F'12' DO I=1 TO 12 BY 6 BH ELOOPI4 MVC MOLINE,BLANK MOLINE=' ' LA R10,6 LMOLINE=6 LR R8,R6 K=I LOOPK4 LA R2,5(R6) I+5 CR R8,R2 DO K=I TO I+5 BH ELOOPK4 LR R1,R8 K MH R1,=H'10' *10 LA R3,MO-10(R1) MO(K) LA R4,MOLINE @MOLINE AR R4,R10 +LMOLINE MVC 0(10,R4),0(R3) SUB(MOLINE,LMOLINE+1,10)=MO(K) LA R10,22(R10) LMOLINE=LMOLINE+22 LA R8,1(R8) K=K+1 B LOOPK4 ELOOPK4 XPRNT MOLINE,L'MOLINE PRINT MONTHS XPRNT WDLINE,L'WDLINE PRINT DAYS OF WEEK LA R7,1 J=1 LOOPJ4 C R7,=F'106' DO J=1 TO 106 BY 21 BH ELOOPJ4 MVC PG,BLANK CLEAR BUFFER LA R9,PG PGI=0 LR R8,R6 K=I LOOPK5 LA R2,5(R6) I+5 CR R8,R2 DO K=I TO I+5 BH ELOOPK5 LR R1,R8 K MH R1,=H'144' *144 LA R4,DA-144(R1) DA(K) BCTR R4,0 -1 AR R4,R7 +J MVC 0(21,R9),0(R4) SUBSTR(DA(K),J,21) LA R9,22(R9) PGI=PGI+22 LA R8,1(R8) K=K+1 B LOOPK5 ELOOPK5 XPRNT PG,L'PG PRINT BUFFER LA R7,21(R7) J=J+21 B LOOPJ4 ELOOPJ4 LA R6,6(R6) I=I+6 B LOOPI4 ELOOPI4 L R13,4(0,R13) RESTORE PREVIOUS SAVEAREA POINTER LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS XR R15,R15 SET RETURN CODE TO 0 BR R14 RETURN TO CALLER SNOOPY DC CL57' ',CL18'INSERT SNOOPY HERE',CL57' ' YEAR DC F'1969' <== 1969 MO DC CL10' JANUARY ',CL10' FEBRUARY ',CL10' MARCH ' DC CL10' APRIL ',CL10' MAY ',CL10' JUNE ' DC CL10' JULY ',CL10' AUGUST ',CL10'SEPTEMBER ' DC CL10' OCTOBER ',CL10' NOVEMBER ',CL10' DECEMBER ' ML DC H'31',H'28',H'31',H'30',H'31',H'30' DC H'31',H'31',H'30',H'31',H'30',H'31' WDNA DC CL20'MO TU WE TH FR SA SU' M DS F D DS F YY DS F TD1 DS CL93 TD2 DS CL144 MOLINE DS CL132 WDLINE DS CL132 PG DC CL132' ' BUFFER FOR THE LINE PRINTER XDEC DS CL12 BLANK DC CL144' ' DA DS 12CL144 YREGS END CALENDAR