!   gfortran -cpp -O3 -flto ex_5.f90 -o ex_5
!   ./ex_5

!   Assemble high-order interpolants over a uniform domain.
!

#   include "../src/ppr_1d.f90"

    program ex

        use ppr_1d

        implicit none

        integer, parameter :: npos = 43 ! no. edge
        integer, parameter :: nvar = 1  ! no. variables to build
        integer, parameter :: ndof = 1  ! no. FV DoF per cell
        integer :: ipos,jpos,mdof

    !------------------------------- domain discretisation !
        real*8  :: xpos(npos),xdel(1)
        real*8  :: xmid,xhat,xloc,floc

    !-------------------------------- finite-volume arrays !

    !   Arrays represent a "block" of finite-volume tracers
    !   to remap. The 1st dim. is the no. of DoF per cell,
    !   NDOF=1 is a standard finite-volume scheme where the
    !   data is specified as cell means. NDOF>1 is reserved
    !   for future use with DG-style schemes. NVAR is the
    !   number of tracers to remap. Processing tracers in a
    !   batch is typically more efficient than one-by-one.
    !   The last dim. is the no. cells (layers) in the grid.

        real*8  :: fdat(ndof,nvar,npos-1)

    !-------------------------------- reconstruction coeff !

    !   Coeff. for the piecewise polynomial reconstruction.
    !   A polynomial is assembled for each cell w.r.t. a
    !   "local" cell coordinate system: each cell is mapped
    !   onto [-1,+1]. The interpolants can be evaluated by
    !   taking the product FHAT*BVEC, where BVEC is a basis
    !   vector assembled at the interpolation points. Basis
    !   vectors can eb assembled via calls to BFUN1D().

        real*8  :: fhat(   5,nvar,npos-1)
        real*8  :: bvec(   5)
        real*8  :: spos(   5)

    !------------------------------ method data-structures !
        type(rcon_work) :: work
        type(rcon_opts) :: opts
        type(rcon_ends) :: bc_l(nvar)
        type(rcon_ends) :: bc_r(nvar)

    !------------------------------ define a simple domain !

        call linspace(0.d0,1.d0,npos,xpos)

        xdel(1) = (xpos(npos)&
    &           -  xpos(   1)) / (npos- 1)

    !------------------------------ setup some simple data !

        do ipos = +1, npos-1

            xmid = xpos(ipos+0) * 0.5d+0 &
    &            + xpos(ipos+1) * 0.5d+0

            fdat(1,1,ipos) = &
    &   .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) &
    & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) &
    & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 )

        end do

    !------------------------------ specify method options !

        opts%edge_meth = p5e_method     ! 5th-order edge interp.
        opts%cell_meth = pqm_method     ! PPM method in cells
        opts%cell_lims = mono_limit     ! monotone limiter

    !------------------------------ set BC.'s at endpoints !

        bc_l%bcopt = bcon_loose         ! "loose" = extrapolate
        bc_r%bcopt = bcon_loose

    !------------------------------ init. method workspace !

        call work%init(npos,nvar,opts)

    !------------------------------ build cell polynomials !

        fhat = 0.d+0

        mdof = ndof1d (opts%cell_meth)

        call rcon1d(npos,nvar,ndof,xdel, &
    &               fdat,bc_l,bc_r,fhat, &
    &               work,opts)

    !------------------------------ clear method workspace !

        call work%free()

    !------------------------------ dump results to stdout !

        print*,"Eval. PPR interpolant: "

        spos(1) = -1.0d+0               ! eval. at local points
        spos(2) = -0.5d+0
        spos(3) = +0.0d+0
        spos(4) = +0.5d+0
        spos(5) = +1.0d+0

        do ipos = +1, npos-1
        do jpos = +1, +5

            xmid = xpos(ipos+1)* 0.5d+0 &
    &            + xpos(ipos+0)* 0.5d+0

            xhat = xpos(ipos+1)* 0.5d+0 &
    &            - xpos(ipos+0)* 0.5d+0

            xloc = xmid + spos(jpos)*xhat

            call bfun1d(0,mdof,spos(jpos),bvec)

            floc = dot_product( &
    &       fhat(+1:mdof,1,ipos),bvec(+1:mdof))

            print *, xloc, floc

        end do
        end do

    end program


*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TYPE
*       INTEGER            INFO, KL, KU, LDA, M, N
*       DOUBLE PRECISION   CFROM, CTO
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLASCL multiplies the M by N real matrix A by the real scalar
*> CTO/CFROM.  This is done without over/underflow as long as the final
*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
*> A may be full, upper triangular, lower triangular, upper Hessenberg,
*> or banded.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TYPE
*> \verbatim
*>          TYPE is CHARACTER*1
*>          TYPE indices the storage type of the input matrix.
*>          = 'G':  A is a full matrix.
*>          = 'L':  A is a lower triangular matrix.
*>          = 'U':  A is an upper triangular matrix.
*>          = 'H':  A is an upper Hessenberg matrix.
*>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
*>                  and upper bandwidth KU and with the only the lower
*>                  half stored.
*>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
*>                  and upper bandwidth KU and with the only the upper
*>                  half stored.
*>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
*>                  bandwidth KU. See DGBTRF for storage details.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
*>          'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
*>          'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] CFROM
*> \verbatim
*>          CFROM is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*>          CTO is DOUBLE PRECISION
*>
*>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
*>          without over/underflow if the final result CTO*A(I,J)/CFROM
*>          can be represented without over/underflow.  CFROM must be
*>          nonzero.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
*>          storage type.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          0  - successful exit
*>          <0 - if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      DOUBLE PRECISION   CFROM, CTO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, DISNAN
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH, DISNAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
*
      IF( LSAME( TYPE, 'G' ) ) THEN
         ITYPE = 0
      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
         ITYPE = 2
      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
         ITYPE = 3
      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
         ITYPE = 4
      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
         ITYPE = 5
      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
         ITYPE = 6
      ELSE
         ITYPE = -1
      END IF
