c\BeginDoc
c
c\Name: dseupd
c
c\Description:
c
c  This subroutine returns the converged approximations to eigenvalues
c  of A*z = lambda*B*z and (optionally):
c
c      (1) the corresponding approximate eigenvectors,
c
c      (2) an orthonormal (Lanczos) basis for the associated approximate
c          invariant subspace,
c
c      (3) Both.
c
c  There is negligible additional cost to obtain eigenvectors.  An orthonormal
c  (Lanczos) basis is always computed.  There is an additional storage cost
c  of n*nev if both are requested (in this case a separate array Z must be
c  supplied).
c
c  These quantities are obtained from the Lanczos factorization computed
c  by DSAUPD for the linear operator OP prescribed by the MODE selection
c  (see IPARAM(7) in DSAUPD documentation.)  DSAUPD must be called before
c  this routine is called. These approximate eigenvalues and vectors are
c  commonly called Ritz values and Ritz vectors respectively.  They are
c  referred to as such in the comments that follow.   The computed orthonormal
c  basis for the invariant subspace corresponding to these Ritz values is
c  referred to as a Lanczos basis.
c
c  See documentation in the header of the subroutine DSAUPD for a definition
c  of OP as well as other terms and the relation of computed Ritz values
c  and vectors of OP with respect to the given problem  A*z = lambda*B*z.
c
c  The approximate eigenvalues of the original problem are returned in
c  ascending algebraic order.  The user may elect to call this routine
c  once for each desired Ritz vector and store it peripherally if desired.
c  There is also the option of computing a selected set of these vectors
c  with a single call.
c
c\Usage:
c  call dseupd
c     ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL,
c       RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c  RVEC    LOGICAL  (INPUT)
c          Specifies whether Ritz vectors corresponding to the Ritz value
c          approximations to the eigenproblem A*z = lambda*B*z are computed.
c
c             RVEC = .FALSE.     Compute Ritz values only.
c
c             RVEC = .TRUE.      Compute Ritz vectors.
c
c  HOWMNY  Character*1  (INPUT)
c          Specifies how many Ritz vectors are wanted and the form of Z
c          the matrix of Ritz vectors. See remark 1 below.
c          = 'A': compute NEV Ritz vectors;
c          = 'S': compute some of the Ritz vectors, specified
c                 by the logical array SELECT.
c
c  SELECT  Logical array of dimension NEV.  (INPUT)
c          If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c          computed. To select the Ritz vector corresponding to a
c          Ritz value D(j), SELECT(j) must be set to .TRUE..
c          If HOWMNY = 'A' , SELECT is not referenced.
c
c  D       Double precision array of dimension NEV.  (OUTPUT)
c          On exit, D contains the Ritz value approximations to the
c          eigenvalues of A*z = lambda*B*z. The values are returned
c          in ascending order. If IPARAM(7) = 3,4,5 then D represents
c          the Ritz values of OP computed by dsaupd transformed to
c          those of the original eigensystem A*z = lambda*B*z. If
c          IPARAM(7) = 1,2 then the Ritz values of OP are the same
c          as the those of A*z = lambda*B*z.
c
c  Z       Double precision N by NEV array if HOWMNY = 'A'.  (OUTPUT)
c          On exit, Z contains the B-orthonormal Ritz vectors of the
c          eigensystem A*z = lambda*B*z corresponding to the Ritz
c          value approximations.
c          If  RVEC = .FALSE. then Z is not referenced.
c          NOTE: The array Z may be set equal to first NEV columns of the
c          Arnoldi/Lanczos basis array V computed by DSAUPD.
c
c  LDZ     Integer.  (INPUT)
c          The leading dimension of the array Z.  If Ritz vectors are
c          desired, then  LDZ .ge.  max( 1, N ).  In any case,  LDZ .ge. 1.
c
c  SIGMA   Double precision  (INPUT)
c          If IPARAM(7) = 3,4,5 represents the shift. Not referenced if
c          IPARAM(7) = 1 or 2.
c
c
c  **** The remaining arguments MUST be the same as for the   ****
c  **** call to DNAUPD that was just completed.               ****
c
c  NOTE: The remaining arguments
c
c           BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
c           WORKD, WORKL, LWORKL, INFO
c
c         must be passed directly to DSEUPD following the last call
c         to DSAUPD.  These arguments MUST NOT BE MODIFIED between
c         the the last call to DSAUPD and the call to DSEUPD.
c
c  Two of these parameters (WORKL, INFO) are also output parameters:
c
c  WORKL   Double precision work array of length LWORKL.  (OUTPUT/WORKSPACE)
c          WORKL(1:4*ncv) contains information obtained in
c          dsaupd.  They are not changed by dseupd.
c          WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the
c          untransformed Ritz values, the computed error estimates,
c          and the associated eigenvector matrix of H.
c
c          Note: IPNTR(8:10) contains the pointer into WORKL for addresses
c          of the above information computed by dseupd.
c          -------------------------------------------------------------
c          IPNTR(8): pointer to the NCV RITZ values of the original system.
c          IPNTR(9): pointer to the NCV corresponding error bounds.
c          IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c                     of the tridiagonal matrix T. Only referenced by
c                     dseupd if RVEC = .TRUE. See Remarks.
c          -------------------------------------------------------------
c
c  INFO    Integer.  (OUTPUT)
c          Error flag on output.
c          =  0: Normal exit.
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV must be greater than NEV and less than or equal to N.
c          = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work WORKL array is not sufficient.
c          = -8: Error return from trid. eigenvalue calculation;
c                Information error from LAPACK routine dsteqr.
c          = -9: Starting vector is zero.
c          = -10: IPARAM(7) must be 1,2,3,4,5.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c          = -12: NEV and WHICH = 'BE' are incompatible.
c          = -14: DSAUPD did not find any eigenvalues to sufficient
c                 accuracy.
c          = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true.
c          = -16: HOWMNY = 'S' not yet implemented
c
c\BeginLib
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Rice University Technical Report
c     TR95-13, Department of Computational and Applied Mathematics.
c  3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c     1980.
c  4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c     Computer Physics Communications, 53 (1989), pp 169-179.
c  5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c     Implement the Spectral Transformation", Math. Comp., 48 (1987),
c     pp 663-673.
c  6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c     Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c     SIAM J. Matr. Anal. Apps.,  January (1993).
c  7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c     for Updating the QR decomposition", ACM TOMS, December 1990,
c     Volume 16 Number 4, pp 369-377.
c
c\Remarks
c  1. The converged Ritz values are always returned in increasing
c     (algebraic) order.
c
c  2. Currently only HOWMNY = 'A' is implemented. It is included at this
c     stage for the user who wants to incorporate it.
c
c\Routines called:
c     dsesrt  ARPACK routine that sorts an array X, and applies the
c             corresponding permutation to a matrix A.
c     dsortr  dsortr  ARPACK sorting routine.
c     dgeqr2  LAPACK routine that computes the QR factorization of
c             a matrix.
c     dlacpy  LAPACK matrix copy routine.
c     dlamch  LAPACK routine that determines machine constants.
c     dorm2r  LAPACK routine that applies an orthogonal matrix in
c             factored form.
c     dsteqr  LAPACK routine that computes eigenvalues and eigenvectors
c             of a tridiagonal matrix.
c     dger    Level 2 BLAS rank one update to a matrix.
c     dcopy   Level 1 BLAS that copies one vector to another .
c     dnrm2   Level 1 BLAS that computes the norm of a vector.
c     dscal   Level 1 BLAS that scales a vector.
c     dswap   Level 1 BLAS that swaps the contents of two vectors.

c\Authors
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Chao Yang                    Houston, Texas
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Revision history:
c     12/15/93: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: seupd.F   SID: 2.7   DATE OF SID: 8/27/96   RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
      subroutine dseupd (rvec, howmny, select, d, z, ldz, sigma, bmat,
     &                   n, which, nev, tol, resid, ncv, v, ldv, iparam,
     &                   ipntr, workd, workl, lworkl, info )
c
c     %----------------------------------------------------%
c     | Include files for debugging and timing information |
c     %----------------------------------------------------%
c
      include   'debug.h'
      include   'stat.h'
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character  bmat, howmny, which*2
      logical    rvec, select(ncv)
      integer    info, ldz, ldv, lworkl, n, ncv, nev
      Double precision
     &           sigma, tol
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      integer    iparam(7), ipntr(11)
      Double precision
     &           d(nev), resid(n), v(ldv,ncv), z(ldz, nev),
     &           workd(2*n), workl(lworkl)
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &           one, zero
      parameter (one = 1.0D+0, zero = 0.0D+0)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character  type*6
      integer    bounds, ierr, ih, ihb, ihd, iq, iw, j, k,
     &           ldh, ldq, mode, msglvl, nconv, next, ritz,
     &           irz, ibd, ktrord, leftptr, rghtptr, ism, ilg
      Double precision
     &           bnorm2, rnorm, temp, thres1, thres2, tempbnd, eps23
      logical    reord
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      Double precision
     &           kv(2)
