c----------------------------------------------------------------------- c c Month-at-a-glance subroutine c c part of Mitch Wyle's DTC program c c Input: c line - 72 byte string; Format: M [dd[19[yy]]] c c Output: c display screen (see below) c c Line c 1 Prevmonth Nextmonth c 2 SMTWTFS SMTWTFS C 3-8 Calendar Calendar c 9/10 Y e a r M o n t h Y e a r c 11 S M T W T F S c 13-23 C a l e n d a r c c Lines 9/10 are double-height/double-width c Odd lines 11-23 are double-width c Even lines 10-22 are blank c c----------------------------------------------------------------------- c c Modified 850318, several changes- CG c Display today's date in current, prev or next month c in reverse video c Write out >>> only <<< non-blank flags (*'s) c Speed-up of month display (actually in dtcdspmth subr) c Months mixed-case and centered (GABY) c Modified 850809 - display IBIGYR both sides of month, DH/DW SUBROUTINE month ! (line) c Declarations: include 'comdtc.inc/nolist' include 'apptdtc.inc/nolist' include 'escdtc.inc/nolist' byte temp(4) ! temporary string converting array integer id ! Julian Day integer im ! Julian Month integer iy ! Julian Year integer prveof, eofflg byte monthn(9), ! string month name 1 lmonth(9) logical*1 lmneven(12)/ ! Entries true if length of name is even 1 .false., .true., .false., .false., .false., .true., 2 .true., .true., .false., .false., .true., .true./ logical*1 lmnodd(12) ! Entries true if length of name is odd 1 /.true., .false., .true., .true., .true., .false., 2 .false., .false., .true., .true., .false., .false./ Byte out(79) ! The output string and * array byte rchr ! Flag set (or reset) character byte ln1 ! Same as line(1) equivalence (line, ln1) include 'stmtfunc.for/nolist' c Trim off the M from command line: if ((ln1 .and. ucmask) .eq. 'M') 1 call shrink(1, ifnb, lnb) call dtcdatcvt(2) ! Decode date string im=idmo ! Pick up result from common id=iddy iy=ibigyr call dtcidate(irm,ird,iry) ! Real month,day,year, for display highlight c Move the cursor to the top part, clear the screen write(iterm,600) esc,homescrn, esc,clrscrn 600 format ('+', 4a, $) c Now start building the output string: (out) encode(4, 20, temp, err=11) iy 11 continue 20 format(i4) c Calculate nominal prev, next month numbers lm = im - 1 ly = iy nm = im + 1 ny = iy If ( im .eq. 1 ) then lm = 12 ly = iy - 1 else If ( im .eq. 12 ) then nm = 1 ny = iy + 1 End If C PRINT PREVIOUS MONTH call dtcmthnam(lm,lmonth) C PRINT NEXT MONTH CALENDAR AT TOP call dtcmthnam(nm,monthn) C WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS ix = 3 if (lmneven(lm)) ix = ix + 1 call dtcat(ix, 1) write(iterm,6) lmonth ix = 61 if (lmneven(nm)) ix = ix + 1 call dtcat(ix, 1) write(iterm,6) monthn 6 format ('+', 9(a1, x), $) call dtcat(1, 2) write(iterm,7) 7 format('+','Su Mo Tu We Th Fr Sa',T60,'Su Mo Tu We Th Fr Sa',$) c *** call dtcat(35, 7) ! Center year above cur month c *** write(iterm,96) temp c *** 96 format ('+', 4(x, a1)) c Now display last month, header for this month, and next month: c Last month to upper-left corner of screen call dtcalcdow(ib,il,lm,ly) call dtcdspmth(ib,il,0,0,-1,0) If ((irm .eq. lm) .and. (iry .eq. ly)) then ! today in rev video irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0) irwk = (ird + ib - 2)/7 ! Week in month (orig 0) call dtcat ((irdw*3) + 1, irwk + 3) write (iterm,684) esc,revattr, ird, esc,resetvattr end if c Next month to upper-right corner of screen call dtcalcdow(ib,il,nm,ny) call dtcdspmth(ib,il,58,0,-1,0) If ((irm .eq. nm) .and. (iry .eq. ny)) then ! today in rev video irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0) irwk = (ird +ib - 2)/7 ! Week in month (orig 0) call dtcat ((irdw*3) + 59, irwk + 3) write (iterm,684) esc,revattr, ird, esc,resetvattr end if c display big banner header name of this month: c call dtcat(ix,9) call dtcat(1,9) call dtcmthnam(im,monthn) ix = 11 if (lmneven(im)) ix = ix + 1 ixx = ix - 9 ixy = 14 - ix write(iterm,8) '+', esc,dhdw1, temp, monthn, temp 8 format(3a, 4(a1, x), x, 9(x,a1), x, 4(x, a1), $) write(iterm,8) ' ', esc,dhdw2, temp, monthn, temp c Now print the week day headers for this month, and the days for this month: call dtcat(1,11) write(iterm,10), esc,dwide 10 format('+', 2a, 1 'Sun Mon Tues Weds Thurs Fri Sat', $) c x x x x x x x x write (iterm,138) ! Mark double-width lines 1 esc,'[13H', esc,dwide, 2 esc,'[15H', esc,dwide, 3 esc,'[17H', esc,dwide, 4 esc,'[19H', esc,dwide, 5 esc,'[21H', esc,dwide, 6 esc,'[23H', esc,dwide 138 format ('+', 24a, $) c call dtcalcdow(ib,il,im,iy) c call dtcdspmth(ib,il,8,8,8,1) ! For single-width call dtcdspmth(ib,il,1,3,9,1) ! For double-width c If ((irm .eq. im) .and. (iry .eq. iy)) then ! today in rev video c irdw = mod (ird + ib - 2, 7) ! Day of week (orig 0) irwk = (ird + ib - 2)/7 ! Week in month (orig 0) call dtcat ((irdw*6)+2, (irwk*2)+13) if (id .eq. ird) then write (iterm,684) esc,'[4;7m', ird, esc,resetvattr else write (iterm,684) esc,revattr, ird, esc,resetvattr go to 685 ! And show looking-at date end if 684 format('+', 2a, i2, 2a, $) else 685 irdw = mod (id + ib - 2, 7) ! Day of week (orig 0) irwk = (id + ib - 2)/7 ! Week in month (orig 0) call dtcat ((irdw*6)+2, (irwk*2)+13) write (iterm,684) esc,'[4m', id, esc,resetvattr end if if (rdspfg .eq. 0) then rchr='*' out(1) = ' ' else rchr=' ' out(1) = '*' end if Do i= 2, 31 ! set the out array to all blanks: out(i) = out(1) end do c Now for files I/O to put *'s on days with appointments: irqhash(1) = ihymd(iy, im, 1) ! Want entries for irqhash(2) = ihymd(iy, im, 31) ! current month eofflg = -1 prveof = 0 do while (prveof .ge. 0) call dtcrdappt(eofflg, 0) if (eofflg .ge. 0) out(ihd) = rchr prveof = eofflg end do c Have now accumulated all info about current month, c go back and flag appropriate days iy = 13 ip = ib - 1 Do i=1,il ip = ip + 1 ! increment day number If ( ip .gt. 7 ) then ! is it Sunday again? ip = 1 ! reset day to Sunday. iy = iy + 2 ! move down one line End If if (out(i) .ne. ' ') then ! Write only non-blank entries !!!! c ix = 11 * ip - 3 ix = 6 * ip - 5 call dtcat(ix,iy) ! position cursor write(iterm,231) out(i) ! write * to screen 231 format('+',a1, $) end if end do ! # days in month 999 call dtcat(1,23) ! Position for next prompt end