*
      IF( ITYPE.EQ.-1 ) THEN
         INFO = -1
      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
         INFO = -4
      ELSE IF( DISNAN(CTO) ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
         INFO = -7
      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( ITYPE.GE.4 ) THEN
         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
            INFO = -2
         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
     $             THEN
            INFO = -3
         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
            INFO = -9
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASCL', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. M.EQ.0 )
     $   RETURN
*
*     Get machine parameters
*
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
*
      CFROMC = CFROM
      CTOC = CTO
*
   10 CONTINUE
      CFROM1 = CFROMC*SMLNUM
      IF( CFROM1.EQ.CFROMC ) THEN
!        CFROMC is an inf.  Multiply by a correctly signed zero for
!        finite CTOC, or a NaN if CTOC is infinite.
         MUL = CTOC / CFROMC
         DONE = .TRUE.
         CTO1 = CTOC
      ELSE
         CTO1 = CTOC / BIGNUM
         IF( CTO1.EQ.CTOC ) THEN
!           CTOC is either 0 or an inf.  In both cases, CTOC itself
!           serves as the correct multiplication factor.
            MUL = CTOC
            DONE = .TRUE.
            CFROMC = ONE
         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
            MUL = SMLNUM
            DONE = .FALSE.
            CFROMC = CFROM1
         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
            MUL = BIGNUM
            DONE = .FALSE.
            CTOC = CTO1
         ELSE
            MUL = CTOC / CFROMC
            DONE = .TRUE.
         END IF
      END IF
*
      IF( ITYPE.EQ.0 ) THEN
*
*        Full matrix
*
         DO 30 J = 1, N
            DO 20 I = 1, M
               A( I, J ) = A( I, J )*MUL
   20       CONTINUE
   30    CONTINUE
*
      ELSE IF( ITYPE.EQ.1 ) THEN
*
*        Lower triangular matrix
*
         DO 50 J = 1, N
            DO 40 I = J, M
               A( I, J ) = A( I, J )*MUL
   40       CONTINUE
   50    CONTINUE
*
      ELSE IF( ITYPE.EQ.2 ) THEN
*
*        Upper triangular matrix
*
         DO 70 J = 1, N
            DO 60 I = 1, MIN( J, M )
               A( I, J ) = A( I, J )*MUL
   60       CONTINUE
   70    CONTINUE
*
      ELSE IF( ITYPE.EQ.3 ) THEN
*
*        Upper Hessenberg matrix
*
         DO 90 J = 1, N
            DO 80 I = 1, MIN( J+1, M )
               A( I, J ) = A( I, J )*MUL
   80       CONTINUE
   90    CONTINUE
*
      ELSE IF( ITYPE.EQ.4 ) THEN
*
*        Lower half of a symmetric band matrix
*
         K3 = KL + 1
         K4 = N + 1
         DO 110 J = 1, N
            DO 100 I = 1, MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  100       CONTINUE
  110    CONTINUE
*
      ELSE IF( ITYPE.EQ.5 ) THEN
*
*        Upper half of a symmetric band matrix
*
         K1 = KU + 2
         K3 = KU + 1
         DO 130 J = 1, N
            DO 120 I = MAX( K1-J, 1 ), K3
               A( I, J ) = A( I, J )*MUL
  120       CONTINUE
  130    CONTINUE
*
      ELSE IF( ITYPE.EQ.6 ) THEN
*
*        Band matrix
*
         K1 = KL + KU + 2
         K2 = KL + 1
         K3 = 2*KL + KU + 1
         K4 = KL + KU + 1 + M
         DO 150 J = 1, N
            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  140       CONTINUE
  150    CONTINUE
*
      END IF
*
      IF( .NOT.DONE )
     $   GO TO 10
*
      RETURN
*
*     End of DLASCL
*
      END


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine eigen_subdiag_periodic(Rmat,evec,iter,ier2)
  use scf_data
  implicit none
  character :: JOBZ, UPLO
  integer :: LWORK
  integer :: iter,ier2
  real(8),allocatable :: RWORK(:)
  real(8) :: W(iter)
  complex(8) :: Rmat(iter,iter)
  complex(8),allocatable :: WORK(:)
  complex(8) :: evec(iter,iter)

  ier2=0

  JOBZ='V'
  UPLO='U'

  LWORK=2*iter-1
  allocate(WORK(LWORK))
  allocate(RWORK(3*iter-2))

  call ZHEEV(JOBZ,UPLO,iter,Rmat,iter,W,WORK,LWORK,RWORK,ier2)

  evec(:,:)=Rmat(:,:)

  deallocate(WORK,RWORK)

end subroutine eigen_subdiag_periodic


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
! $Id: geom_tet_quality.f90 3093 2008-04-22 14:51:09Z sfilippo $
!
! Description:
!
SUBMODULE(tools_mesh_basics) geom_tet_quality_implementation
    IMPLICIT NONE

    CONTAINS

        MODULE PROCEDURE geom_tet_quality
            USE class_psblas, ONLY : psb_dpk_
            USE class_vector !, ONLY : mag
            USE class_vertex, ONLY : vertex, OPERATOR(-)
            IMPLICIT NONE
            !
            INTEGER :: iv1, iv2
            REAL(psb_dpk_) :: sum_edge_sq
            TYPE(vertex) :: verts(4)
            TYPE(vector) :: verts_temp

            verts = [ v1, v2, v3, v4 ]

            sum_edge_sq = 0.d0

            ! All vertices are connected to all others, so just permutate to find all edge lengths
            DO iv2 = 1, 3
                DO iv1 = iv2 + 1, 4
                    verts_temp = verts(iv2) - verts(iv1)
                    !sum_edge_sq = sum_edge_sq + (verts(iv2) - verts(iv1))%mag()**2
                    sum_edge_sq = sum_edge_sq + verts_temp%mag()**2
                ENDDO
            ENDDO

            geom_tet_quality = SIGN((vol*vol)**(1.0d0/3.d0) * 6.0d0**(5.d0/3.d0) * 2.0**(1.d0/3.d0) / &
                &               sum_edge_sq, vol)  ! signed quality, must handle neg. volume

        END PROCEDURE geom_tet_quality

END SUBMODULE geom_tet_quality_implementation


      SUBROUTINE cfft99(a, work, trigs, ifax, inc, jump, n, lot, isign)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER inc, jump, n, lot, isign
      INTEGER, DIMENSION(*) :: ifax
      REAL(rprec) :: a(*), work(*), trigs(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: nn, ink, jum, nfax, jnk, jst, ibase, ilast, nh, l, i1,
     1   i2, m, jbase, i, j, igo, la, k
      REAL(rprec) :: hREAL, himag
C-----------------------------------------------
c
c     SUBROUTINE 'cfft99' - multiple fast complex fourier transform
c
c     a is the array containing input and output data
c     work is an area of SIZE n*lot
c     trigs is a previously prepared list of trig FUNCTION values
c     ifax is a previously prepared list of factors of n
c     inc is the increment within each data "vector"
c         (e.g. inc=1 for consecutively stored data)
c     jump is the increment between the start of each data vector
c     n is the length of the data vectors
c     lot is the number of data vectors
c     isign = +1 for transform from spectral to gridpoint
c           = -1 for transform from gridpoint to spectral
c
c
c     vectorization is achieved on cray by DOing the transforms in
c     parallel.
c
c
      nn = n+n
      ink=inc+inc
      jum = jump+jump
      nfax=ifax(1)
      jnk = 2
      jst = 2
      IF (isign.ge.0) GOTO 30
      jnk = -2
      jst = nn-2
      IF (MOD(nfax,2).eq.1) GOTO 40
      ibase = 1
      ilast = (n-1)*ink
      nh = n/2
      DO 20 l=1,lot
      i1 = ibase+ink
      i2 = ibase+ilast
cdir$ ivdep
      DO 10 m=1,nh
c     swap REAL and imaginary portions
      hREAL = a(i1)
      himag = a(i1+1)
      a(i1) = a(i2)
      a(i1+1) = a(i2+1)
      a(i2) = hreal
      a(i2+1) = himag
      i1 = i1+ink
      i2 = i2-ink
   10 CONTINUE
      ibase = ibase+jum
   20 CONTINUE
      GOTO 100
c
   30 CONTINUE
      IF (MOD(nfax,2).eq.0) GOTO 100
c
   40 CONTINUE
c
c     during the transform process, nfax steps are taken, and the
c     results are stored alternately in work and in a.  IF nfax is
c     odd, the input data are first moved to work so that the final
c     result (after nfax steps) is stored in array a.
c
      ibase=1
      jbase=1
      DO 60 l=1,lot
c     move REAL and imaginary portions of element zero
      work(jbase) = a(ibase)
      work(jbase+1) = a(ibase+1)
      i=ibase+ink
      j=jbase+jst
cdir$ ivdep
      DO 50 m=2,n
c     move REAL and imaginary portions of other elements (possibly in
c     reverse order, depending on jst and jnk)
      work(j) = a(i)
      work(j+1) = a(i+1)
      i=i+ink
      j=j+jnk
   50 CONTINUE
      ibase=ibase+jum
      jbase=jbase+nn
   60 CONTINUE
c
  100 CONTINUE
c
c     perform the transform passes, one pass for each factor.  during
c     each pass the data are moved from a to work or from work to a.
c
c     for nfax even, the first pass moves from a to work
      igo = 110
c     for nfax odd, the first pass moves from work to a
      IF (MOD(nfax,2).eq.1) igo = 120
      la=1
      DO 140 k=1,nfax
      IF (igo.eq.120) GOTO 120
  110 CONTINUE
      CALL vpassm(a(1),a(2),work(1),work(2),trigs,
     *   ink,2,jum,nn,lot,n,ifax(k+1),la)
      igo=120
      GOTO 130
  120 CONTINUE
      CALL vpassm(work(1),work(2),a(1),a(2),trigs,
     *    2,ink,nn,jum,lot,n,ifax(k+1),la)
      igo=110
  130 CONTINUE
      la=la*ifax(k+1)
  140 CONTINUE
c
c     at this point the final transform result is stored in a.
c
      END SUBROUTINE cfft99


! NPV subroutine
! Lubello: feb 2020

subroutine NPVcalc(curveNPV0,    & ! (I) VAN buying from grid
                   curveNPV,     & ! (I) VAN considered configuration
                   TotActInvest, & ! (I) Total actual investment
                   deltaNPV,     & ! (O) VAN difference between two cases
                   ActPBP,       & ! (O) Actualized payback period
                   ProfInd)        ! (O) Profit index

      USE MODparam, ONLY: NdayYear,Nyears,Nstep,MaxGiorni

      implicit real(8) (a-h,o-z), integer(i-n)

      ! Argument declarations

      real(8), dimension(0:MaxGiorni), intent(IN   ):: curveNPV0, curveNPV
      real(8),                         intent(IN   ):: TotActInvest
      real(8), dimension(0:MaxGiorni), intent(  OUT):: deltaNPV
      real(8),                         intent(  OUT):: ActPBP,ProfInd

      ! NPV as a difference between case 1 and case 0

      deltaNPV(0:Nstep) = curveNPV(0:Nstep) - curveNPV0(0:Nstep)

      ! Actualized payback period
      ii = 0
      do while ((deltaNPV(ii) .le. 0.d0) .and. (ii .le. Nstep))
        ii=ii+1
      enddo

      if(ii .ge. Nstep) then
        ActPBP = 9999.9999d0
      else
        ActPBP = dble(ii)/NdayYear
      endif

      ! Profit Index
      ProfInd = deltaNPV(Nstep)/TotActInvest

      return

end subroutine NPVcalc


      SUBROUTINE FFUNP(N,NUMT,MMAXT,KDEG,COEF,CL,X,
     $ XX,TRM,DTRM,CLX,DXNP1,F,DF)
C
C FFUNP  EVALUATES THE SYSTEM "F(X)=0" AND ITS PARTIAL
C DERIVATIVES, USING THE "TABLEAU" INPUT: N,NUMT,KDEG,COEF.
C
C FFUNP  CAN BE MADE MORE EFFICIENT BY CUSTOMIZING IT TO
C PARTICULAR SYSTEM TYPES.  FOR EXAMPLE,
C IF X(1)**2 AND X(1)**3 ARE USED IN SEVERAL
C EQUATIONS, THE CURRENT  FFUNP  RECOMPUTES BOTH OF THESE FOR
C EACH EQUATION.  BUT (OF COURSE) WE CAN COMPUTE
C X1SQ=X(1)**2 AND X1CU=XSQ(1)*X(1), AND
C USE THESE IN EACH OF THE EQUATIONS.
C
C THE PART OF THE CODE BELOW LABELED "BLOCK A" CAN BE
C CUSTOMIZED IN THIS WAY.   (THE CODE OUTSIDE OF
C BLOCK A CONCERNS THE PROJECTIVE TRANSFORMATION AND NEED NOT
C BE CHANGED.)  HOWEVER, BLOCK A REQUIRES THE HOMOGENEOUS FORM
C OF THE POLYNOMIALS RATHER THAN THE STANDARD FORM.  FURTHER,
C THE PARTIAL DERIVATIVES WITH RESPECT TO ALL N+1 PROJECTIVE
C VARIABLES MUST BE COMPUTED.  MORE EXPLICITLY,
C THE ORIGINAL SYSTEM, F(X)=0, IS GIVEN IN "NON-HOMOGENEOUS FORM" AS
C DESCRIBED IN SUBROUTINE POLSYS.  F(X)  IS
C REPRESENTED IN "HOMOGENEOUS FORM" AS FOLLOWS:
C
C              NUMT(J)
C
C    F(J) =     SUM   TRM(J,K)
C
C               K=1
C
C WHERE  TRM(J,K)=COEF(J,K) * XX(J,1,K)*XX(J,2,K)* ... *XX(J,N+1,K)
C
C WITH XX(J,L,K) = X(L)**KDEG(J,L,K) FOR J=1 TO N, L=1 TO N, AND
C K=1 TO NUMT(J), AND WITH XX(J,N+1,K) = XNP1**KDEG(J,N+1,K) FOR J=1 TO
C N AND K=1 TO NUMT(J), WHERE  XNP1  IS THE "HOMOGENEOUS COORDINATE,"
C KDEG(J,N+1,K)=IDEG(J)-(KDEG(J,1,K)+ ... + KDEG(J,N,K)),
C AND IDEG(J) THE DEGREE OF THE J-TH EQUATION.   XNP1  IS GENERATED
C FROM  X  AND  CL  BEFORE BLOCK A.
C
C IN THIS DISCUSSION WE HAVE OMITTED, FOR SIMPLICITY OF
C EXPOSITION, THE LEADING INDEX, WHICH DIFFERENTIATES THE
C REAL AND IMAGINARY PARTS.  HOWEVER, THIS INDEX MUST NOT BE
C OMITTED IN THE CODE.
C
C WE COMPLETE THE EXPOSITION OF "REPLACING BLOCK A WITH MORE EFFICIENT
C CODE" WITH AN EXPLICIT EXAMPLE.  FIRST, THE SYSTEM IS DESCRIBED.
C THEN THE CODE THAT SHOULD BE USED IS GIVEN (COMMENTED OUT).
C IN TESTS  POLSYS  WITH THE MORE EFFICIENT  FFUNP  RAN ABOUT TWICE AS
C FAST AS WITH THE GENERIC  FFUNP .
C
C HERE IS THE SYSTEM TO BE SOLVED:
C
C     F(1) = COEF(1,1) * X(1)**4
C    &     + COEF(1,2) * X(1)**3 * X(2)
C    &     + COEF(1,3) * X(1)**3
C    &     + COEF(1,4) * X(1)
C    &     + COEF(1,5)
C     F(2) = COEF(2,1) * X(1)     * X(2)**2
C    &     + COEF(2,2)              X(2)**2
C    &     + COEF(2,3)
C
C THE REPLACEMENT CODE REQUIRES THE FOLLOWING DECLARATIONS:
C     DOUBLE PRECISION X1SQ,X1CU,X2SQ,X3SQ,X3CU,
C    &  TEMPA,TEMPB,TEMPC,TEMPD,TEMPE,TEMPF
C     DIMENSION X1SQ(2),X1CU(2),X2SQ(2),X3SQ(2),X3CU(2),
C    &  TEMPA(2),TEMPB(2),TEMPC(2),TEMPD(2),TEMPE(2),TEMPF(2)
C
C HERE IS CODE TO REPLACE BLOCK A:
C
C******************  BEGIN BLOCK A  *******************
C
C     CALL MULP(X(1,1),X(1,1),X1SQ)
C     CALL MULP(X1SQ  ,X(1,1),X1CU)
C     CALL MULP(X(1,2),X(1,2),X2SQ)
C     CALL MULP(XNP1,  XNP1,  X3SQ)
C     CALL MULP(X3SQ  ,XNP1,  X3CU)
C
C     DO 1 I=1,2
C       TEMPA(I)=   COEF(1,1) * X(I,1)
C    &            + COEF(1,2) * X(I,2)
C    &            + COEF(1,3) * XNP1(I)
C       TEMPB(I)=   COEF(1,4) * X(I,1)
C    &            + COEF(1,5) * XNP1(I)
C 1   CONTINUE
C
C     CALL MULP(X1SQ,  TEMPA,TEMPC)
C     CALL MULP(X(1,1),TEMPC,TEMPD)
C     CALL MULP(X3SQ,  TEMPB,TEMPE)
C     CALL MULP(XNP1,  TEMPE,TEMPF)
C
C     DO 2 I=1,2
C       F(I,1)=TEMPD(I) + TEMPF(I)
C       DF(I,1,1)= 3. *TEMPC(I) + COEF(1,1)*X1CU(I) + COEF(1,4)*X3CU(I)
C       DF(I,1,2)= COEF(1,2) * X1CU(I)
C       DF(I,1,3)= COEF(1,3)*X1CU(I) + 3. *TEMPE(I) + COEF(1,5)*X3CU(I)
C
C       TEMPA(I) = COEF(2,1) * X(I,1) + COEF(2,2) * XNP1(I)
C  2  CONTINUE
C
C     CALL MULP(TEMPA,X(1,2),TEMPB)
C     CALL MULP(TEMPB,X(1,2),TEMPC)
C
C     DO 3 I=1,2
C       F(I,2) = TEMPC(I) + COEF(2,3) * X3CU(I)
C       DF(I,2,1) = COEF(2,1) * X2SQ(I)
C       DF(I,2,2) = 2. * TEMPB(I)
C       DF(I,2,3) = COEF(2,2) * X2SQ(I) + COEF(2,3) * 3. * X3SQ(I)
C  3  CONTINUE
C******************  END OF BLOCK A  *******************
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
C
C NUMT(J)  IS THE NUMBER OF TERMS IN THE JTH EQUATION.
C
C MMAXT  IS AN UPPER BOUND ON NUMT(J) FOR J=1 TO N.
C
C KDEG(J,L,K)  IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH TERM
C   OF THE J-TH EQUATION.
C
C COEF(J,K)  IS THE K-TH COEFFICIENT OF THE J-TH EQUATION.
C
C CL  IS USED TO DEFINE THE PROJECTIVE TRANSFORMATION.  IF
C   THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED, THEN  CL
C   CONTAINS DUMMY VALUES.
C
C X(1,J), X(2,J)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF
C   THE J-TH INDEPENDENT VARIABLE.
C
C XX, TRM, DTRM, CLX, DXNP1  ARE WORKSPACE VARIABLES.
C
C ON OUTPUT:
C
C F(1,J), F(2,J)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF
C   THE J-TH EQUATION.
C
C DF(1,J,K), DF(2,J,K)  ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY
C   OF THE K-TH PARTIAL DERIVATIVE OF THE J-TH EQUATION.
C
C
C VARIABLES: XNP1,TEMP1,TEMP2.
C
C NOTE:  XNP1(1), XNP1(2)  ARE THE REAL AND IMAGINARY PARTS,
C   RESPECTIVELY, OF THE PROJECTIVE VARIABLE.  XNP1  IS UNITY
C   IF THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED.
C
C  SUBROUTINES: MULP,POWP,DIVP.
C
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,NUMT,MMAXT,KDEG
      DOUBLE PRECISION COEF,CL,X,XX,TRM,DTRM,CLX,DXNP1,F,DF
      DIMENSION NUMT(N),KDEG(N,N+1,MMAXT),
     $  COEF(N,MMAXT),CL(2,N+1),X(2,N),
     $  XX(2,N,N+1,MMAXT),TRM(2,N,MMAXT),DTRM(2,N,N+1,MMAXT),
     $  CLX(2,N),DXNP1(2,N),F(2,N),DF(2,N,N+1)
C
C DECLARATION OF VARIABLES:
      INTEGER I,IERR,J,K,L,M,NNNN,NP1
      DOUBLE PRECISION TEMP1,TEMP2,XNP1
      DIMENSION TEMP1(2),TEMP2(2),XNP1(2)
C
      NP1=N+1
C
C GENERATE XNP1, THE PROJECTIVE COORDINATE, AND ITS DERIVATIVES.
      DO 40 J=1,N
         CALL MULP(CL(1,J),X(1,J),CLX(1,J))
 40   CONTINUE
C
      DO 60 I=1,2
          XNP1(I)=CL(I,NP1)
          DO 50 J=1,N
              XNP1(I) = XNP1(I) + CLX(I,J)
              DXNP1(I,J)=CL(I,J)
 50       CONTINUE
 60   CONTINUE
C
C******************  BEGIN BLOCK A  *******************
C
C "BLOCK A" TAKES  X  AND  XNP1  AS INPUT AND RETURNS  F
C AND  DF  AS OUTPUT.   F  IS THE HOMOGENEOUS FORM OF THE
C ORIGINAL  F, AND  DF  CONSISTS OF THE PARTIAL
C DERIVATIVES OF THE HOMOGENEOUS FORM OF  F  WITH RESPECT
C TO THE N+1 VARIABLES X(1), ... ,X(N), XNP1.
C
C BEGIN "COMPUTE F"
C
      DO 100 J=1,N
        DO 100 K=1,NUMT(J)
          CALL POWP(KDEG(J,NP1,K),XNP1, XX(1,J,NP1,K))
          DO 100 L=1,N
            CALL POWP(KDEG(J, L,K),X(1,L),XX(1,J,  L,K))
 100  CONTINUE
      DO 200 J=1,N
        DO 200 K=1,NUMT(J)
          TRM(1,J,K)=COEF(J,K)
          TRM(2,J,K)=0.0
          DO 120 L=1,NP1
            CALL MULP(XX(1,J,L,K), TRM(1,J,K),TEMP1)
            TRM(1,J,K  )=TEMP1(1)
            TRM(2,J,K  )=TEMP1(2)
 120      CONTINUE
 200  CONTINUE
      DO 300 J=1,N
          F(1,J)=0.0
          F(2,J)=0.0
          DO 220 I=1,2
          DO 220 K=1,NUMT(J)
              F(I,J)= F(I,J) + TRM(I,J,K)
 220      CONTINUE
 300  CONTINUE
C
C END OF "COMPUTE F"
C
C BEGIN "COMPUTE DF"
C
      DO 400 J=1,N
        DO 400 K=1,NUMT(J)
        DO 400 M=1,NP1
C
C IF TERM DOES NOT INCLUDE X(M), SET PARTIAL DERIVATIVE OF TERM
C   EQUAL TO ZERO.
          IF(KDEG(J,M,K) .EQ. 0) THEN
            DTRM(1,J,M,K)=0.0
            DTRM(2,J,M,K)=0.0
          ELSE
C
C IF TERM DOES INCLUDE X(M), TRY COMPUTING THE PARTIAL BY DIVIDING
C   THE TERM BY X(M).
            IF(M.LE.N) CALL DIVP(TRM(1,J,K),X(1,M),DTRM(1,J,M,K),IERR)
            IF(M.EQ.NP1) CALL DIVP(TRM(1,J,K),XNP1,DTRM(1,J,M,K),IERR)
            IF (IERR .EQ. 0) THEN
              DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K)
              DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K)
            ELSE