c
c     %----------------------%
c     | External Subroutines |
c     %----------------------%
c
      external   dcopy, dger, dgeqr2, dlacpy, dorm2r, dscal,
     &           dsesrt, dsteqr, dswap, dsortr
c
c     %--------------------%
c     | External Functions |
c     %--------------------%
c
      Double precision
     &           dnrm2, dlamch
      external   dnrm2, dlamch
c
c     %---------------------%
c     | Intrinsic Functions |
c     %---------------------%
c
      intrinsic    min
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %------------------------%
c     | Set default parameters |
c     %------------------------%
c
      msglvl = mseupd
      mode = iparam(7)
      nconv = iparam(5)
      info = 0
c
c     %--------------%
c     | Quick return |
c     %--------------%
c
      if (nconv .eq. 0) go to 9000
      ierr = 0
c
      if (nconv .le. 0)                        ierr = -14
      if (n .le. 0)                            ierr = -1
      if (nev .le. 0)                          ierr = -2
      if (ncv .le. nev .or.  ncv .gt. n)       ierr = -3
      if (which .ne. 'LM' .and.
     &    which .ne. 'SM' .and.
     &    which .ne. 'LA' .and.
     &    which .ne. 'SA' .and.
     &    which .ne. 'BE')                     ierr = -5
      if (bmat .ne. 'I' .and. bmat .ne. 'G')   ierr = -6
      if ( (howmny .ne. 'A' .and.
     &           howmny .ne. 'P' .and.
     &           howmny .ne. 'S') .and. rvec )
     &                                         ierr = -15
      if (rvec .and. howmny .eq. 'S')           ierr = -16
c
      if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7
c
      if (mode .eq. 1 .or. mode .eq. 2) then
         type = 'REGULR'
      else if (mode .eq. 3 ) then
         type = 'SHIFTI'
      else if (mode .eq. 4 ) then
         type = 'BUCKLE'
      else if (mode .eq. 5 ) then
         type = 'CAYLEY'
      else
                                               ierr = -10
      end if
      if (mode .eq. 1 .and. bmat .eq. 'G')     ierr = -11
      if (nev .eq. 1 .and. which .eq. 'BE')    ierr = -12
c
c     %------------%
c     | Error Exit |
c     %------------%
c
      if (ierr .ne. 0) then
         info = ierr
         go to 9000
      end if
c
c     %-------------------------------------------------------%
c     | Pointer into WORKL for address of H, RITZ, BOUNDS, Q  |
c     | etc... and the remaining workspace.                   |
c     | Also update pointer to be used on output.             |
c     | Memory is laid out as follows:                        |
c     | workl(1:2*ncv) := generated tridiagonal matrix H      |
c     |       The subdiagonal is stored in workl(2:ncv).      |
c     |       The dead spot is workl(1) but upon exiting      |
c     |       dsaupd stores the B-norm of the last residual   |
c     |       vector in workl(1). We use this !!!             |
c     | workl(2*ncv+1:2*ncv+ncv) := ritz values               |
c     |       The wanted values are in the first NCONV spots. |
c     | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates   |
c     |       The wanted values are in the first NCONV spots. |
c     | NOTE: workl(1:4*ncv) is set by dsaupd and is not      |
c     |       modified by dseupd.                             |
c     %-------------------------------------------------------%
c
c     %-------------------------------------------------------%
c     | The following is used and set by dseupd.              |
c     | workl(4*ncv+1:4*ncv+ncv) := used as workspace during  |
c     |       computation of the eigenvectors of H. Stores    |
c     |       the diagonal of H. Upon EXIT contains the NCV   |
c     |       Ritz values of the original system. The first   |
c     |       NCONV spots have the wanted values. If MODE =   |
c     |       1 or 2 then will equal workl(2*ncv+1:3*ncv).    |
c     | workl(5*ncv+1:5*ncv+ncv) := used as workspace during  |
c     |       computation of the eigenvectors of H. Stores    |
c     |       the subdiagonal of H. Upon EXIT contains the    |
c     |       NCV corresponding Ritz estimates of the         |
c     |       original system. The first NCONV spots have the |
c     |       wanted values. If MODE = 1,2 then will equal    |
c     |       workl(3*ncv+1:4*ncv).                           |
c     | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is  |
c     |       the eigenvector matrix for H as returned by     |
c     |       dsteqr. Not referenced if RVEC = .False.        |
c     |       Ordering follows that of workl(4*ncv+1:5*ncv)   |
c     | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) :=         |
c     |       Workspace. Needed by dsteqr and by dseupd.      |
c     | GRAND total of NCV*(NCV+8) locations.                 |
c     %-------------------------------------------------------%
c
c
      ih     = ipntr(5)
      ritz   = ipntr(6)
      bounds = ipntr(7)
      ldh    = ncv
      ldq    = ncv
      ihd    = bounds + ldh
      ihb    = ihd    + ldh
      iq     = ihb    + ldh
      iw     = iq     + ldh*ncv
      next   = iw     + 2*ncv
      ipntr(4)  = next
      ipntr(8)  = ihd
      ipntr(9)  = ihb
      ipntr(10) = iq
c
c     %----------------------------------------%
c     | irz points to the Ritz values computed |
c     |     by _seigt before exiting _saup2.   |
c     | ibd points to the Ritz estimates       |
c     |     computed by _seigt before exiting  |
c     |     _saup2.                            |
c     %----------------------------------------%
c
      irz = ipntr(11)+ncv
      ibd = irz+ncv
c
c
c     %---------------------------------%
c     | Set machine dependent constant. |
c     %---------------------------------%
c
      eps23 = dlamch('Epsilon-Machine')
      eps23 = eps23**(2.0D+0 / 3.0D+0)
c
c     %---------------------------------------%
c     | RNORM is B-norm of the RESID(1:N).    |
c     | BNORM2 is the 2 norm of B*RESID(1:N). |
c     | Upon exit of dsaupd WORKD(1:N) has    |
c     | B*RESID(1:N).                         |
c     %---------------------------------------%
c
      rnorm = workl(ih)
      if (bmat .eq. 'I') then
         bnorm2 = rnorm
      else if (bmat .eq. 'G') then
         bnorm2 = dnrm2(n, workd, 1)
      end if
c
      if (rvec) then
c
c        %------------------------------------------------%
c        | Get the converged Ritz value on the boundary.  |
c        | This value will be used to dermine whether we  |
c        | need to reorder the eigenvalues and            |
c        | eigenvectors comupted by _steqr, and is        |
c        | referred to as the "threshold" value.          |
c        |                                                |
c        | A Ritz value gamma is said to be a wanted      |
c        | one, if                                        |
c        | abs(gamma) .ge. threshold, when WHICH = 'LM';  |
c        | abs(gamma) .le. threshold, when WHICH = 'SM';  |
c        | gamma      .ge. threshold, when WHICH = 'LA';  |
c        | gamma      .le. threshold, when WHICH = 'SA';  |
c        | gamma .le. thres1 .or. gamma .ge. thres2       |
c        |                            when WHICH = 'BE';  |
c        |                                                |
c        | Note: converged Ritz values and associated     |
c        | Ritz estimates have been placed in the first   |
c        | NCONV locations in workl(ritz) and             |
c        | workl(bounds) respectively. They have been     |
c        | sorted (in _saup2) according to the WHICH      |
c        | selection criterion. (Except in the case       |
c        | WHICH = 'BE', they are sorted in an increasing |
c        | order.)                                        |
c        %------------------------------------------------%
c
         if (which .eq. 'LM' .or. which .eq. 'SM'
     &       .or. which .eq. 'LA' .or. which .eq. 'SA' ) then
c
             thres1 = workl(ritz)
c
c             if (msglvl .gt. 2) then
c                call dvout(logfil, 1, thres1, ndigit,
c     &          '_seupd: Threshold eigenvalue used for re-ordering')
c             end if
c
         else if (which .eq. 'BE') then
c
c            %------------------------------------------------%
c            | Ritz values returned from _saup2 have been     |
c            | sorted in increasing order.  Thus two          |
c            | "threshold" values (one for the small end, one |
c            | for the large end) are in the middle.          |
c            %------------------------------------------------%
c
             ism = max(nev,nconv) / 2
             ilg = ism + 1
             thres1 = workl(ism)
             thres2 = workl(ilg)
c
             if (msglvl .gt. 2) then
                kv(1) = thres1
                kv(2) = thres2
c                call dvout(logfil, 2, kv, ndigit,
c     &          '_seupd: Threshold eigenvalues used for re-ordering')
             end if
c
         end if
