calendar

[Dave Schuller]

Happy winter solstice.

below is a FORTRAN program which produces monthly calendars in Postscript.
It compiles and runs on Irix 4.0.5 and Irix 5.3 machines.
It could conceivably run on other Unix machines, but i have no resources
for testing that.

The calendar page has been developed for U.S. 8.5" x 11" paper, but I
think it may work acceptably with A4.

=======================================================================
              "The gene is the basic unit of selfishness"
                   - Richard Dawkins in The Selfish Gene
=======================================================================
                        Dave Schuller
                        University of California-Irvine
                        schuller at indigo2.biomol.uci.edu
                        modern man in a post-modern world

----------------------- pscal.f -----------------------------------------------
	program pscal
c
c		djms Unix version apr 1995
c
c		produce calendar for given month and year as Postscript file
c		requires unix utilities cal, time, wait to be present (they are on Irix)
c		default month and year are taken from current date;
c		can be overridden by command line arguments for month and year:
c		e.g.:  pscal 12 1995
c		will produce calendar for december 1995
c		(note that year 95 and year 1995 are not equivalent)
c		e.g.: pscal 12
c		will produce calendar for december of current year
c		usually you will want to pipe the output to a file:
c		pscal 12 1995 >dec95.ps
c
c
        integer i_arg, n_arg, iargc, temp, i
	external time
	integer time
	integer itime, itarray(9)
	integer test, wait, status
	integer month, year
	integer clen, true_clen, zip_check
	character*80 line
	character*2 short_text
	character*9 weekday(7)
c
	data weekday /'Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday',
     *	'Friday', 'Saturday' /
c
c
c	fill in current month and year as default (Irix Unix fashion)
	itime = time()
	call ltime(itime, itarray)
	month = itarray(5) + 1
	year  = itarray(6) + 1900

c
c               look for command line arguments
        n_arg = iargc()
        if (n_arg .NE. 0) then
c	    recover month
            call getarg(1, line)
	    read(line, *, end=666, err=666) temp
	    month = temp
	  if (n_arg .gt. 1) then
c	    recover year
	    call getarg(2, line)
	    read(line, *, end=666, err=666) temp
	    year = temp
	  endif
	endif

	if (month .lt. 1 .or. month .gt. 12) then
	  stop ' PSCAL> bad month'
	endif

c	have year and date; call 'cal'

	write(line,'(a4, 1x, i2, 1x, i5, 1x, a20)')
     &	  'cal ',month, year, '> time_temp_asdfasdf'
	call system(line)

c	wait for completion of file write
	status = 0
	test = wait(status)
	
	open (unit=10, file='time_temp_asdfasdf',carriagecontrol='LIST',
     &	status='OLD', err=667, form='FORMATTED')


c	Postscript file header, define routines
c
	write(6,'(A)') '%!Postscript'
	write(6,*) '90 rotate'			!set landscape orientation
	write(6,*) '0 -612 translate'
	write(6,*) '106 45 { dup mul exch'	!goodgray shades
	write(6,*) '	dup mul add 1.0'
	write(6,*) '	exch sub } setscreen'
c
	write(6,*) '/rightjust {'		!routine to rightjustify txt
	write(6,*) 'moveto'
	write(6,*) 'dup stringwidth pop neg 0 rmoveto'
	write(6,*) 'show} def'
c
	write(6,*) '/leftjust {'		!routine to leftjustify txt
	write(6,*) 'moveto'
	write(6,*) 'show} def'
c
	write(6,*) '/center { moveto'		!routine to center txt
	write(6,*) 'dup stringwidth pop 2 div neg'
	write(6,*) '0 rmoveto show } def'
c
c					!write month and year
	write(6,*) '/Helvetica findfont'
	write(6,*) '72 scalefont setfont'

c
c	first line is month and year; e.g. 'April 1995'
	read(10,'(A)',end=668, err=668) line
	call left_just(line)
	clen = true_clen(line)

 	write(6,*) '(', line(1:clen), ') 396 512 center'

c	  !read and discard 'S  M Tu  W Th  F S' line
c	  !write full weekday names
	read(10,'(A)',end=668, err=668) line
	write(6,'(A)') '/Helvetica-Bold findfont'
	write(6,'(A)') '17 scalefont setfont'
	do i = 1,7
	  write(6,210) weekday(i), i * 100 - 4
 210	  format('(',a9,') ',i3,' 470 center')
	end do

c	set up font for dates
	write(6,*) '/Helvetica-Bold findfont'
	write(6,*) '50 scalefont setfont'

 300	continue

c	  read, write a line of dates

	  read(10,'(A)',end=669, err=668) line
	  if (zip_check(line) .eq. 0) goto 669

c					!draw boxes
	  write(6,'(A)') '0 setgray'
	  do i = 0, 7
	    write(6,220) i * 100 + 46, 458, i *100 + 46, 390
 220	    format(i3,1x,i3,' moveto ',i3,1x,i3, ' lineto stroke')
	  end do
	  do i = 0, 1
	    write(6,220) 46, 458 - (i * 68), 746, 458 - (i * 68)
	  end do

c					!write dates
	  write(6,'(A)') '0.8 setgray'
c
	  do i = 1, 7
	    read(line((i*3-2):(i*3-1)), '(A2)') short_text
	    write(6,250) short_text, (i * 100 + 30), 402
 250	    format ('(',a2,') ',i3,1x,i3,' rightjust')
	  end do

	  write(6,'(A)') '0 -68 translate'
	goto 300



c	each day of week is 100 wide; left margin 46, right margin 46
c	top margin 46, bottom margin 46, each week 68 high, daynames 36, title 72
c	title 396 494
c	daynames x 458
c	week boxes 458 - 5x68 or 6x68



 666	continue
	stop 'PSCAL> bad command line argument'
 667	continue
	stop 'PSCAL> err opening temp file'
 668	continue
	stop 'PSCAL> err reading temp file'
 669	continue
c	finish output, terminate
	write(6,*) 'showpage'
	close(6)
	open (unit=10, file='time_temp_asdfasdf',
     &	status='OLD', dispose='DELETE')
	close(10, dispose='DELETE')

	end

c==========================================================================
	integer function true_clen( string )
C**************************************************************************
c	find length of string, excluding trailing blanks
	character*(*) string
	integer clen, i
c
	true_clen = 0
	clen = len(string)
	do i = clen, 1, -1
	  if (string(i:i) .ne. ' ') then
	    true_clen = i
	    return
	  endif
	end do
c	if reach end of loop, string is all blank, return with 0.
	return
	end

c==========================================================================
	subroutine left_just( string )
C**************************************************************************
c	left-justify character string
c
	character*(*) string
	integer clen, i
	integer true_clen
c
	clen = true_clen(string)
	if (clen .gt. 0) then
	  do i = 1, clen
	    if (string(i:i) .ne. ' ') then
	      if (i .gt. 1) then
		string = string(i:clen)
	      endif
	      return
	    endif
	  end do
	endif

	return
	end

c==========================================================================
	integer function zip_check( string )
C**************************************************************************
c	return 0 if nothing but spaces; otherwise return 1
c
	character*(*) string
	integer clen, i
	integer true_clen
c
	zip_check = 0

	clen = true_clen(string)
	if (clen .gt. 0) then
	  do i = 1, clen
	    if (string(i:i) .ne. ' ') then
	      zip_check = 1
	      return
	    endif
	  end do
	endif
	return
	end