C
C IF DIVISION WOULD CAUSE OVERFLOW, GENERATE THE PARTIAL BY
C   THE POLYNOMIAL FORMULA.
              DTRM(1,J,M,K)=COEF(J,K)
              DTRM(2,J,M,K)=0.0
              DO 320 L=1,NP1
                IF (L .EQ. M) GOTO 320
                CALL MULP(XX(1,J,L,K),DTRM(1,J,M,K),TEMP1)
                DTRM(1,J,M,K)=TEMP1(1)
                DTRM(2,J,M,K)=TEMP1(2)
 320          CONTINUE
              NNNN=KDEG(J,M,K)-1
              IF (M .LE. N) CALL POWP(NNNN,X(1,M),TEMP2)
              IF (M .EQ. NP1) CALL POWP(NNNN,XNP1 ,TEMP2)
              CALL MULP(TEMP2,TEMP1,DTRM(1,J,M,K))
              DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K)
              DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K)
            END IF
          END IF
 400  CONTINUE
      DO 600 J=1,N
      DO 600 M=1,NP1
          DF(1,J,M)=0.0
          DF(2,J,M)=0.0
          DO 420 I=1,2
            DO 420 K=1,NUMT(J)
              DF(I,J,M)= DF(I,J,M) + DTRM(I,J,M,K)
 420      CONTINUE
 600  CONTINUE