c
c        %----------------------------------------------------------%
c        | Check to see if all converged Ritz values appear within  |
c        | the first NCONV diagonal elements returned from _seigt.  |
c        | This is done in the following way:                       |
c        |                                                          |
c        | 1) For each Ritz value obtained from _seigt, compare it  |
c        |    with the threshold Ritz value computed above to       |
c        |    determine whether it is a wanted one.                 |
c        |                                                          |
c        | 2) If it is wanted, then check the corresponding Ritz    |
c        |    estimate to see if it has converged.  If it has, set  |
c        |    corresponding entry in the logical array SELECT to    |
c        |    .TRUE..                                               |
c        |                                                          |
c        | If SELECT(j) = .TRUE. and j > NCONV, then there is a     |
c        | converged Ritz value that does not appear at the top of  |
c        | the diagonal matrix computed by _seigt in _saup2.        |
c        | Reordering is needed.                                    |
c        %----------------------------------------------------------%
c
         reord = .false.
         ktrord = 0
         do 10 j = 0, ncv-1
            select(j+1) = .false.
            if (which .eq. 'LM') then
               if (abs(workl(irz+j)) .ge. abs(thres1)) then
                   tempbnd = max( eps23, abs(workl(irz+j)) )
                   if (workl(ibd+j) .le. tol*tempbnd) then
                      select(j+1) = .true.
                   end if
               end if
            else if (which .eq. 'SM') then
               if (abs(workl(irz+j)) .le. abs(thres1)) then
                   tempbnd = max( eps23, abs(workl(irz+j)) )
                   if (workl(ibd+j) .le. tol*tempbnd) then
                      select(j+1) = .true.
                   end if
               end if
            else if (which .eq. 'LA') then
               if (workl(irz+j) .ge. thres1) then
                  tempbnd = max( eps23, abs(workl(irz+j)) )
                  if (workl(ibd+j) .le. tol*tempbnd) then
                     select(j+1) = .true.
                  end if
               end if
            else if (which .eq. 'SA') then
               if (workl(irz+j) .le. thres1) then
                  tempbnd = max( eps23, abs(workl(irz+j)) )
                  if (workl(ibd+j) .le. tol*tempbnd) then
                     select(j+1) = .true.
                  end if
               end if
            else if (which .eq. 'BE') then
               if ( workl(irz+j) .le. thres1 .or.
     &              workl(irz+j) .ge. thres2 ) then
                  tempbnd = max( eps23, abs(workl(irz+j)) )
                  if (workl(ibd+j) .le. tol*tempbnd) then
                     select(j+1) = .true.
                  end if
               end if
            end if
            if (j+1 .gt. nconv ) reord = select(j+1) .or. reord
            if (select(j+1)) ktrord = ktrord + 1
 10      continue

c        %-------------------------------------------%
c        | If KTRORD .ne. NCONV, something is wrong. |
c        %-------------------------------------------%
c
c         if (msglvl .gt. 2) then
c             call ivout(logfil, 1, ktrord, ndigit,
c     &            '_seupd: Number of specified eigenvalues')
c             call ivout(logfil, 1, nconv, ndigit,
c     &            '_seupd: Number of "converged" eigenvalues')
c         end if
c
c        %-----------------------------------------------------------%
c        | Call LAPACK routine _steqr to compute the eigenvalues and |
c        | eigenvectors of the final symmetric tridiagonal matrix H. |
c        | Initialize the eigenvector matrix Q to the identity.      |
c        %-----------------------------------------------------------%
c
         call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1)
         call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1)
c
         call dsteqr ('Identity', ncv, workl(ihd), workl(ihb),
     &                workl(iq), ldq, workl(iw), ierr)
c
         if (ierr .ne. 0) then
            info = -8
            go to 9000
         end if
c
         if (msglvl .gt. 1) then
            call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1)
c            call dvout (logfil, ncv, workl(ihd), ndigit,
c     &          '_seupd: NCV Ritz values of the final H matrix')
c            call dvout (logfil, ncv, workl(iw), ndigit,
c     &           '_seupd: last row of the eigenvector matrix for H')
         end if
c
         if (reord) then
c
c           %---------------------------------------------%
c           | Reordered the eigenvalues and eigenvectors  |
c           | computed by _steqr so that the "converged"  |
c           | eigenvalues appear in the first NCONV       |
c           | positions of workl(ihd), and the associated |
c           | eigenvectors appear in the first NCONV      |
c           | columns.                                    |
c           %---------------------------------------------%
c
            leftptr = 1
            rghtptr = ncv
c
            if (ncv .eq. 1) go to 30
c
 20         if (select(leftptr)) then
c
c              %-------------------------------------------%
c              | Search, from the left, for the first Ritz |
c              | value that has not converged.             |
c              %-------------------------------------------%
c
               leftptr = leftptr + 1
c
            else if ( .not. select(rghtptr)) then
c
c              %----------------------------------------------%
c              | Search, from the right, the first Ritz value |
c              | that has converged.                          |
c              %----------------------------------------------%
c
               rghtptr = rghtptr - 1
c
            else
c
c              %----------------------------------------------%
c              | Swap the Ritz value on the left that has not |
c              | converged with the Ritz value on the right   |
c              | that has converged.  Swap the associated     |
c              | eigenvector of the tridiagonal matrix H as   |
c              | well.                                        |
c              %----------------------------------------------%
c
               temp = workl(ihd+leftptr-1)
               workl(ihd+leftptr-1) = workl(ihd+rghtptr-1)
               workl(ihd+rghtptr-1) = temp
               call dcopy(ncv, workl(iq+ncv*(leftptr-1)), 1,
     &                    workl(iw), 1)
               call dcopy(ncv, workl(iq+ncv*(rghtptr-1)), 1,
     &                    workl(iq+ncv*(leftptr-1)), 1)
               call dcopy(ncv, workl(iw), 1,
     &                    workl(iq+ncv*(rghtptr-1)), 1)
               leftptr = leftptr + 1
               rghtptr = rghtptr - 1
c
            end if
c
            if (leftptr .lt. rghtptr) go to 20
c
 30      end if
c
c         if (msglvl .gt. 2) then
c             call dvout (logfil, ncv, workl(ihd), ndigit,
c     &       '_seupd: The eigenvalues of H--reordered')
c         end if
c
c        %----------------------------------------%
c        | Load the converged Ritz values into D. |
c        %----------------------------------------%
c
         call dcopy(nconv, workl(ihd), 1, d, 1)
c
      else
c
c        %-----------------------------------------------------%
c        | Ritz vectors not required. Load Ritz values into D. |
c        %-----------------------------------------------------%
c
         call dcopy (nconv, workl(ritz), 1, d, 1)
         call dcopy (ncv, workl(ritz), 1, workl(ihd), 1)
c
      end if
c
c     %------------------------------------------------------------------%
c     | Transform the Ritz values and possibly vectors and corresponding |
c     | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values |
c     | (and corresponding data) are returned in ascending order.        |
c     %------------------------------------------------------------------%
c
      if (type .eq. 'REGULR') then
c
c        %---------------------------------------------------------%
c        | Ascending sort of wanted Ritz values, vectors and error |
c        | bounds. Not necessary if only Ritz values are desired.  |
c        %---------------------------------------------------------%
c
         if (rvec) then
            call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq)
         else
            call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
         end if
c
      else
c
c        %-------------------------------------------------------------%
c        | *  Make a copy of all the Ritz values.                      |
c        | *  Transform the Ritz values back to the original system.   |
c        |    For TYPE = 'SHIFTI' the transformation is                |
c        |             lambda = 1/theta + sigma                        |
c        |    For TYPE = 'BUCKLE' the transformation is                |
c        |             lambda = sigma * theta / ( theta - 1 )          |
c        |    For TYPE = 'CAYLEY' the transformation is                |
c        |             lambda = sigma * (theta + 1) / (theta - 1 )     |
c        |    where the theta are the Ritz values returned by dsaupd.  |
c        | NOTES:                                                      |
c        | *The Ritz vectors are not affected by the transformation.   |
c        |  They are only reordered.                                   |
c        %-------------------------------------------------------------%
c
         call dcopy (ncv, workl(ihd), 1, workl(iw), 1)
         if (type .eq. 'SHIFTI') then
            do 40 k=1, ncv
               workl(ihd+k-1) = one / workl(ihd+k-1) + sigma
  40        continue
         else if (type .eq. 'BUCKLE') then
            do 50 k=1, ncv
               workl(ihd+k-1) = sigma * workl(ihd+k-1) /
     &                          (workl(ihd+k-1) - one)
  50        continue
         else if (type .eq. 'CAYLEY') then
            do 60 k=1, ncv
               workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) /
     &                          (workl(ihd+k-1) - one)
  60        continue
         end if
