subroutine aptfact (n, tol, nfact, fact, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTFACT
c
c     call aptfact (n, tol, nfact, fact, nerr)
c
c     Version:  aptfact  Updated    2003 August 20 18:00.
c               aptfact  Originated 2003 August 20 18:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  For argument n, to find the integer and floating point values
c               of n factorial (n!), nfact and fact, respectively.
c
c     Input:    n, tol.
c
c     Output:   nfact, fact, nerr.
c
c     Glossary:
c
c     fact      Output   The floating point value of n factorial (n!).
c                          If n < 0, returned as -1.e99, with nerr = 1.
c                          WARNING:  may overflow largest machine floating point
c                          number, if n is too large.
c                          For example:  170! =  7.25741561530799+306.
c
c     n         Input    Argument of factorial function, n!.
c
c     nerr      Output   Indicates an input or result error, if not zero.
c                          -1 if nfact exceeds the largest machine integer.
c                           1 if n < 0.
c
c     nfact     Output   The integer value of n!.
c                          If n < 0, returned as -999999, with nerr = 1.
c                          If larger then the largest machine integer,
c                          returned as -999999, with nerr = -1, but fact will
c                          still be accurate, unless fact overflows the largest
c                          machine floating point number.
c
c     tol       Input    The precision with which nfact and fact must agree,
c                          to insure that nfact does not exceed the largest
c                          machine integer.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

      implicit none

c.... Arguments.

      integer  n                      ! Argument of factorial.
      integer  nerr                   ! Error indicator.
      integer  nfact                  ! Integer value of factorial of n.

      real     fact                   ! Real value of factorial of n.
      real     tol                    ! Reqired precision of fact, nfact match.


c.... Local variables.

      integer  nn                     ! Index, 2 to n.

      real     fnn                    ! Real value of nn.
      real     fnfact                 ! Real value of nfact.

cbugc***DEBUG begins.
cbug 9001 format (/ 'aptfact finding factorial of ',i6,'.  tol = ',1pe22.14)
cbug      write ( 3, 9001) n, tol
cbugc***DEBUG ends.

c.... Initialize.

      nerr   = 0
      nfact  = -999999
      fnfact = -999999.0
      fact   = -1.e99

c.... Test for errors, limits.

      if (n .lt. 0) then
        nerr = 1
        go to 210
      endif

c.... Find factorial of n.

      nfact  = 1
      fnfact = 1.0
      fact   = 1.0

      if (n .gt. 1) then              ! Find factorial of positive integer.

        do 110 nn = 2, n
          nfact = nfact * nn
          fnn   = nn
          fact  = fact * fnn
  110   continue

        fnfact = nfact
        if (abs (fnfact - fact) .gt. tol * fact) then
          nerr  = -1
          nfact = -999999
        endif

      endif                           ! Tested n.

  210 continue
cbugc***DEBUG begins.
cbug 9002 format (/ 'aptfact found factorial.  nerr = ',i3 /
cbug     &  'n!, fn!, chk =',i20,2x,1p2e22.14)
cbug      write ( 3, 9002) nerr, nfact, fact, fnfact
cbugc***DEBUG ends.

      return

c.... End of subroutine aptfact.      (+1 line.)
      end

UCRL-WEB-209832