C
C END OF "COMPUTE DF"
C*******************  END BLOCK A  ********************
C
C CONVERT  DF  TO BE PARTIALS WITH RESPECT TO  X(1), ... ,X(N),
C BY APPLYING THE CHAIN RULE WITH  XNP1  CONSIDERED A FUNCTION OF
C OF  X(1), ... ,X(N).
C
      DO 700 J=1,N
        DO 700 K=1,N
          CALL MULP(DF(1,J,NP1),DXNP1(1,K),TEMP1)
          DO 700 I=1,2
            DF(I,J,K)=DF(I,J,K)+TEMP1(I)
 700  CONTINUE
      RETURN
      END


      subroutine specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!                .      .    .                                       .
! SUBPROGRAM:    specunpack
!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-19
!
! ABSTRACT: This subroutine unpacks a spectral data field that was packed
!   using the complex packing algorithm for spherical harmonic data as
!   defined in the GRIB2 documention,
!   using info from the GRIB2 Data Representation Template 5.51.
!
! PROGRAM HISTORY LOG:
! 2002-12-19  Gilbert
!
! USAGE:    CALL specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld)
!   INPUT ARGUMENT LIST:
!     cpack    - The packed data field (character*1 array)
!     len      - length of packed field cpack().
!     idrstmpl - Contains the array of values for Data Representation
!                Template 5.51
!     ndpts    - The number of data values to unpack
!     JJ       - J - pentagonal resolution parameter
!     KK       - K - pentagonal resolution parameter
!     MM       - M - pentagonal resolution parameter
!
!   OUTPUT ARGUMENT LIST:
!     fld()    - Contains the unpacked data values
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: XL Fortran 90
!   MACHINE:  IBM SP
!
!$$$

      character(len=1),intent(in) :: cpack(len)
      integer,intent(in) :: ndpts,len,JJ,KK,MM
      integer,intent(in) :: idrstmpl(*)
      real,intent(out) :: fld(ndpts)

      integer :: ifld(ndpts),Ts
      integer(4) :: ieee
      real :: ref,bscale,dscale,unpk(ndpts)
      real,allocatable :: pscale(:)

      ieee = idrstmpl(1)
      call rdieee(ieee,ref,1)
      bscale = 2.0**real(idrstmpl(2))
      dscale = 10.0**real(-idrstmpl(3))
      nbits = idrstmpl(4)
      Js=idrstmpl(6)
      Ks=idrstmpl(7)
      Ms=idrstmpl(8)
      Ts=idrstmpl(9)

      if (idrstmpl(10).eq.1) then           ! unpacked floats are 32-bit IEEE
         !call gbytes(cpack,ifld,0,32,0,Ts)
         call rdieee(cpack,unpk,Ts)          ! read IEEE unpacked floats
         iofst=32*Ts
         call gbytes(cpack,ifld,iofst,nbits,0,ndpts-Ts)  ! unpack scaled data