c
c        %-------------------------------------------------------------%
c        | *  Store the wanted NCONV lambda values into D.             |
c        | *  Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1)   |
c        |    into ascending order and apply sort to the NCONV theta   |
c        |    values in the transformed system. We'll need this to     |
c        |    compute Ritz estimates in the original system.           |
c        | *  Finally sort the lambda's into ascending order and apply |
c        |    to Ritz vectors if wanted. Else just sort lambda's into  |
c        |    ascending order.                                         |
c        | NOTES:                                                      |
c        | *workl(iw:iw+ncv-1) contain the theta ordered so that they  |
c        |  match the ordering of the lambda. We'll use them again for |
c        |  Ritz vector purification.                                  |
c        %-------------------------------------------------------------%
c
         call dcopy (nconv, workl(ihd), 1, d, 1)
         call dsortr ('LA', .true., nconv, workl(ihd), workl(iw))
         if (rvec) then
            call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq)
         else
            call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
            call dscal (ncv, bnorm2/rnorm, workl(ihb), 1)
            call dsortr ('LA', .true., nconv, d, workl(ihb))
         end if
c
      end if
c
c     %------------------------------------------------%
c     | Compute the Ritz vectors. Transform the wanted |
c     | eigenvectors of the symmetric tridiagonal H by |
c     | the Lanczos basis matrix V.                    |
c     %------------------------------------------------%
c
      if (rvec .and. howmny .eq. 'A') then
c
c        %----------------------------------------------------------%
c        | Compute the QR factorization of the matrix representing  |
c        | the wanted invariant subspace located in the first NCONV |
c        | columns of workl(iq,ldq).                                |
c        %----------------------------------------------------------%
c
         call dgeqr2 (ncv, nconv, workl(iq), ldq, workl(iw+ncv),
     &        workl(ihb), ierr)
c
c
c        %--------------------------------------------------------%
c        | * Postmultiply V by Q.                                 |
c        | * Copy the first NCONV columns of VQ into Z.           |
c        | The N by NCONV matrix Z is now a matrix representation |
c        | of the approximate invariant subspace associated with  |
c        | the Ritz values in workl(ihd).                         |
c        %--------------------------------------------------------%
c
         call dorm2r ('Right', 'Notranspose', n, ncv, nconv, workl(iq),
     &        ldq, workl(iw+ncv), v, ldv, workd(n+1), ierr)
         call dlacpy ('All', n, nconv, v, ldv, z, ldz)
c
c        %-----------------------------------------------------%
c        | In order to compute the Ritz estimates for the Ritz |
c        | values in both systems, need the last row of the    |
c        | eigenvector matrix. Remember, it's in factored form |
c        %-----------------------------------------------------%
c
         do 65 j = 1, ncv-1
            workl(ihb+j-1) = zero
  65     continue
         workl(ihb+ncv-1) = one
         call dorm2r ('Left', 'Transpose', ncv, 1, nconv, workl(iq),
     &        ldq, workl(iw+ncv), workl(ihb), ncv, temp, ierr)
c
      else if (rvec .and. howmny .eq. 'S') then
c
c     Not yet implemented. See remark 2 above.
c
      end if
c
      if (type .eq. 'REGULR' .and. rvec) then
c
            do 70 j=1, ncv
               workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) )
 70         continue
c
      else if (type .ne. 'REGULR' .and. rvec) then
c
c        %-------------------------------------------------%
c        | *  Determine Ritz estimates of the theta.       |
c        |    If RVEC = .true. then compute Ritz estimates |
c        |               of the theta.                     |
c        |    If RVEC = .false. then copy Ritz estimates   |
c        |              as computed by dsaupd.             |
c        | *  Determine Ritz estimates of the lambda.      |
c        %-------------------------------------------------%
c
         call dscal (ncv, bnorm2, workl(ihb), 1)
         if (type .eq. 'SHIFTI') then
c
            do 80 k=1, ncv
               workl(ihb+k-1) = abs( workl(ihb+k-1) ) / workl(iw+k-1)**2
 80         continue
c
         else if (type .eq. 'BUCKLE') then
c
            do 90 k=1, ncv
               workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) /
     &                          ( workl(iw+k-1)-one )**2
 90         continue
c
         else if (type .eq. 'CAYLEY') then
c
            do 100 k=1, ncv
               workl(ihb+k-1) = abs( workl(ihb+k-1) /
     &                          workl(iw+k-1)*(workl(iw+k-1)-one) )
 100        continue
c
         end if
c
      end if
c
c      if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
c         call dvout (logfil, nconv, d, ndigit,
c     &          '_seupd: Untransformed converged Ritz values')
c         call dvout (logfil, nconv, workl(ihb), ndigit,
c     &     '_seupd: Ritz estimates of the untransformed Ritz values')
c      else if (msglvl .gt. 1) then
c         call dvout (logfil, nconv, d, ndigit,
c     &          '_seupd: Converged Ritz values')
c         call dvout (logfil, nconv, workl(ihb), ndigit,
c     &     '_seupd: Associated Ritz estimates')
c      end if
c
c     %-------------------------------------------------%
c     | Ritz vector purification step. Formally perform |
c     | one of inverse subspace iteration. Only used    |
c     | for MODE = 3,4,5. See reference 7               |
c     %-------------------------------------------------%
c
      if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then
c
         do 110 k=0, nconv-1
            workl(iw+k) = workl(iq+k*ldq+ncv-1) / workl(iw+k)
 110     continue
c
      else if (rvec .and. type .eq. 'BUCKLE') then
c
         do 120 k=0, nconv-1
            workl(iw+k) = workl(iq+k*ldq+ncv-1) / (workl(iw+k)-one)
 120     continue
c
      end if
c
      if (type .ne. 'REGULR')
     &   call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz)
c
 9000 continue
c
      return
c
c     %---------------%
c     | End of dseupd |
c     %---------------%
c
      end


      SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V,
     $                   LDV, DWORK )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To separate a zero singular value of a bidiagonal submatrix of
C     order k, k <= p, of the bidiagonal matrix
C
C               |Q(1) E(1)  0    ...   0   |
C               | 0   Q(2) E(2)        .   |
C           J = | .                    .   |
C               | .                  E(p-1)|
C               | 0   ...  ...   ...  Q(p) |
C
C     with p = MIN(M,N), by annihilating one or two superdiagonal
C     elements E(i-1) (if i > 1) and/or E(i) (if i < k).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATU  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix U the left-hand Givens rotations S, as follows:
C             = .FALSE.:  Do not form U;
C             = .TRUE. :  The given matrix U is updated (postmultiplied)
C                         by the left-hand Givens rotations S.
C
C     UPDATV  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix V the right-hand Givens rotations T, as follows:
C             = .FALSE.:  Do not form V;
C             = .TRUE. :  The given matrix V is updated (postmultiplied)
C                         by the right-hand Givens rotations T.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix U.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows of the matrix V.  N >= 0.
C
C     I       (input) INTEGER
C             The index of the negligible diagonal entry Q(I) of the
C             bidiagonal matrix J, I <= p.
C
C     K       (input) INTEGER
C             The index of the last diagonal entry of the considered
C             bidiagonal submatrix of J, i.e., E(K-1) is considered
C             negligible, K <= p.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (p)
C             where p = MIN(M,N).
C             On entry, Q must contain the diagonal entries of the
C             bidiagonal matrix J.
C             On exit, Q contains the diagonal entries of the
C             transformed bidiagonal matrix S' J T.
C
C     E       (input/output) DOUBLE PRECISION array, dimension (p-1)
C             On entry, E must contain the superdiagonal entries of J.
C             On exit, E contains the superdiagonal entries of the
C             transformed bidiagonal matrix S' J T.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,p)
C             On entry, if UPDATU = .TRUE., U must contain the M-by-p
C             left transformation matrix.
C             On exit, if UPDATU = .TRUE., the Givens rotations S on the
C             left, annihilating E(i) if i < k, have been postmultiplied
C             into U.
C             U is not referenced if UPDATU = .FALSE..
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= max(1,M) if UPDATU = .TRUE.;
C             LDU >= 1        if UPDATU = .FALSE..
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,p)
C             On entry, if UPDATV = .TRUE., V must contain the N-by-p
C             right transformation matrix.
C             On exit, if UPDATV = .TRUE., the Givens rotations T on the
C             right, annihilating E(i-1) if i > 1,  have been
C             postmultiplied into V.
C             V is not referenced if UPDATV = .FALSE..
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= max(1,N) if UPDATV = .TRUE.;
C             LDV >= 1        if UPDATV = .FALSE..
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK))
C             LDWORK >= 2*MAX(K-I,I-1),  if UPDATV = UPDATU = .TRUE.;
C             LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.;
C             LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.;
C             LDWORK >= 1,       if UPDATU = UPDATV = .FALSE..
C
C     METHOD
C
C     Let the considered bidiagonal submatrix be
C
C               |Q(1) E(1)  0                    ...   0   |
C               | 0   Q(2) E(2)                        .   |
C               | .                                    .   |
C               | .           Q(i-1) E(i-1)            .   |
C          Jk = | .                   Q(i) E(i)        .   |.
C               | .                       Q(i+1) .     .   |
C               | .                              ..    .   |
C               | .                                  E(k-1)|
C               | 0    ...                       ...  Q(k) |
C
C     A zero singular value of Jk manifests itself by a zero diagonal
C     entry Q(i) or in practice, a negligible value of Q(i).
C     When a negligible diagonal element Q(i) in Jk is present, the
C     bidiagonal submatrix Jk is split by the routine into 2 or 3
C     unreduced bidiagonal submatrices by annihilating E(i) (if i < k)
C     using Givens rotations S on the left and by annihilating E(i-1)
C     (if i > 1) using Givens rotations T on the right until Jk is
C     reduced to the form:
C
C               |Q(1) E(1)  0                ...   0   |
C               | 0         .                ...   .   |
C               | .                          ...   .   |
C               | .       Q(i-1) 0                 .   |
C     S' Jk T = | .              0   0             .   |.
C               | .                 Q(i+1)   .     .   |
C               | .                          ..    .   |
C               | .                              E(k-1)|
C               | 0    ...                   ...  Q(k) |
C
C     For more details, see [1, pp.11.12-11.14].
C
C     REFERENCES
C
C     [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W.
C         LINPACK User's Guide.
C         SIAM, Philadelphia, 1979.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Bidiagonal matrix, orthogonal transformation, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATU, UPDATV
      INTEGER           I, K, LDU, LDV, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      INTEGER           I1, IROT, L, L1, NROT
      DOUBLE PRECISION  C, F, G, R, S
C     .. External Subroutines ..
      EXTERNAL          DLARTG, DLASR
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
C
C     For speed, no tests of the input scalar arguments are done.
C
C     Quick return if possible.
C
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO
C
C     Annihilate E(I) (if I < K).
C
      IF ( I.LT.K ) THEN
         C = ZERO
         S = ONE
         IROT = 0
         NROT = K - I
C
         DO 20 L = I, K-1
            G = E(L)
            E(L) = C*G
            CALL DLARTG( Q(L+1), S*G, C, S, R )
            Q(L+1) = R
            IF ( UPDATU ) THEN
               IROT = IROT + 1
               DWORK(IROT) = C
               DWORK(IROT+NROT) = S
            END IF
   20    CONTINUE
C
         IF ( UPDATU )
     $      CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1),
     $                  DWORK(NROT+1), U(1,I), LDU )
      END IF
