MODULE LIB_pom(IDENT='V04-000',ADDRESSING_MODE(EXTERNAL=GENERAL)) =
BEGIN
  LIBRARY 'SYS$LIBRARY:starlet';

GLOBAL ROUTINE LIB_pom(time,phase_code,age) =
!<TITLE>PHASE_OF_MOON.B32 - Phase of the Moon routine LIB_pom </TITLE>
!	status.wlc.v = LIB_pom(time.rq.r,phase_code.wbu.r,age.wbu.r)
!	Arguments:
!		TIME -		optional time for computation; address 0 = now.
!		PHASE_CODE -	code for the phase:
!			0 = new, 1 = waxing crescent, 2 = first quarter
!			3 = waxing gibbous, 4 = full, 5 = waning gibbous,
!			6 = last quarter, 7 = waning crescent.
!		AGE -		days since new moon.
!	All arguments are optional.
!Times:  The moon's period is taken as 2551440 seconds (29d 12h44m).
!  The phases are New: 0 sec, FQ: 638100 sec, Full: 1276127 sec, LQ: 1913785.
!  Each of these primary phases is held to last 12 hours (43200 sec) to each 
!  side of the given value.  Computations are made in 10 second units to avoid
!  EDIV overflow.
BEGIN
!  EXTERNAL LITERAL
!    LIB__early;

  LITERAL
    period = 255144;
  LITERAL
    LIB__early = 0;
  LOCAL
    timadr : VECTOR[2],
    basetime : VECTOR[2] INITIAL(%X'85E8A000',%X'86C199'), !28-JAN-79 0120
    seconds,
    phase_table : VECTOR[9] INITIAL(4320,59466,68106,123252,131892,
    					187038,195678,250824,255144);
  BUILTIN
    EDIV, SUBM,
    actualcount,
    nullparameter;
  MACRO test(val) = (LOCAL sts; IF NOT (sts = (val)) THEN RETURN .sts)%;
  IF nullparameter(1) THEN test($gettim(TIMADR=timadr))
  ELSE IF actualcount() EQL 1 THEN RETURN 1
    ELSE
      (CH$move(8,.time,timadr);
       IF (.timadr[1] EQL 0) AND (.timadr[0] EQL 0)
	 THEN test($gettim(TIMADR=timadr))
      );
  SUBM(2,basetime,timadr,timadr); IF .timadr[1] LEQ 0 THEN RETURN LIB__early;
  EDIV(%REF(100000000),timadr,seconds,basetime);
  seconds = .seconds MOD period;
  IF NOT nullparameter(2) THEN
    (.phase_code)<0,8,0> = (INCR i FROM 0 TO 8 DO
    		    IF .seconds LSS .phase_table[.i] THEN EXITLOOP .i) MOD 8;
  IF NOT nullparameter(3) THEN
    (.age)<0,8,0> = .seconds/(24*360);
  1
END;
END
ELUDOM