!
!   Calculate Laplacian scaling factors for each possible wave number.
!
         allocate(pscale(JJ+MM))
         tscale=real(idrstmpl(5))*1E-6
         do n=Js,JJ+MM
            pscale(n)=real(n*(n+1))**(-tscale)
         enddo
!
!   Assemble spectral coeffs back to original order.
!
         inc=1
         incu=1
         incp=1
         do m=0,MM
            Nm=JJ      ! triangular or trapezoidal
            if ( KK .eq. JJ+MM ) Nm=JJ+m          ! rhombodial
            Ns=Js      ! triangular or trapezoidal
            if ( Ks .eq. Js+Ms ) Ns=Js+m          ! rhombodial
            do n=m,Nm
               if (n.le.Ns .AND. m.le.Ms) then    ! grab unpacked value
                  fld(inc)=unpk(incu)         ! real part
                  fld(inc+1)=unpk(incu+1)     ! imaginary part
                  inc=inc+2
                  incu=incu+2
               else                         ! Calc coeff from packed value
                  fld(inc)=((real(ifld(incp))*bscale)+ref)*
     &                      dscale*pscale(n)           ! real part
                  fld(inc+1)=((real(ifld(incp+1))*bscale)+ref)*
     &                      dscale*pscale(n)           ! imaginary part
                  inc=inc+2
                  incp=incp+2
               endif
            enddo
         enddo

         deallocate(pscale)

      else
         print *,'specunpack: Cannot handle 64 or 128-bit floats.'
         fld=0.0
         return
      endif

      return
      end