C
C     Annihilate E(I-1) (if I > 1).
C
      IF ( I.GT.1 ) THEN
         I1 = I - 1
         F  = E(I1)
         E(I1) = ZERO
C
         DO 40 L1 = 1, I1 - 1
            L = I - L1
            CALL DLARTG( Q(L), F, C, S, R )
            Q(L) = R
            IF ( UPDATV ) THEN
               DWORK(L) = C
               DWORK(L+I1) = S
            END IF
            G =  E(L-1)
            F = -S*G
            E(L-1) = C*G
   40    CONTINUE
C
         CALL DLARTG( Q(1), F, C, S, R )
         Q(1) = R
         IF ( UPDATV ) THEN
            DWORK(1) = C
            DWORK(I) = S
            CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1),
     $                  DWORK(I), V(1,1), LDV )
         END IF
      END IF
C
      RETURN
C *** Last line of MB02NY ***
      END


      function diskdf3ez(ep,am,ez)
      parameter (pi=3.1415926535,nrmax=1000)

      psi00 = pot(0.0,0.0)
      rc=rcirc(am)
      call omekap(rc,fomega,fkappa)
      vc=rc*fomega
      ec=pot(rc,0.0)+0.5*vc**2
      if (am.lt.0.) ec = 2.0*psi00 - ec
      sr2=sigr2(rc)
      sz2=sigz2(rc)
      if (sz2.gt.0.) then
         fvert=fnamidden(rc)*exp(-ez/sz2)/sqrt(2*pi*sz2)
         diskdf3ez=fomega/(pi*fkappa)/sr2*exp(-(ep - ec)/sr2)*fvert
      else
         diskdf3ez=0
      endif
c      if (.not.(diskdf3ez.gt.0.) .and..not.(diskdf3ez.lt.0.) .and..not.(diskdf3ez.eq.0.)) then
c         write(*,*) 'DISK DF WAS NAN.'
c         write(*,*) 'EP,EZ,AM:',ep,ez,am
c         write(*,*) 'RC,EC,SR2,SZ2:',rc,ec,sr2,sz2
c         write(*,*)
c      endif
      return
      end


