$! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 3-DEC-1990 22:40:08.48 By user DYSON (Rick Dyson) $! $! This VMS_SHARE Written by: $! Andy Harper, Kings College London UK $! $! Acknowledgements to: $! James Gray - Original VMS_SHARE $! Michael Bednarek - Original Concept and implementation $! $!+ THIS PACKAGE DISTRIBUTED IN 3 PARTS, TO KEEP EACH PART $! BELOW 30 BLOCKS $! $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER $! AND EXECUTE AS A COMMAND PROCEDURE ( @name ) $! $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING: $! 1. AAAREADME.FIRST;1 $! 2. ADD_LIST.COM;1 $! 3. CALENDAR.FOR;1 $! 4. CALENDAR.HLP;1 $! 5. CALENDAR.LIS;1 $! 6. MAKE_CALENDAR.COM;1 $! $set="set" $set symbol/scope=(nolocal,noglobal) $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID")) $e="write sys$error ""%UNPACK"", " $w="write sys$output ""%UNPACK"", " $ if f$trnlnm("SHARE_LOG") then $ w = "!" $ ve=f$getsyi("version") $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START $ e "-E-OLDVER, Must run at least VMS 4.4" $ v=f$verify(v) $ exit 44 $UNPACK: SUBROUTINE ! P1=filename, P2=checksum $ if f$search(P1) .eqs. "" then $ goto file_absent $ e "-W-EXISTS, File ''P1' exists. Skipped." $ delete 'f'* $ exit $file_absent: $ if f$parse(P1) .nes. "" then $ goto dirok $ dn=f$parse(P1,,,"DIRECTORY") $ w "-I-CREDIR, Creating directory ''dn'." $ create/dir 'dn' $ if $status then $ goto dirok $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped." $ delete 'f'* $ exit $dirok: $ w "-I-PROCESS, Processing file ''P1'." $ if .not. f$verify() then $ define/user sys$output nl: $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1' PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET( SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:= CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b)); LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION( BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1); IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE; MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1; ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")= 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF"; POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r); ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1; COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE, "output_file"));ENDPROCEDURE;Unpacker;QUIT; $ delete/nolog 'f'* $ CHECKSUM 'P1' $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT $ e "-E-CHKSMFAIL, Checksum of ''P1' failed." $ ENDSUBROUTINE $START: $ create 'f' XGreetings Fellow VMS user! X X CALENDAR is a simple little program for a fast graphical X display of a monthly calendar on DEC VT (and many other) X terminals. It quickly puts up the desired month complete with the X correct day-of-year number. For those of you in the science X community, this is very handy. This VMS_SHARE package should X produce six files: X X 1) AAAREADME.FIRST this file X 2) ADD_LIST.COM A FREE-BEE! a DCL com procedure to add anoth Ver X library to any logical name library list, i. Ve., X Hlp$Library_nn or Lnk$Library_nn. X 3) MAKE_CALENDAR.COM a DCL com procedure to setup CALENDAR X 4) CALENDAR.FOR VAX FORTRAN source file X 5) CALENDAR.HLP VAX Help Library text file X 6) CALENDAR.LIS text file of stripped off source code header X documentation X X I hope you get some use from this software. Please let me X know if you have any problems, complaints, suggestions, or X questions. Just drop me e-mail at the address below. X X Rick X-- XRichard L. Dyson INTERNET: Dyson@IowaSP.Physics.UIowa.EDU X Great God what an awful place ... X`20 X -- Robert Falcon Scott X concerning Antarctica on his ill-fated`20 X trip to the South Pole in 1910-11 $ CALL UNPACK AAAREADME.FIRST;1 104794262 $ create 'f' X$ ! ENTER /* DCL:ADD_HELP file_spec */ X$ ! X$ save_verify = f$verify(0) !Turn off verification, remember what it was X$ ! X$ ! BEGIN X$ ! `20 X$ ! Escape route X$ on error then $ goto finish X$ on warning then $ goto finish X$ on severe then $ goto finish X$ ! X$ ! Out of here if the calling parameter is null X$ p2 = f$edit(p2,"trim,upcase") X$ if p2 .eqs. "" then $ goto finish X$ ! X$ ! Check the first value in the help list X$ LIB = p1 X$ X = F$TRNLNM(LIB,"LNM$PROCESS") X$ IF X .EQS. "" THEN GOTO INSERT X$ IF X .EQS. p2 THEN GOTO FINISH X$ ! X$ ! Find the first free logical to assign the help file to X$ BASE = p1 + "_" X$ N = 1 X$ NEXTLIB: X$ LIB := 'BASE''N' X$ X = F$TRNLNM(LIB,"LNM$PROCESS") X$ IF X .EQS. "" THEN GOTO INSERT X$ IF X .EQS. p2 THEN GOTO FINISH X$ N = N + 1 X$ GOTO NEXTLIB X$ !`20 X$ ! Add the help file to the help file list X$ INSERT: X$ DEFINE/PROCESS 'LIB' 'p2' X$ ! X$ FINISH: X$ IF SAVE_VERIFY THEN $ SET VERIFY X$ EXIT ! /* DCL:ADD_HELP */ $ CALL UNPACK ADD_LIST.COM;1 51190608 $ create 'f' X Options /Extend_Source XC*CALENDAR -- Produce graphical monthly calendar on ANSI terminal XC+ X Program CALENDAR X X************************************************************************* X* * X* This program creates a monthly (with handy day of year number!) * X* calendar for any month from 1900 - 2199. It is trivial to extend * X* the upper century value by a feed back method explained in the * X* code. The output was designed for the family of DEC VTxxx * X* terminals equipped with double width lines and DEC's special * X* graphics. Full VT100 emulators should work. Other terminals may * X* work, but the double size will probably not work properly. * X* * X* See the documentation for the INDATE routine for allowed input * X* formats. * X* * X* If the executable module is installed as a foreign command, * X* i.e., * X* * X* DOY :== $ :`5B`5DCALENDAR.EXE V * X* * X* any of the input can be included on the VMS DCL command line, e.g., * X* * X* $ DOY 16-APR-60 * X* $ DOY 60 APR * X* $ DOY 2135 APR * X* $ DOY . * X* * X* Author: Rick Dyson (as a DCL command procedure) * X* Gregg Parmentier (as first FORTRAN program) * X* Written: late 1988 * X* O/S: DEC VAX/VMS 5.0 or greater. It will probably work for earlier * X* versions. It DOES use VAX FORTRAN calls and as such will (I * X* guess?) not port to just ANSI FORTRAN. It uses the DEC escape * X* sequence for double-width lines (DECDWL) which may not work * X* on all terminals. It's been my experience that terminals * X* which don't support these escape sequences, simply ignore them.* X* * X* * X* Modified: 26-MAR-1989 changed style of input and month output * X* fully documented program. RLD * X* 18-JUL-1990 corrected leap year bug: 1900 is, 2000 isn't. * X* Extended abilities to 21st and 22nd centuries.* X* RLD * X* 24-SEP-1990 updated documentation and made fully * X* stand alone RLD * X* * X************************************************************************* XC-- end marker for DOCUMENT program X X Implicit None X X Logical*1 END, LEAP, CURRENT X Byte ESC / 27 / X Byte DAYS (12) / 31, 28, 31, 30, 31, 30,`20 X & 31, 31, 30, 31, 30, 31 / X Integer FIRST, WEEKDAY, WEEKS, YR, MO, DAY, DOY, I, J, K, X, Y X Integer YEAR, UNIT / 6 / X Integer DOYS (12) / 1, 32, 60, 91, 121, 152, X & 182, 213, 244, 274, 305, 335 / X Character*2 DECDWL / '#6' /, DEC_GRAPHICS (2) / '(0', '(B' / X Character*3 MONTH, BOLD (2) / '`5B1m', '`5B0m' / X Character*3 WKDYS (7) / 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'S Vat' / X Character*5 CLEAR (2) / '`5B2J', '`5B2;1H' /, INVRS (2) / '`5B7;5m', V '`5B0m' / X Character*7 PLACE / '`5B00;00H' / X Character*36 LINE_1 / 'lqqqqwqqqqwqqqqwqqqqwqqqqwqqqqwqqqqk' /, X & LINE_2 / 'x x x x x x x x' /, X & LINE_3 / 'tqqqqnqqqqnqqqqnqqqqnqqqqnqqqqnqqqqu' /, X & LINE_4 / 'mqqqqvqqqqvqqqqvqqqqvqqqqvqqqqvqqqqj' / X X X* ...get desired date information X1 Call INDATE (YEAR, DOY, DAY, MO, MONTH, END, CURRENT) X If (END) GoTo 666 X X* ...leap year? X LEAP = .False. X YR = Mod (YEAR, 100) X If (Mod (YEAR, 4) .eq. 0) LEAP = .True. X* ...correct for leap centuries X If (Mod (YEAR, 100) .eq. 0) LEAP = .False. X If (Mod (YEAR, 400) .eq. 0) LEAP = .True. X If (LEAP) Then X DAYS (2) = 29 X Else X DAYS (2) = 28 X EndIf X X* To determine the day of the week for January first of future X* centuries (i.e. nn00) years, execute CALENDAR for December of X* the nn99 year. Then, edit the If-Then-Else structure below X* and the equation of the following form for the variable FIRST: X* FIRST = 2 + YR + (YR - 1) / 4 X* `5E`5E`5E`5E`5E X* where the first term on the right hand side (the integer), X* FIRST = 2 + YR + (YR - 1) / 4 X* `5E X* is set equal to the day of the week number, X* i.e., X* 1 = Sunday 2 = Monday X* 3 = Tuesday 4 = Wednesday X* 5 = Thursday 6 = Friday X* 7 = Saturday X X If (YEAR .lt. 2000) Then X FIRST = 2 + YR + (YR - 1) / 4 ! Monday, 1 Jan 1900 X Else X If (YEAR .lt. 2100) Then X FIRST = 7 + YR + (YR - 1) / 4 ! Saturday, 1 Jan 20 V00 X Else X If (YEAR .lt. 2200) Then X FIRST = 5 + YR + (YR - 1) / 4 ! Thursday, 1 Jan 21 V00 X Else X Write (UNIT, '(A)') ' I''m sorry, but I can''t go that h Vigh at the current time. ' X Write (UNIT, '(A)') ' Please ask my caretaker to check i Vnto extending my abilities.' X Write (UNIT, '(A)') ' It is possible to extend me indefi Vnitely!' X Write (UNIT, '(A)') ' Try a new date, or to exi Vt.' X Write (UNIT, '(A)') ' ' X GoTo 1 X EndIf X EndIf X EndIf X X* ...day of week for start of month X WEEKDAY = Mod (FIRST + DOY - DAY - 1, 7) X X* ...put up frame X I = WEEKDAY + DAYS (MO) + 6 X If ((MO .eq. 2) .and. (LEAP)) I = I + 1 X WEEKS = I / 7 X Write (UNIT, '(X, A1, A3, A1, A5)') ESC, CLEAR (1), ESC, CLEAR (2) X Write (UNIT, 1006) ESC, BOLD (1) X Write (UNIT, 1005) ESC, DEC_GRAPHICS (1) X PLACE = '`5B01;02H' X Write (UNIT, 1000) ESC, PLACE, ESC, DECDWL, YEAR, MONTH, YEAR X Write (UNIT, 10) ESC, DECDWL, LINE_1 X Write (UNIT, 10) ESC, DECDWL, LINE_2 X Do I = 1, WEEKS X Write (UNIT, 10) ESC, DECDWL, LINE_3 X Write (UNIT, 10) ESC, DECDWL, LINE_2 X Write (UNIT, 10) ESC, DECDWL, LINE_2 X EndDo X Write (UNIT, 10) ESC, DECDWL, LINE_4 X Write (UNIT, 1005) ESC, DEC_GRAPHICS (2) X PLACE (2:3) = '03' X X* ...put up day of week header X Do I = 1, 7 X Write (PLACE (5:6), '(I2.2)') I * 5 - 2 X Write (UNIT, '(X, A1, A7, A3)') ESC, PLACE, WKDYS (I) X EndDo X Write (UNIT, 1006) ESC, BOLD (2) X X* ...put up days of month X X = 5 X Y = -2 + 5 * WEEKDAY X If (MO .ne. 1) J = DOYS (MO) - 1 X If ((LEAP) .and. (MO .gt. 2)) J = J + 1 X Write (PLACE (2:3), '(I2.2)') X X Do I = 1, DAYS (MO) X Y = Y + 5 X If (Y .eq. 38) Then X X = X + 3 X Y = 3 X EndIf X Write (PLACE (2:3), '(I2.2)') X X Write (PLACE (5:6), '(I2.2)') Y + 1 X If ((I .eq. DAY) .and. CURRENT) Then X If (DAY .lt. 10) Then X Write (PLACE (5:6), '(I2.2)') Y + 1 X Write (UNIT, 1001) ESC, INVRS (1), ESC, PLACE, I, ESC, I VNVRS (2) X Else X Write (UNIT, 1002) ESC, INVRS (1), ESC, PLACE, I, ESC, I VNVRS (2) X EndIf X Else X Write (UNIT, '(X, A1, A7, I2)') ESC, PLACE, I X EndIf X If (MO .ne. 1) Then X Write (PLACE (2:3), '(I2.2)') X + 1 +-+-+-+-+-+-+-+- END OF PART 1 +-+-+-+-+-+-+-+- -- Richard L. Dyson INTERNET: Dyson@IowaSP.Physics.UIowa.EDU I have often had the impression that, to penguins, man is just another penguin -- different, less predictable, occasionally violent, but tolerable company when he sits still and minds his own business. --Bernard Stonehouse /* ---------- */