c***********************************************************************
      subroutine qss3dRK1Step(
     &  u_next,
     &  ilo_u_next_gb, ihi_u_next_gb,
     &  jlo_u_next_gb, jhi_u_next_gb,
     &  klo_u_next_gb, khi_u_next_gb,
     &  u_cur,
     &  ilo_u_cur_gb, ihi_u_cur_gb,
     &  jlo_u_cur_gb, jhi_u_cur_gb,
     &  klo_u_cur_gb, khi_u_cur_gb,
     &  rhs,
     &  ilo_rhs_gb, ihi_rhs_gb,
     &  jlo_rhs_gb, jhi_rhs_gb,
     &  klo_rhs_gb, khi_rhs_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dt)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_u_next_gb, ihi_u_next_gb
      integer jlo_u_next_gb, jhi_u_next_gb
      integer klo_u_next_gb, khi_u_next_gb
      integer ilo_u_cur_gb, ihi_u_cur_gb
      integer jlo_u_cur_gb, jhi_u_cur_gb
      integer klo_u_cur_gb, khi_u_cur_gb
      integer ilo_rhs_gb, ihi_rhs_gb
      integer jlo_rhs_gb, jhi_rhs_gb
      integer klo_rhs_gb, khi_rhs_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real u_next(ilo_u_next_gb:ihi_u_next_gb,
     &                        jlo_u_next_gb:jhi_u_next_gb,
     &                        klo_u_next_gb:khi_u_next_gb)
      real u_cur(ilo_u_cur_gb:ihi_u_cur_gb,
     &                       jlo_u_cur_gb:jhi_u_cur_gb,
     &                       klo_u_cur_gb:khi_u_cur_gb)
      real rhs(ilo_rhs_gb:ihi_rhs_gb,
     &                     jlo_rhs_gb:jhi_rhs_gb,
     &                     klo_rhs_gb:khi_rhs_gb)
      integer i, j, k
      real dt

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

            u_next(i,j,k) = u_cur(i,j,k) + dt*rhs(i,j,k)

          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************


*> \brief \b SSFRK performs a symmetric rank-k operation for matrix in RFP format.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSFRK + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
*                         C )
*
*       .. Scalar Arguments ..
*       REAL               ALPHA, BETA
*       INTEGER            K, LDA, N
*       CHARACTER          TRANS, TRANSR, UPLO
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), C( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Level 3 BLAS like routine for C in RFP Format.
*>
*> SSFRK performs one of the symmetric rank--k operations
*>
*>    C := alpha*A*A**T + beta*C,
*>
*> or
*>
*>    C := alpha*A**T*A + beta*C,
*>
*> where alpha and beta are real scalars, C is an n--by--n symmetric
*> matrix and A is an n--by--k matrix in the first case and a k--by--n
*> matrix in the second case.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER*1
*>          = 'N':  The Normal Form of RFP A is stored;
*>          = 'T':  The Transpose Form of RFP A is stored.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>           On  entry, UPLO specifies whether the upper or lower
*>           triangular part of the array C is to be referenced as
*>           follows:
*>
*>              UPLO = 'U' or 'u'   Only the upper triangular part of C
*>                                  is to be referenced.
*>
*>              UPLO = 'L' or 'l'   Only the lower triangular part of C
*>                                  is to be referenced.
*>
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>           On entry, TRANS specifies the operation to be performed as
*>           follows:
*>
*>              TRANS = 'N' or 'n'   C := alpha*A*A**T + beta*C.
*>
*>              TRANS = 'T' or 't'   C := alpha*A**T*A + beta*C.
*>
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry, N specifies the order of the matrix C. N must be
*>           at least zero.
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>           On entry with TRANS = 'N' or 'n', K specifies the number
*>           of  columns of the matrix A, and on entry with TRANS = 'T'
*>           or 't', K specifies the number of rows of the matrix A. K
*>           must be at least zero.
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*>           On entry, ALPHA specifies the scalar alpha.
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array of DIMENSION (LDA,ka)
*>           where KA
*>           is K  when TRANS = 'N' or 'n', and is N otherwise. Before
*>           entry with TRANS = 'N' or 'n', the leading N--by--K part of
*>           the array A must contain the matrix A, otherwise the leading
*>           K--by--N part of the array A must contain the matrix A.
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           On entry, LDA specifies the first dimension of A as declared
*>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
*>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
*>           be at least  max( 1, k ).
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is REAL
*>           On entry, BETA specifies the scalar beta.
*>           Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is REAL array, dimension (NT)
*>           NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP
*>           Format. RFP Format is described by TRANSR, UPLO and N.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realOTHERcomputational
*
*  =====================================================================
      SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
     $                  C )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      REAL               ALPHA, BETA
      INTEGER            K, LDA, N
      CHARACTER          TRANS, TRANSR, UPLO
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), C( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, NORMALTRANSR, NISODD, NOTRANS
      INTEGER            INFO, NROWA, J, NK, N1, N2
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SSYRK, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NORMALTRANSR = LSAME( TRANSR, 'N' )
      LOWER = LSAME( UPLO, 'L' )
      NOTRANS = LSAME( TRANS, 'N' )
*
      IF( NOTRANS ) THEN
         NROWA = N
      ELSE
         NROWA = K
      END IF
*
      IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSFRK ', -INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
*     The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
*     done (it is in SSYRK for example) and left in the general case.
*
      IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND.
     $    ( BETA.EQ.ONE ) ) )RETURN
*
      IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN
         DO J = 1, ( ( N*( N+1 ) ) / 2 )
            C( J ) = ZERO
         END DO
         RETURN
      END IF