!***************************************************************************************************************************
! This module is intended to calculate photosynthesis effects in the plant
! 12/09/2017 converted from UTF-8 to ANSI
! Atributes:
!
! Object functions:
!
! Static functions:
!
! Authors
! @danipilze
!*********

    Module YCA_Control_Photosyntesis !Module of environment

    contains

    !-------------------------------------------
    ! STATIC FUNCTIONS
    !-------------------------------------------

    ! Conventional method using PAR utilization efficiency (P)
    real function availableCarbohydrate_methodR(PARMJFAC, SRAD, PARU, CO2FP, TFP, RSFP, VPDFP, SLPF, PARI, PLTPOP)
        implicit none
        real, intent (in) :: PARMJFAC, SRAD, PARU, CO2FP, TFP, RSFP, VPDFP, SLPF, PARI, PLTPOP
        real :: CARBOTMPR = 0

        !CARBOTMPR = 0.0
        !DO L = 1, TS
        !    CARBOTMPRHR(L) = AMAX1(0.0,(PARMJFAC*RADHR(L)*3.6/1000.)*PARU*CO2FP*TFP* WFP * NFP * RSFP * VPDFPHR(L) * SLPF)       ! MF 17SE14 RADHR is in J/m2/s. Multiply by 3600 for hour, divide by 10^6 for MJ.
        !    CARBOTMPR = CARBOTMPR + CARBOTMPRHR(L)
        !END DO
        !
        !CARBOTMPR = AMAX1(0.0,(PARMJFAC*SRAD)*PARU*CO2FP*TFP* WFP * NFP * RSFP * VPDFP * SLPF) !LPM 02SEP2016 Deleted WFP and NFP
        CARBOTMPR = AMAX1(0.0,(PARMJFAC*SRAD)*PARU*CO2FP*TFP* RSFP * VPDFP * SLPF)

        availableCarbohydrate_methodR = CARBOTMPR * PARI / PLTPOP																		   !EQN 259
    end function availableCarbohydrate_methodR

    ! Modified conventional using internal CO2 (I)
    real function availableCarbohydrate_methodI(CO2, CO2AIR, CO2EX, CO2FP, CO2COMPC, PARMJFAC, PARFC, PARI, PARU, PLTPOP, RATM, RCROP, RLFC, RLF, RSFP, SLPF, SRAD, TMAX, TMIN, TFP, WFP)
        implicit none
        real, intent (in) :: CO2, CO2AIR, CO2EX, CO2FP, CO2COMPC, PARMJFAC, PARFC, PARI, PARU, PLTPOP, RATM, RCROP, RLFC, RLF, RSFP, SLPF, SRAD, TMAX, TMIN, TFP, WFP
        real :: CARBOTMP, CARBOTMPI, CO2INTPPM, CO2INTPPMP, CO2INT, CO2FPI, CARBOBEGIA  ! temp variables
        integer :: L !                                                                  ! temp variables
        real :: CARBOBEGI ! result

            !CARBOTMP = AMAX1(0.,PARMJFAC*SRAD*PARU*TFP*NFP*RSFP)                                                       !EQN 264 !LPM 02SEP2016 Deleted WFP and NFP
            CARBOTMP = AMAX1(0.,PARMJFAC*SRAD*PARU*TFP*RSFP)                                                       !EQN 264
        ! Calculate for no water stress for WFPI determination
        CARBOTMPI = CARBOTMP
        CO2INTPPMP = CO2
        DO L = 1,20
            CO2INT = CO2AIR - CARBOTMPI * (RATM+RCROP*RLFC/RLF*WFP*(1.0*(1.0-WFP)))*1.157407E-05						!EQN 265
            CO2INTPPM = AMAX1(CO2COMPC+20.0,CO2INT *(8.314*1.0E7*((TMAX+TMIN)*.5+273.))/(1.0E12*1.0E-6*44.))			!EQN 269
            CO2FPI = PARFC*((1.-EXP(-CO2EX*CO2INTPPM))-(1.-EXP(-CO2EX*CO2COMPC)))										!EQN 268
            CARBOTMPI = CARBOTMP * CO2FPI
            IF (ABS(CO2INTPPM-CO2INTPPMP) < 1.0) EXIT
            CO2INTPPMP = CO2INTPPM
        ENDDO
        CARBOBEGIA = 0.0
            IF (CARBOTMPI > 0) CARBOBEGIA =(CARBOTMP*CO2FP)/CARBOTMPI                                                 !EQN 270
        CARBOTMPI = CARBOTMP
        CO2INTPPMP = CO2
        DO L = 1,20
            CO2INT = CO2AIR - CARBOTMPI * (RATM+RCROP*RLFC/RLF*WFP*(1.*(1.-WFP)))*1.157407E-05
            CO2INTPPM = AMAX1(CO2COMPC,CO2INT *(8.314*1.0E7*((TMAX+TMIN)*0.5+273.))/(1.0E12*1.0E-6*44.0))				!EQN 271
            CO2FPI = PARFC*((1.-EXP(-CO2EX*CO2INTPPM))-(1.-EXP(-CO2EX*CO2COMPC)))
            CARBOTMPI = CARBOTMP * CO2FPI
            !---- DA 25APR2017 is this used at all?
            IF (ABS(CO2INTPPM-CO2INTPPMP) < 1.0) EXIT
            IF (ABS(CO2INTPPM-CO2COMPC) < 1.0) EXIT
            CO2INTPPMP = CO2INTPPM
            !----

        ENDDO
            CARBOBEGI = CARBOTMPI * SLPF * PARI / PLTPOP * CARBOBEGIA                                                  !EQN 272

        availableCarbohydrate_methodI = CARBOBEGI

    end function availableCarbohydrate_methodI

    ! Alternate method using resistances as per Monteith (M)
    ! Calculate photosynthetic efficiency
    ! Use 10 Mj.m2.d PAR to establish quantum requirement
    real function availableCarbohydrate_methodM(CO2AIR,PARU, RATM, RCROP,RLFC, RLF, WFP, MJPERE, PARMJFAC, SRAD, TFP, RSFP, SLPF, PARI, PLTPOP)
        implicit none
        real, intent (in) :: CO2AIR,PARU, RATM, RCROP,RLFC, RLF, WFP, MJPERE, PARMJFAC, SRAD, TFP, RSFP, SLPF, PARI, PLTPOP
        real :: PHOTQR, RM
        real :: CARBOTMPM = 0

        PHOTQR = (CO2AIR/(10.0*PARU)-((RATM+RCROP*RLFC/RLF*WFP*(1.*(1.-WFP)))*1.157407E-05))*(10.0*30.0)/(CO2AIR*MJPERE) ! 30 = MW Ch2o!EQN 273
        RM = CO2AIR/(((SRAD*PARMJFAC/MJPERE)/PHOTQR)*30.0)                                                               !EQN 274
        !CARBOTMPM = AMAX1(0.,(CO2AIR/((RATM+RCROP*RLFC/RLF*WFP*(1.*(1.-WFP)))*1.157407E-05+RM))*TFP*NFP*RSFP)           !EQN 275 !LPM 02SEP2016 Deleted NFP
        CARBOTMPM = AMAX1(0.,(CO2AIR/((RATM+RCROP*RLFC/RLF*WFP*(1.*(1.-WFP)))*1.157407E-05+RM))*TFP*RSFP)                    !EQN 275

        availableCarbohydrate_methodM = CARBOTMPM * SLPF * PARI / PLTPOP																	 !EQN 276

    end function availableCarbohydrate_methodM

    ! Alternate method V
    real function availableCarbohydrate_methodV(TMin, TMax, TDEW, SRAD, PHTV, PHSV, KCANI, LAI, PARUE)
        USE YCA_Control_Environment
        USE YCA_Control_VPDEffect
        implicit none
        real, intent (in) :: TMin, TMax, TDEW, SRAD, PHTV, PHSV, KCANI, LAI, PARUE
        type (DailyEnvironment_type)                     :: env
        type (VPDEffect_type)                            :: vpde
        real hourlyStomatalConductance
        real dailyBiomass
        integer I

        env = DailyEnvironment_type(TMin, TMax, TDEW, SRAD)
        vpde = VPDEffect_type(PHTV, PHSV)
        dailyBiomass = 0.0
        DO I = 1, 24
            hourlyStomatalConductance = vpde%affectStomatalConductance(env%hourlyVPD(I))
            dailyBiomass = dailyBiomass + env%hourlyBiomass(I, KCANI, LAI, PARUE,hourlyStomatalConductance )
        END DO

        availableCarbohydrate_methodV = dailyBiomass

    end function availableCarbohydrate_methodV

END Module YCA_Control_Photosyntesis


      module conref_C
      USE vast_kind_param, ONLY:  double
      real(double), dimension(2,10) :: fpcref
!
!   Fundamental physical constants
!
!   fpcref(1,*) = 1998 Codata  fpcref(2,8) = old constants
!
    data fpcref(1, 1) / 1.602176462d0 /         ! Elementary charge, in Coulombs*10**19
    data fpcref(2, 1) / 1.60217733d0 /
    data fpcref(1, 2) / 14.399643d0 /           ! a0*(one au in eV)
    data fpcref(2, 2) / 14.399d0 /
    data fpcref(1, 3) / 0.5291772083d0 /        ! a0
    data fpcref(2, 3) / 0.529167d0 /
    data fpcref(1, 4) / 27.2113834d0 /          ! one au in eV
    data fpcref(2, 4) / 27.21d0 /
    data fpcref(1, 5) / 1.9872065d0 /           ! "R", the gas constant, in calories
    data fpcref(2, 5) / 1.98726d0 /
    data fpcref(1, 6) / 6.6260755d-27 /         ! Planck's constant in Joule-seconds
    data fpcref(2, 6) / 6.626d-27 /
    data fpcref(1, 7) / 1.3806503d-16 /         ! Boltzmann's constant
    data fpcref(2, 7) / 1.3807d-16 /
    data fpcref(1, 8) / 2.99792458d+10 /        ! Speed of light, in cm/sec
    data fpcref(2, 8) / 2.99776d+10 /
    data fpcref(1, 9) / 23.060529d0 /           ! 1eV in kcal/mol = (ref(1)*ref(10)*10**(-3))/4.184
    data fpcref(2, 9) / 23.061d0 /
    data fpcref(1, 10) / 6.0221367d23 /         ! Avogadro's number (1/mole)
    data fpcref(2, 10) / 6.02205d23 /
end module conref_C
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!


      SUBROUTINE revcst(x,y,iorder,ncity,n,de)
      INTEGER ncity,iorder(ncity),n(6)
      REAL de,x(ncity),y(ncity)
      INTEGER ii,j
      REAL alen,xx(4),yy(4),x1,x2,y1,y2
      alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2)
      n(3)=1+mod((n(1)+ncity-2),ncity)
      n(4)=1+mod(n(2),ncity)
      do 11 j=1,4
        ii=iorder(n(j))
        xx(j)=x(ii)
        yy(j)=y(ii)
11    continue
      de=-alen(xx(1),xx(3),yy(1),yy(3))-alen(xx(2),xx(4),yy(2),yy(4))+
     *alen(xx(1),xx(4),yy(1),yy(4))+alen(xx(2),xx(3),yy(2),yy(3))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/revcst.for


C
C
C  Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
C
C  This program is free software; you can redistribute it and/or modify it
C  under the terms of version 2.1 of the GNU Lesser General Public License
C  as published by the Free Software Foundation.
C
C  This program is distributed in the hope that it would be useful, but
C  WITHOUT ANY WARRANTY; without even the implied warranty of
C  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
C
C  Further, this software is distributed without any warranty that it is
C  free of the rightful claim of any third person regarding infringement
C  or the like.  Any license provided herein, whether implied or
C  otherwise, applies only to this software file.  Patent licenses, if
C  any, provided herein do not apply to combinations of this program with
C  other software, or any other product whatsoever.
C
C  You should have received a copy of the GNU Lesser General Public
C  License along with this program; if not, write the Free Software
C  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307,
C  USA.
C
C  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
C  Mountain View, CA 94043, or:
C
C  http://www.sgi.com
C
C  For further information regarding this notice, see:
C
C  http://oss.sgi.com/projects/GenInfo/NoticeExplan
C
C

      SUBROUTINE _C4GEMMX( ICONJA, ICONJB, M, N, K, ALPHA, A, INCCA,
     $                   INCRA, B, INCCB, INCRB, BETA, C, INCCC, INCRC )
!DIR$ ID "@(#) libfi/matrix/c4gemmx.f	92.0	"
!DIR$ ID "10/08/98 14:37:14"
*     Remove this entry when the -e U option is working for cf90.
*     ENTRY C4GEMMX_( ICONJA, ICONJB, M, N, K, ALPHA, A, INCCA,
*    $                   INCRA, B, INCCB, INCRB, BETA, C, INCCC, INCRC )
*
*  -- X-interface BLAS specification --
*     E. Anderson, Cray Research Inc.
*     February 25, 1993
*
*     .. Scalar Arguments ..
      INTEGER            ICONJA, ICONJB, INCCA, INCCB, INCCC, INCRA,
     $                   INCRB, INCRC, K, M, N
      COMPLEX(KIND=4)    ALPHA, BETA
C     COMPLEX*8          ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX(KIND=4)    A( * ), B( * ), C( * )
C     COMPLEX*8          A( * ), B( * ), C( * )
*     ..
*
*  Purpose
*  =======
*
*  C4GEMMX performs the matrix-matrix operation
*
*     C := alpha*A*B + beta*C,
*
*  where alpha and beta are scalars, A is an m-by-k matrix,
*  B is a k-by-n matrix, and C is an m-by-n matrix.  Arbitrary row
*  and column increments are permitted for the matrices, which allows
*  transposes.  For example, a matrix A with leading dimension LDA is
*  specified by INCCA = 1, INCRA = LDA, while the transpose of A is
*  specified by INCCA = LDA, INCRA = 1.
*
*  Arguments
*  =========
*
*  ICONJA  (input) INTEGER
*          Specifies whether the matrix A or its conjugate will be used.
*          = 0:  No conjugate for A
*          = 1:  Use conjugate of A
*
*  ICONJB  (input) INTEGER
*          Specifies whether the matrix B or its conjugate will be used.
*          = 0:  No conjugate for B
*          = 1:  Use conjugate of B
*
*  M       (input) INTEGER
*          The number of rows of the matrix A and of the matrix C.
*          M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix B and the number of
*          columns of the matrix C.  N >= 0.
*
*  K       (input) INTEGER
*          The number of columns of the matrix A and the number of
*          rows of the matrix B.  K >= 0.
*
*  ALPHA   (input) COMPLEX
*          The scalar alpha.
*
*  A       (input) COMPLEX array, dimension
*                  (1 + abs(INCCA)*(M-1) + abs(INCRA)*(K-1))
*          The m-by-k matrix A with column and row increments specified
*          by INCCA and INCRA.
*
*  INCCA   (input) INTEGER
*          The increment between elements in a column of A.
*
*  INCRA   (input) INTEGER
*          The increment between elements in a row of A.
*
*  B       (input) COMPLEX array, dimension
*                  (1 + abs(INCCB)*(K-1) + abs(INCRB)*(N-1))
*          The k-by-n matrix B with column and row increments specified
*          by INCCB and INCRB.
*
*  INCCB   (input) INTEGER
*          The increment between elements in a column of B.
*
*  INCRB   (input) INTEGER
*          The increment between elements in a row of B.
*
*  BETA    (input) COMPLEX
*          The scalar beta.
*
*  C       (input/output) COMPLEX array, dimension
*                         (1 + abs(INCCC)*(M-1) + abs(INCRC)*(N-1))
*          On entry, the m-by-n matrix C with column and row increments
*          specified by INCCC and INCRC.  If beta = 0. on input, then C
*          is initialized to zero and need not be set on input.
*
*          On exit, the array C is overwritten by the m-by-n matrix
*          alpha*A*B + beta*C.
*
*  INCCC   (input) INTEGER
*          The increment between elements in a column of C.
*
*  INCRC   (input) INTEGER
*          The increment between elements in a row of C.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX(KIND=4)           ONE, ZERO
C     COMPLEX*8                 ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IA, IB, IC, J, JA, JB, JC, L
      COMPLEX(KIND=4)    TEMP
C     COMPLEX*8          TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) .OR.
     $    ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ. ONE ) ) )RETURN

*     Set the result to zeros and exit
      IF ( K.EQ.0 ) THEN
           DO, J = 1, N
               DO, I = 1, M
                   IC = INCRC*(J - 1) + INCCC*(I - 1) + 1
                   C( IC ) = ZERO
               END DO
           END DO
           RETURN
       END IF
*
*     Compute C := alpha*A*B + beta*C
*
      JB = 1
      JC = 1
      DO 70 J = 1, N
         JA = 1
         IB = JB
*
*        Scale C by beta (or set to zero if beta is zero).
*
         IF( BETA.EQ.ZERO ) THEN
            IC = JC
            DO 10 I = 1, M
               C( IC ) = ZERO
               IC = IC + INCCC
   10       CONTINUE
         ELSE IF( BETA.NE.ONE ) THEN
            IC = JC
            DO 20 I = 1, M
               C( IC ) = BETA*C( IC )
               IC = IC + INCCC
   20       CONTINUE
         END IF
*
         IF( ICONJA.EQ.0 ) THEN
            DO 40 L = 1, K
               IA = JA
               IC = JC
               IF( ICONJB.EQ.0 ) THEN
                  TEMP = ALPHA*B( IB )
               ELSE
                  TEMP = ALPHA*CONJG( B( IB ) )
               END IF
               IB = IB + INCCB
               DO 30 I = 1, M
                  C( IC ) = C( IC ) + TEMP*A( IA )
                  IA = IA + INCCA
                  IC = IC + INCCC
   30          CONTINUE
               JA = JA + INCRA
   40       CONTINUE
         ELSE
            DO 60 L = 1, K
               IA = JA
               IC = JC
               IF( ICONJB.EQ.0 ) THEN
                  TEMP = ALPHA*B( IB )
               ELSE
                  TEMP = ALPHA*CONJG( B( IB ) )
               END IF
               IB = IB + INCCB
               DO 50 I = 1, M
                  C( IC ) = C( IC ) + TEMP*CONJG( A( IA ) )
                  IA = IA + INCCA
                  IC = IC + INCCC
   50          CONTINUE
               JA = JA + INCRA
   60       CONTINUE
         END IF
         JB = JB + INCRB
         JC = JC + INCRC
   70 CONTINUE
*
      RETURN