*
*     C is N-by-N.
*     If N is odd, set NISODD = .TRUE., and N1 and N2.
*     If N is even, NISODD = .FALSE., and NK.
*
      IF( MOD( N, 2 ).EQ.0 ) THEN
         NISODD = .FALSE.
         NK = N / 2
      ELSE
         NISODD = .TRUE.
         IF( LOWER ) THEN
            N2 = N / 2
            N1 = N - N2
         ELSE
            N1 = N / 2
            N2 = N - N1
         END IF
      END IF
*
      IF( NISODD ) THEN
*
*        N is odd
*
         IF( NORMALTRANSR ) THEN
*
*           N is odd and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*              N is odd, TRANSR = 'N', and UPLO = 'L'
*
               IF( NOTRANS ) THEN
*
*                 N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
*
                  CALL SSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 1 ), N )
                  CALL SSYRK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
     $                        BETA, C( N+1 ), N )
                  CALL SGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N )
*
               ELSE
*
*                 N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
*
                  CALL SSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 1 ), N )
                  CALL SSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA,
     $                        BETA, C( N+1 ), N )
                  CALL SGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N )
*
               END IF
*
            ELSE
*
*              N is odd, TRANSR = 'N', and UPLO = 'U'
*
               IF( NOTRANS ) THEN
*
*                 N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
*
                  CALL SSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( N2+1 ), N )
                  CALL SSYRK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA,
     $                        BETA, C( N1+1 ), N )
                  CALL SGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( N2, 1 ), LDA, BETA, C( 1 ), N )
*
               ELSE
*
*                 N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
*
                  CALL SSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( N2+1 ), N )
                  CALL SSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N2 ), LDA,
     $                        BETA, C( N1+1 ), N )
                  CALL SGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( 1, N2 ), LDA, BETA, C( 1 ), N )
*
               END IF
*
            END IF
*
         ELSE
*
*           N is odd, and TRANSR = 'T'
*
            IF( LOWER ) THEN
*
*              N is odd, TRANSR = 'T', and UPLO = 'L'
*
               IF( NOTRANS ) THEN
*
*                 N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
*
                  CALL SSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 1 ), N1 )
                  CALL SSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
     $                        BETA, C( 2 ), N1 )
                  CALL SGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( N1+1, 1 ), LDA, BETA,
     $                        C( N1*N1+1 ), N1 )
*
               ELSE
*
*                 N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
*
                  CALL SSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 1 ), N1 )
                  CALL SSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA,
     $                        BETA, C( 2 ), N1 )
                  CALL SGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( 1, N1+1 ), LDA, BETA,
     $                        C( N1*N1+1 ), N1 )
*
               END IF
*
            ELSE
*
*              N is odd, TRANSR = 'T', and UPLO = 'U'
*
               IF( NOTRANS ) THEN
*
*                 N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
*
                  CALL SSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( N2*N2+1 ), N2 )
                  CALL SSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
     $                        BETA, C( N1*N2+1 ), N2 )
                  CALL SGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 )
*
               ELSE
*
*                 N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
*
                  CALL SSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( N2*N2+1 ), N2 )
                  CALL SSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA,
     $                        BETA, C( N1*N2+1 ), N2 )
                  CALL SGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 )
*
               END IF
*
            END IF
*
         END IF
*
      ELSE
*
*        N is even
*
         IF( NORMALTRANSR ) THEN
*
*           N is even and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*              N is even, TRANSR = 'N', and UPLO = 'L'
*
               IF( NOTRANS ) THEN
*
*                 N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
*
                  CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 2 ), N+1 )
                  CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
     $                        BETA, C( 1 ), N+1 )
                  CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ),
     $                        N+1 )
*
               ELSE
*
*                 N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
*
                  CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( 2 ), N+1 )
                  CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA,
     $                        BETA, C( 1 ), N+1 )
                  CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ),
     $                        N+1 )
*
               END IF
*
            ELSE
*
*              N is even, TRANSR = 'N', and UPLO = 'U'
*
               IF( NOTRANS ) THEN
*
*                 N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
*
                  CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK+2 ), N+1 )
                  CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
     $                        BETA, C( NK+1 ), N+1 )
                  CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( NK+1, 1 ), LDA, BETA, C( 1 ),
     $                        N+1 )
*
               ELSE
*
*                 N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
*
                  CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK+2 ), N+1 )
                  CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA,
     $                        BETA, C( NK+1 ), N+1 )
                  CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( 1, NK+1 ), LDA, BETA, C( 1 ),
     $                        N+1 )
*
               END IF
*
            END IF
*
         ELSE
*
*           N is even, and TRANSR = 'T'
*
            IF( LOWER ) THEN
*
*              N is even, TRANSR = 'T', and UPLO = 'L'
*
               IF( NOTRANS ) THEN
*
*                 N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
*
                  CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK+1 ), NK )
                  CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
     $                        BETA, C( 1 ), NK )
                  CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( NK+1, 1 ), LDA, BETA,
     $                        C( ( ( NK+1 )*NK )+1 ), NK )
*
               ELSE
*
*                 N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
*
                  CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK+1 ), NK )
                  CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA,
     $                        BETA, C( 1 ), NK )
                  CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ),
     $                        LDA, A( 1, NK+1 ), LDA, BETA,
     $                        C( ( ( NK+1 )*NK )+1 ), NK )
*
               END IF
*
            ELSE
*
*              N is even, TRANSR = 'T', and UPLO = 'U'
*
               IF( NOTRANS ) THEN
*
*                 N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
*
                  CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK*( NK+1 )+1 ), NK )
                  CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
     $                        BETA, C( NK*NK+1 ), NK )
                  CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK )
*
               ELSE
*
*                 N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
*
                  CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA,
     $                        BETA, C( NK*( NK+1 )+1 ), NK )
                  CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA,
     $                        BETA, C( NK*NK+1 ), NK )
                  CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ),
     $                        LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK )
*
               END IF
*
            END IF
*
         END IF
*
      END IF
*
      RETURN
*
*     End of SSFRK
*
      END


	SUBROUTINE RS_HHDE  ( temp, digits, nout, iret )
C************************************************************************
C* RS_HHDE								*
C*									*
C* This subroutine decodes the one or two digit cloud height code and	*
C* returns the cloud height in meters.					*
C*									*
C* RS_HHDE ( TEMP, DIGITS, NOUT, IRET )					*
C*									*
C* Input parameters:							*
C*	TEMP		INTEGER		Undecoded digits		*
C*	DIGITS		INTEGER		Number of digits		*
C*									*
C* Output parameters:							*
C*	NOUT		INTEGER		Decoded cloud height		*
C*	IRET		INTEGER		Return code			*
C*					  0 = Normal return		*
C*					 -1 = Too many digits		*
C**									*
C* Log:									*
C* J. Nielsen/MIT	 4/89						*
C* J. Nielsen/TAMU	 2/92	Gempacized				*
C* S. Jacobs/NCEP	 2/01	Fixed typo code -> temp			*
C************************************************************************
	INTEGER		temp, digits
C
	INTEGER		nout, iret