*
*     End of C4GEMMX
*
      END


      module k0

      implicit none (type, external)
      private
      public:: besk0

      contains

      SUBROUTINE CALCK0(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the second kind
C   and order zero, K0(X) and EXP(X)*K0(X), for real
C   arguments X.  It contains two function type subprograms, BESK0
C   and BESEK0, and one subroutine type subprogram, CALCK0.
C   the calling statements for the primary entries are
C
C                   Y=BESK0(X)
C   and
C                   Y=BESEK0(X)
C
C   where the entry points correspond to the functions K0(X) and
C   EXP(X)*K0(X), respectively.  The routine CALCK0 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCK0 with the statement
C          CALL CALCK0(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCK0
C       Call              ARG                  RESULT          JINT
C
C     BESK0(ARG)   0 .LT. ARG .LE. XMAX       K0(ARG)           1
C     BESEK0(ARG)     0 .LT. ARG           EXP(ARG)*K0(ARG)     2
C
C   The main computation evaluates slightly modified forms of near
C   minimax rational approximations generated by Russon and Blair,
C   Chalk River (Atomic Energy of Canada Limited) Report AECL-3461,
C   1969.  This transportable program is patterned after the
C   machine-dependent FUNPACK packet NATSK0, but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   functions that theoretically approximate K-SUB-0(X) to at
C   least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C   XSMALL = Argument below which BESK0 and BESEK0 may
C            each be represented by a constant and a log.
C            largest X such that  1.0 + X = 1.0  to machine
C            precision.
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMAX   = Largest argument acceptable to BESK0;  Solution to
C            equation:
C               W(X) * (1-1/8X+9/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C
C
C     Approximate values for some important machines are:
C
C
C                           beta       minexp       maxexp
C
C  CRAY-1        (S.P.)       2        -8193         8191
C  Cyber 180/185
C    under NOS   (S.P.)       2         -975         1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2         -126          128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2        -1022         1024
C  IBM 3033      (D.P.)      16          -65           63
C  VAX D-Format  (D.P.)       2         -128          127
C  VAX G-Format  (D.P.)       2        -1024         1023
C
C
C                          XSMALL       XINF         XMAX
C
C CRAY-1        (S.P.)    3.55E-15   5.45E+2465    5674.858
C Cyber 180/855
C   under NOS   (S.P.)    1.77E-15   1.26E+322      672.788
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)    5.95E-8    3.40E+38        85.337
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)    1.11D-16   1.79D+308      705.342
C IBM 3033      (D.P.)    1.11D-16   7.23D+75       177.852
C VAX D-Format  (D.P.)    6.95D-18   1.70D+38        86.715
C VAX G-Format  (D.P.)    5.55D-17   8.98D+307      706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ARG .LE. 0.0, and the
C  BESK0 entry returns the value 0.0 for ARG .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     EXP, LOG, SQRT
C
C  Latest modification: March 19, 1990
C
C  Authors: W. J. Cody and Laura Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
      DOUBLE PRECISION
     1    ARG,F,G,ONE,P,PP,Q,QQ,RESULT,SUMF,SUMG,SUMP,SUMQ,TEMP,
     2    X,XINF,XMAX,XSMALL,XX,ZERO
      DIMENSION P(6),Q(2),PP(10),QQ(10),F(4),G(3)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/5.95E-8/,XINF/3.40E+38/,XMAX/ 85.337E0/
CD    DATA XSMALL/1.11D-16/,XINF/1.79D+308/,XMAX/705.342D0/
C--------------------------------------------------------------------
C
C     Coefficients for XSMALL .LE.  ARG  .LE. 1.0
C
C--------------------------------------------------------------------
CS    DATA   P/ 5.8599221412826100000E-04, 1.3166052564989571850E-01,
CS   1          1.1999463724910714109E+01, 4.6850901201934832188E+02,
CS   2          5.9169059852270512312E+03, 2.4708152720399552679E+03/
CS    DATA   Q/-2.4994418972832303646E+02, 2.1312714303849120380E+04/
CS    DATA   F/-1.6414452837299064100E+00,-2.9601657892958843866E+02,
CS   1         -1.7733784684952985886E+04,-4.0320340761145482298E+05/
CS    DATA   G/-2.5064972445877992730E+02, 2.9865713163054025489E+04,
CS   1         -1.6128136304458193998E+06/
CD    DATA   P/ 5.8599221412826100000D-04, 1.3166052564989571850D-01,
CD   1          1.1999463724910714109D+01, 4.6850901201934832188D+02,
CD   2          5.9169059852270512312D+03, 2.4708152720399552679D+03/
CD    DATA   Q/-2.4994418972832303646D+02, 2.1312714303849120380D+04/
CD    DATA   F/-1.6414452837299064100D+00,-2.9601657892958843866D+02,
CD   1         -1.7733784684952985886D+04,-4.0320340761145482298D+05/
CD    DATA   G/-2.5064972445877992730D+02, 2.9865713163054025489D+04,
CD   1         -1.6128136304458193998D+06/
C--------------------------------------------------------------------
C
C     Coefficients for  1.0 .LT. ARG
C
C--------------------------------------------------------------------
CS    DATA  PP/ 1.1394980557384778174E+02, 3.6832589957340267940E+03,
CS   1          3.1075408980684392399E+04, 1.0577068948034021957E+05,
CS   2          1.7398867902565686251E+05, 1.5097646353289914539E+05,
CS   3          7.1557062783764037541E+04, 1.8321525870183537725E+04,
CS   4          2.3444738764199315021E+03, 1.1600249425076035558E+02/
CS    DATA  QQ/ 2.0013443064949242491E+02, 4.4329628889746408858E+03,
CS   1          3.1474655750295278825E+04, 9.7418829762268075784E+04,
CS   2          1.5144644673520157801E+05, 1.2689839587977598727E+05,
CS   3          5.8824616785857027752E+04, 1.4847228371802360957E+04,
CS   4          1.8821890840982713696E+03, 9.2556599177304839811E+01/
CD    DATA  PP/ 1.1394980557384778174D+02, 3.6832589957340267940D+03,
CD   1          3.1075408980684392399D+04, 1.0577068948034021957D+05,
CD   2          1.7398867902565686251D+05, 1.5097646353289914539D+05,
CD   3          7.1557062783764037541D+04, 1.8321525870183537725D+04,
CD   4          2.3444738764199315021D+03, 1.1600249425076035558D+02/
CD    DATA  QQ/ 2.0013443064949242491D+02, 4.4329628889746408858D+03,
CD   1          3.1474655750295278825D+04, 9.7418829762268075784D+04,
CD   2          1.5144644673520157801D+05, 1.2689839587977598727D+05,
CD   3          5.8824616785857027752D+04, 1.4847228371802360957D+04,
CD   4          1.8821890840982713696D+03, 9.2556599177304839811D+01/
C--------------------------------------------------------------------
      X = ARG
      IF (X .GT. ZERO) THEN
            IF (X .LE. ONE) THEN
C--------------------------------------------------------------------
C     0.0 .LT.  ARG  .LE. 1.0
C--------------------------------------------------------------------
                  TEMP = LOG(X)
                  IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C     Return for small ARG
C--------------------------------------------------------------------
                        RESULT = P(6)/Q(2) - TEMP
                     ELSE
                        XX = X * X
                        SUMP = ((((P(1)*XX + P(2))*XX + P(3))*XX +
     1                         P(4))*XX + P(5))*XX + P(6)
                        SUMQ = (XX + Q(1))*XX + Q(2)
                        SUMF = ((F(1)*XX + F(2))*XX + F(3))*XX + F(4)
                        SUMG = ((XX + G(1))*XX + G(2))*XX + G(3)
                        RESULT = SUMP/SUMQ - XX*SUMF*TEMP/SUMG - TEMP
                        IF (JINT .EQ. 2) RESULT = RESULT * EXP(X)
                  END IF
               ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
C--------------------------------------------------------------------
C     Error return for ARG .GT. XMAX
C--------------------------------------------------------------------
                  RESULT = ZERO
               ELSE
C--------------------------------------------------------------------
C     1.0 .LT. ARG
C--------------------------------------------------------------------
                  XX = ONE / X
                  SUMP = PP(1)
                  DO 120 I = 2, 10
                     SUMP = SUMP*XX + PP(I)
  120             CONTINUE
                  SUMQ = XX
                  DO 140 I = 1, 9
                     SUMQ = (SUMQ + QQ(I))*XX
  140             CONTINUE
                  SUMQ = SUMQ + QQ(10)
                  RESULT = SUMP / SUMQ / SQRT(X)
                  IF (JINT .EQ. 1) RESULT = RESULT * EXP(-X)
            END IF
         ELSE
C--------------------------------------------------------------------
C     Error return for ARG .LE. 0.0
C--------------------------------------------------------------------
            RESULT = XINF
      END IF
C--------------------------------------------------------------------
C     Update error counts, etc.
C--------------------------------------------------------------------
      RETURN
C---------- Last line of CALCK0 ----------
      END SUBROUTINE CALCK0
CS    REAL
      DOUBLE PRECISION    FUNCTION BESK0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order zero
C   for arguments 0.0 .LT. ARG .LE. XMAX (see comments heading
C   CALCK0).
C
C  Authors: W. J. Cody and Laura Stoltz
C
C  Latest Modification: January 19, 1988
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION     X, RESULT
C--------------------------------------------------------------------
      JINT = 1
      CALL CALCK0(X,RESULT,JINT)
      BESK0 = RESULT
      RETURN
C---------- Last line of BESK0 ----------
      END FUNCTION BESK0
CS    REAL
      DOUBLE PRECISION     FUNCTION BESEK0(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order zero
C   multiplied by the Exponential function, for arguments
C   0.0 .LT. ARG.
C
C  Authors: W. J. Cody and Laura Stoltz
C
C  Latest Modification: January 19, 1988
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION  X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK0(X,RESULT,JINT)
      BESEK0 = RESULT
      RETURN
C---------- Last line of BESEK0 ----------
      END FUNCTION BESEK0

      end module k0


	program ftr
	implicit doubleprecision (a-h,o-z)
        integer*4,parameter :: nf=20000
	real*8, dimension(nf) :: w, t
        complex*16, dimension(nf) :: ac,ft
	complex*16 im,te
	real*4 a1,a2,a3,a4,a5
        character*32 fil1,fil2,fil3

        im=(0.d0,1.d0)

	open(20,file='ftr_in',status='old')
	read(20,*) nm,beta
	read(20,*) fil1

        open(25,file='cor1', status='old')
        open(26,file='fft.dat')
!       energy  units
        eu=27.2d0/1836.15
        emx=4d0
        write(*,*) 'energy unit',eu

	do 1 i=1,nm
	  read(25,1000) x1,ac(i),xx
	 t(i)=x1
1	continue

        print *,'ac',ac(1)

	ac(1)=ac(1)/2.d0
	ac(nm)=ac(nm)/2.d0

!-------- damp the signal ----------------
!        beta = 0d0
!        beta=-log(beta/x2)/t(nm)**2

!       do  i=1,nm
!         ac(i)=ac(i)*exp(-beta*t(i)**2)
!        enddo

	pi=4.d0*atan(1.d0)
	dt=abs(t(2)-t(1))
	write(*,*) dt,nm
	h=0.5d0/nm/dt*pi
	nw=emx/h
	write(*,*) h,nw

        de = 0.05
        nw = 100
	do 3 i=1,nw
	  w(i)=de*i
3	continue

        print *,im,ac(1),dt,t(1),w(1)

	do 2 k=1,nw
	  ft(k)=(0.d0,0.d0)
	  do  i=1,nm
	    ft(k) = ac(i)*exp(im*w(k)*t(i)) + ft(k)
          enddo
!	  fin=dreal(ft(k))*dt
	  fin=abs(ft(k))*dt
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
          print *,'ft',ft(k)
          write(26,1000) w(k),ft(k)*dt
2	  continue

1001    format(20(e14.5,1x))
1000    format(20(e14.7,1x))
	stop
	end