C------------------------------------------------------------------------
	iret = 0
	IF  ( ( digits .ne. 1 ) .and. ( digits .ne. 2 ) )  THEN
	    iret = -1
	    RETURN
	ENDIF
C
C*	Decode two digits
C
	IF  ( digits .eq. 2 )  THEN
	    IF  ( temp .le. 50 )  THEN
		nout = 30 * temp
		RETURN
	    ELSE IF  ( temp .le. 80 )  THEN
		nout = ( temp - 50 ) * 300
		RETURN
	    ELSE IF  ( temp .le. 90 )  THEN
		nout = ( temp - 74 ) * 1500
		RETURN
	    ELSE
C
C*		Convert to one-digit code
C
		temp = temp - 90
	    ENDIF
	ENDIF
C
C*	Decode one digit
C
	If  ( temp .eq. 0 )  nout = 0
	IF  ( temp .eq. 1 )  nout = 50
	IF  ( temp .eq. 2 )  nout = 100
	IF  ( temp .eq. 3 )  nout = 200
	IF  ( temp .eq. 4 )  nout = 300
	IF  ( temp .eq. 5 )  nout = 600
	IF  ( temp .eq. 6 )  nout = 1000
	IF  ( temp .eq. 7 )  nout = 1500
	IF  ( temp .eq. 8 )  nout = 2000
C
C*	The final possibility includes cloud height of > 2500 m,
C*	or no clouds at all
C
	IF  ( temp .eq. 9 )  nout = 2500
	RETURN
	END


SUBROUTINE PARTITION_K(EXTICK,LAI,MAXLAI,FCLIMAT,FWATER,FNITRO,fswtd,ISTRESS,FSH,FRT,FLV,FST,FSO)
!-------------------------------------------------------------------------------
!THIS SUBROUTINE IS DEVELOPED ACCORDING TO DR. TAO LI'S EARLY WORK IN K-MODEL
!IT RESPONSE TO CLIMATIC INFLUENCE, LIGHT COMPETITION, WATER AND
!NITROGEN STRESS
!DATE: APRIL 29, 2010, BY DR. TAO LI
!THE FSH+FRT = 1.0 AND FST+FLV+FGR = FSH
!-------------------------------------------------------------------------------
!VARIABLE		TYPE			MEANINGS																					UNIT
!EXTICK			REAL			CANOPY LIGHT EXTINCTION COEFFICIENT								-
!LAI				REAL			LEAF AREA INDEX																		-
!MAXLAI     REAL      MAXIMUM LEAF AREA FOR SHADING TOLERANCE           -
!FCLIMAT		REAL			THE INFLUNCE DEGREE OF CLIMATE CONDITION (0 TO 1) -
!FWATER			REAL			WATER STRESS (0 TO 1)															-
!FNITRO			REAL      NITROGEN STRESS (0 TO 1)
!fswtd		REAL		the maximum osmatic potential of plant													-
!FSH				REAL 			FRACTION OF CARBON TO STEM(0 TO 1)								-
!FRT				REAL      FRACTION OF CARBON TO ROOT (0 TO 1)               -
!FLV				REAL      FRACTION OF CARBON TO LEAF (0 TO 1)               -
!FST				REAL      FRACTION OF CARBON TO STEM (0 TO 1)               -
!FSO				REAL      FRACTION OF CARBON TO GRAIN (0 TO 1)              -
!FLIGHT     REAL      THE COMPETITION FACTOR TO LIGHT										-
!ISTRESS    INTEGER   THE DETERMINER FOR WHETHER THE STRESS WILL AFFCT ALLOCATION OF
!                       CARBON AMONG ABOVE GROUND ORGANS, 1=YES,0=NO
!--------------------------------------------------------------------------------
implicit none
REAL EXTICK,LAI,MAXLAI,FCLIMAT,FWATER,FNITRO,FSWTD,FSH,FRT,FLV,FST,FSO, FLIGHT
INTEGER ISTRESS
REAL TMPV1, tmpS, tmpL
SAVE
		FLIGHT =MIN(1.0, EXP(EXTICK*(MAXLAI-LAI)))
		FNITRO = min(1.0,fnitro)							!AT THIS STAGE, THE NITROGEN STRESS WAS NOT INVOLVED YET
		fwater=min(1.0,fwater)
	 IF(FCLIMAT.LE.0.0) FCLIMAT = 1.0
	 IF(((FLV+FST+FSO).LT.0.99).OR.((FLV+FST+FSO).GT.1.01)) THEN
	  	 CALL FATALERR ('PARTITION','THE SUM OF FRACTIONS AT ABOVE GROUND ORGANS IS NOT 1.0!')
	 ENDIF
	 	!IF EITHER LIGHT COMPETITION, OR WATER STRESS OR NITROGEN STRESS EXISTED, THE MORE
	 	!CARBON WILL BE ASIGNED TO ROOT
	 	tmps=1.0-(1.0-min(fnitro, fwater))**(FSWTD*1.5)   !4.0
	 	tmpl=1.0-(1.0-flight)**4.0
   	FSH = FSH /(1.0+FCLIMAT*(1.0-tmps))
   	FRT = 1.0 - FSH
   IF(((FSH+FRT).GT.1.01).OR.((FSH+FRT).LT.0.99)) THEN
	 	 CALL FATALERR ('PATITION','THE SUM OF FRACTIONS TO ROOT ANS SHOOT IS NOT 1.0!')
	 ENDIF
   	!THE DISTRIBUTION OF CARBON AMONG ABOVE GROUND ORGANS
   TMPV1 = FST + FSO
   IF(TMPV1.LE.0.0) THEN
   	 CALL FATALERR ('PATITION','THE SUM OF FRACTIONS TO STEM AND GRAIN IS 0.0!')
   ENDIF
   IF(ISTRESS.EQ.1) THEN
   	!OPTION ONE: SUPPOSED THE EITHER THE STRESS OF WATER OR NITROGEN WILL REDUCE THE CARBON TO GRAIN AND SHIFT TO STEM
   	FST = (FST + FST/TMPV1*FCLIMAT*(1.0-tmpl)+FCLIMAT*(1.0-tmps))/ &
   				(1.0+FCLIMAT*(2.0-tmpl-tmps))
   	FLV = FLV/(1.0+FCLIMAT*(2.0-tmpl-tmps))
   	FSO = (FSO+FSO/TMPV1*FCLIMAT*(1.0-tmpl))/(1.0+FCLIMAT*(2.0-tmpl-tmps))
   ELSE
   	!OPTION TWO: SUPPOSED THE WATER OR NITROGEN STRESS DOES NOT CHANGE THE DISTRIBUTION IN ABOVE ORGANS
   	FST=(FST+FST/TMPV1*FCLIMAT*(1.0-tmpl))/(1.0+FCLIMAT*(1.0-tmpl))
   	FLV = FLV/(1.0+FCLIMAT*(1.0-tmpl))
   	FSO = (FSO+FSO/TMPV1*FCLIMAT*(1.0-tmpl))/(1.0+FCLIMAT*(1.0-tmpl))
   ENDIF

END SUBROUTINE