!***************************************************************************************************************************
! This module is intended to calculate environmental factors
! 15SEP2017 added function TFAC5 to estimate cardinal temperatures with a plateau by @lpmorenoc
! Atributes:
!   - tMin minimmun temprature of the day
!   - tMax maximun temprature of the day
!   - dewPointTemp dew point temperature of the day
!   - dayRadiation registered during the day
! Type functions:
!        hourlyTemperature
!        hourlySVP
!        hourlyWHCAIR
!        hourlyRH
!        hourlyVPD
!        hourlyRadiation
!        hourlyBiomass
!        hourlyTranspiration
! Static functions:
!        calculateSVP
!        calculateWHCAIR
!        calculateRH
!        calculateVPD
!        calculatePortionOfRadiation
!        calculatateHourlyRadiation
!        calculateBiomass
!        calculateTranspiration
!        calculateTemperatureFactor
! Authors
! @danipilze
!*********

    Module YCA_Control_Environment         !Module of environment

    ! STATIC ATRIBUTES
    real, private :: PI =  4 * atan (1.0_8)
    real, private :: HOURS_OF_DAY = 24
    real, private :: LIGHT_HOURS = 12
    real, private :: DAWN_TIME = 5                                              !dawn time

    type DailyEnvironment_type

        ! OBJECT ATRIBUTES

        real, private :: tMin_ = 0
        real, private :: tMax_ = 0
        real, private :: dewPointTemp_ = 0
        real, private :: dayRadiation_ = 0                                      ! solar radiation

    contains

        ! type functions
        procedure, pass (this) :: hourlyTemperature
        procedure, pass (this) :: hourlySVP
        procedure, pass (this) :: hourlyWHCAIR
        procedure, pass (this) :: hourlyRH
        procedure, pass (this) :: hourlyVPD
        procedure, pass (this) :: hourlyRadiation
        procedure, pass (this) :: hourlyBiomass
        procedure, pass (this) :: hourlyTranspiration

        ! getters and setters
        procedure, pass (this) :: getTMin
        procedure, pass (this) :: setTMin
        procedure, pass (this) :: getTMax
        procedure, pass (this) :: setTMax
        procedure, pass (this) :: getDewPointTemp
        procedure, pass (this) :: setDewPointTemp
        procedure, pass (this) :: getDayRadiation
        procedure, pass (this) :: setDayRadiation

    end Type DailyEnvironment_type

    ! interface to reference the constructor
    interface DailyEnvironment_type
        module procedure DailyEnvironment_type_constructor
    end interface DailyEnvironment_type

    contains

    ! constructor for the type
    ! tMin          mandatory
    ! tMax          mandatory
    ! dewPointTemp
    ! dayRadiation
    type (DailyEnvironment_type) function DailyEnvironment_type_constructor(tMin, tMax, dewPointTemp, dayRadiation)
        implicit none
        real, intent (in) :: tMin, tMax, dewPointTemp,dayRadiation
        DailyEnvironment_type_constructor%TMin_ = tMin
        DailyEnvironment_type_constructor%TMax_ = tMax
        DailyEnvironment_type_constructor%dewPointTemp_ = dewPointTemp
        DailyEnvironment_type_constructor%dayRadiation_ = dayRadiation
    end function DailyEnvironment_type_constructor

    !-------------------------------------------
    ! TYPE FUNCTIONS
    !-------------------------------------------

    ! obtain the temperature for any given hour of the day
    ! T(Hour) = Amplitude*sin[w(t - a)] + C.
    ! Amplitude is called the amplitude the height of each peak above the baseline
    ! Hod is Hours Of Day, the period or wavelength (the length of each cycle)
    ! a  is the phase shift (the horizontal offset of the basepoint; where the curve crosses the baseline as it ascends)
    ! C is average temperature,  the vertical offset (height of the baseline)
    ! w is the angular frequency, given by w = 2PI/hod
    real function hourlyTemperature(this, hour)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour
        real :: Amplitude, C, w, g

        w = (2*PI)/HOURS_OF_DAY
        Amplitude = ((this%TMax_ - this%TMin_)/2)                                               ! half distance between temperatures
        C = (this%TMin_ + this%TMax_)/2                                                         ! mean temperature
        g = w*(hour - 8)

        hourlyTemperature = Amplitude*SIN(g)+C                                                  ! calculate temperature acording to the current time

    end function hourlyTemperature

    !obtain the Saturation Vapour Pressure for any given hour                                   ! (pascals)
    real function hourlySVP(this, Hour)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour

        hourlySVP = calculateSVP(hourlyTemperature(this, Hour))

    end function hourlySVP

    ! obtain the water holding capacity of the air for any given hour
    real function hourlyWHCAIR(this, hour) ! (kg/m3)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour

        hourlyWHCAIR = calculateWHCAIR(hourlyTemperature(this, Hour))

    end function hourlyWHCAIR

    ! obtain the relative humidity for any given hour
    real function hourlyRH(this, hour)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour

        hourlyRH =  calculateRH(hourlyTemperature(this, Hour), this%dewPointTemp_)

    end function hourlyRH

    ! obtain the Vapor Preasure Deficit VPD for any given hour
    real function hourlyVPD(this, hour)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour

        hourlyVPD =  calculateVPD(hourlyTemperature(this, Hour), this%dewPointTemp_)

    end function hourlyVPD

    ! obtain the radiation VPD for any given hour
    real function hourlyRadiation(this, hour)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour

        hourlyRadiation = calculatateHourlyRadiation(hour, DAWN_TIME, this%dayRadiation_ , LIGHT_HOURS)

    end function hourlyRadiation

    ! obtain the biomass produced at a given hour
    real function hourlyBiomass(this, hour, extinctionCoefficient,LAI, radiationUseEfficiency,stomatalConductance)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour
        real, intent (in) :: extinctionCoefficient, LAI,radiationUseEfficiency,stomatalConductance

        hourlyBiomass = calculateBiomass(calculatateHourlyRadiation(hour, DAWN_TIME, this%dayRadiation_ , LIGHT_HOURS) , extinctionCoefficient , LAI, radiationUseEfficiency, stomatalConductance )

    end function hourlyBiomass

    ! obtain the transpiration
    real function hourlyTranspiration(this, hour, stomatalConductance)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this
        integer, intent (in) :: hour
        real, intent (in) :: stomatalConductance

        hourlyTranspiration = calculateTranspiration(hourlyVPD(this, hour), stomatalConductance)

    end function hourlyTranspiration

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

    ! obtain the Saturation Vapour Pressure  for any given temperature                          ! (pascals)
    real function calculateSVP(temperature)
        implicit none
        real, intent (in) :: temperature

        !Saturation vapour pressure in pascals: svp = 610.78 *exp( t / ( t + 238.3 ) *17.2694 )
        calculateSVP = 610.78 * exp( temperature/ ( temperature  + 238.3 ) * 17.2694 )

    end function calculateSVP

    ! obtain the water holding capacity of the air for any given temperature                    ! (kg/m3)
    real function calculateWHCAIR(temperature)
        implicit none
        real, intent (in) :: temperature

        ! WHCAIR = 0.002166 *SVP / ( t + 273.16 )
        calculateWHCAIR = 0.002166 * calculateSVP(temperature) / ( temperature  + 273.16 )

    end function calculateWHCAIR

    ! obtain the relative humidity                                                              ! %
    real function calculateRH(temperature, dewPointTemp)
        implicit none
        real, intent (in) :: temperature, dewPointTemp

        !(RHt) = WHCAIRdp/WHCAIRt
        calculateRH =  calculateWHCAIR(dewPointTemp)/calculateWHCAIR(temperature)

    end function calculateRH

    ! obtain the Vapor Preasure Deficit VPD                                                     ! (KPa)
    real function calculateVPD(temperature, dewPointTemp)
        implicit none
        real, intent (in) :: temperature, dewPointTemp

        ! VPD = (1 - (RH/100)) * SVP
        calculateVPD =  ((1 - (calculateRH(temperature, dewPointTemp)/100)) * calculateSVP(temperature))/1000

    end function calculateVPD

    ! calculates proportion of radiation
    ! K is the extinction coefficient
    ! LAI is leaf area index
    real function calculatePortionOfRadiation(K, LAI)                                           ! fraction
        implicit none
        real, intent (in) :: K, LAI
        real :: value = 0

        calculatePortionOfRadiation = 1.0 - exp(-K*LAI)

    end function calculatePortionOfRadiation

    ! obtain the radiation at a given hour
    real function calculatateHourlyRadiation(hour, dawnTime, dayRadiation, lightHours)          !MJ/m2
        implicit none
        integer, intent (in) :: hour
        real :: Amplitude, C, w, g, value, dawnTime, dayRadiation, lightHours

        w = (2*PI)/24
        C = 0
        Amplitude = (dayRadiation * PI)/24
        g = w*(hour - dawnTime)

        value = Amplitude*SIN(g)+C           ! calculate hourly radiation
        if(value < 0.0 ) value = 0           ! no radiation on non-light hours

        calculatateHourlyRadiation=value

    end function calculatateHourlyRadiation

    ! obtain the biomass produced accoording to the radiation at a given moment             ! MJ/m2 * # * # * g/MJ * fraction = g/m2
    real function calculateBiomass(radiation, extinctionCoefficient , LAI, radiationUseEfficiency, stomatalConductance)
        implicit none
        real, intent (in) :: radiation, extinctionCoefficient, LAI, radiationUseEfficiency, stomatalConductance
        real :: value = 0

        calculateBiomass = calculatePortionOfRadiation(extinctionCoefficient, LAI) * radiation * radiationUseEfficiency  * stomatalConductance

    end function calculateBiomass

    ! obtain the transpiration
    real function calculateTranspiration(VPD, stomatalConductance)
        implicit none
        real, intent (in) :: stomatalConductance, VPD

        calculateTranspiration = stomatalConductance * VPD

    end function calculateTranspiration

    ! Estimate thermal time with a plateau after second cardinal temperature                        ! by @lpmorenoc
    ! Calculate temp factor and thermal units from cardinal temps                                   ! 0EQN 58
    ! ARGUMENTS
    ! tcard,temp,tunit
    ! MODIFES
    ! tunit
    ! RETURNS
    ! tfac5
    real function calculateTemperatureFactor(tcard,temp,tunit)

      implicit none
      real, intent (in) ::      tcard(4),temp
      real                      tfac5
      real                      tunit

      IF (temp <= tcard(1)) THEN
        tfac5 = 0.0
      ELSEIF (temp > tcard(1) .AND. temp <= tcard(2)) THEN
        tfac5 = (temp-tcard(1))/(tcard(2)-tcard(1))
      ELSEIF (temp > tcard(2) .AND. temp <= tcard(3)) THEN
        tfac5 = 1.0
      ELSEIF (temp > tcard(3) .AND. temp <= tcard(4) .AND. tcard(3) < tcard(4)) THEN
        tfac5 = 1.0 - ((temp-tcard(3))/(tcard(4)-tcard(3)))
      ELSEIF (temp > tcard(4) .AND. tcard(3) < tcard(4)) THEN
        tfac5 = 0.0
      ELSEIF (temp > tcard(3)) THEN
        tfac5 = 1.0
      ENDIF

      calculateTemperatureFactor = AMAX1(0.0,AMIN1(1.0,tfac5))
      tunit = tfac5 * (tcard(2)-tcard(1))

      end function calculateTemperatureFactor
    !-------------------------------------------
    ! GETTERS AND SETTERS
    !------------------------------------------

    ! get TMin
    real function getTMin(this)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this

        getTMin = this%tMin_
    end function getTMin

    ! set TMin
    subroutine setTMin(this, tMin)
        implicit none
        class (DailyEnvironment_type), intent(inout) :: this
        real, intent (in) :: tMin

        this%tMin_ = tMin
    end subroutine setTMin

    ! get tMax
    real function getTMax(this)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this

        getTMax = this%tMax_
    end function getTMax

    ! set tMax
    subroutine setTMax(this, tMax)
        implicit none
        class (DailyEnvironment_type), intent(inout) :: this
        real, intent (in) :: tMax

        this%tMax_ = tMax
    end subroutine setTMax

    ! get dewPointTemp
    real function getDewPointTemp(this)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this

        getDewPointTemp = this%dewPointTemp_
    end function getDewPointTemp

    ! set dewPointTemp
    subroutine setDewPointTemp(this, dewPointTemp)
        implicit none
        class (DailyEnvironment_type), intent(inout) :: this
        real, intent (in) :: dewPointTemp

        this%dewPointTemp_ = dewPointTemp
    end subroutine setDewPointTemp

    ! get day radiation
    real function getDayRadiation(this)
        implicit none
        class (DailyEnvironment_type), intent(in) :: this

        getDayRadiation = this%dayRadiation_
    end function getDayRadiation

    ! set day radiation
    subroutine setDayRadiation(this, dayRadiation)
        implicit none
        class (DailyEnvironment_type), intent(inout) :: this
        real, intent (in) :: dayRadiation

        this%dayRadiation_ = dayRadiation
    end subroutine setDayRadiation

END Module YCA_Control_Environment


      SUBROUTINE W3FC07(FFID, FFJD, FGU, FGV, FU, FV)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:  W3FC07        GRID U-V TO EARTH U-V IN NORTH HEM.
C   PRGMMR: CHASE            ORG: NMC421      DATE:88-10-26
C
C ABSTRACT: GIVEN THE GRID-ORIENTED WIND COMPONENTS ON A NORTHERN
C   HEMISPHERE POLAR STEREOGRAPHIC GRID POINT, COMPUTE THE EARTH-
C   ORIENTED WIND COMPONENTS AT THAT POINT.  IF THE INPUT WINDS
C   ARE AT THE NORTH POLE, THE OUTPUT COMPONENTS WILL BE MADE
C   CONSISTENT WITH THE WMO STANDARDS FOR REPORTING WINDS AT THE
C   NORTH POLE.  (SEE OFFICE NOTE 241 FOR WMO DEFINITION.)
C
C PROGRAM HISTORY LOG:
C   81-12-30  STACKPOLE, J. D.
C   88-10-13  CHASE, P.   ALLOW INPUT AND OUTPUT TO BE THE SAME
C   91-03-06  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:    CALL W3FC07 (FFID, FFJD, FGU, FGV, FU, FV)
C
C   INPUT ARGUMENT LIST:
C     FFID     - REAL   I-DISPLACEMENT FROM POINT TO NORTH POLE
C     FFJD     - REAL   J-DISPLACEMENT FROM POINT TO NORTH POLE
C     FGU      - REAL   GRID-ORIENTED U-COMPONENT
C     FGV      - REAL   GRID-ORIENTED V-COMPONENT
C
C   OUTPUT ARGUMENT LIST:
C     FU       - REAL   EARTH-ORIENTED U-COMPONENT, POSITIVE FROM WEST
C                MAY REFERENCE THE SAME LOCATION AS FGU.
C     FV       - REAL   EARTH-ORIENTED V-COMPONENT, POSITIVE FROM SOUTH
C                MAY REFERENCE THE SAME LOCATION AS FGV.
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       COMMON - SQRT
C
C REMARKS:  CALCULATE FFID AND FFJD AS FOLLOWS...
C         FFID = REAL(IP - I)
C         FFJD = REAL(JP - J)
C   WHERE (IP,JP) IS THE GRID COORDINATES OF THE NORTH POLE AND
C   (I,J) IS THE GRID COORDINATES OF THE POINT WHERE FGU AND FGV
C   OCCUR.
C        SEE W3FC11 FOR A SOUTHERN HEMISPHERE COMPANION SUBROUTINE.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
C
C$$$
C
      SAVE
C
      DATA  COS80 / 0.1736482 /
      DATA  SIN80 / 0.9848078 /

C     COS80 AND SIN80 ARE FOR WIND AT POLE
C     (USED FOR CO-ORDINATE ROTATION TO EARTH ORIENTATION)

      DFP = SQRT(FFID * FFID + FFJD * FFJD)
      IF (DFP .EQ. 0.0) THEN
        XFU = -(FGU * COS80 + FGV * SIN80)
        FV  = -(FGV * COS80 - FGU * SIN80)
      ELSE
        XFU = (FGU * FFJD - FGV * FFID) / DFP
        FV  = (FGU * FFID + FGV * FFJD) / DFP
      ENDIF
      FU = XFU
      RETURN
      END


      SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA,
     $                   X, LDX, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix formula
C        _
C        R = alpha*R + beta*op( A )*X*op( A )',
C                                                 _
C     where alpha and beta are scalars, R, X, and R are symmetric
C     matrices, A is a general matrix, and op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrices R
C             and X are given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( A ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER           _
C             The order of the matrices R and R and the number of rows
C             of the matrix op( A ).  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix X and the number of columns of the
C             the matrix op( A ).  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry, except when R is identified with X in
C             the call.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then A and X are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry with UPLO = 'U', the leading M-by-M upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R.
C             On entry with UPLO = 'L', the leading M-by-M lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R.
C             On exit, the leading M-by-M upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R. When R is identified with X in
C             the call, after exit, the diagonal entries of R must be
C             divided by 2.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,k)
C             where k is N when TRANS = 'N' and is M when TRANS = 'T' or
C             TRANS = 'C'.
C             On entry with TRANS = 'N', the leading M-by-N part of this
C             array must contain the matrix A.
C             On entry with TRANS = 'T' or TRANS = 'C', the leading
C             N-by-M part of this array must contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,k),
C             where k is M when TRANS = 'N' and is N when TRANS = 'T' or
C             TRANS = 'C'.
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C             The diagonal elements of this array are modified
C             internally, but are restored on exit.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             This array is not referenced when beta = 0, or M*N = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= M*N, if  beta <> 0;
C             LDWORK >= 0,   if  beta =  0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the symmetry
C     into account. Specifically, let X = T + T', with T an upper or
C     lower triangular matrix, defined by
C
C        T = triu( X ) - (1/2)*diag( X ),  if UPLO = 'U',
C        T = tril( X ) - (1/2)*diag( X ),  if UPLO = 'L',
C
C     where triu, tril, and diag denote the upper triangular part, lower
C     triangular part, and diagonal part of X, respectively. Then,
C
C        A*X*A' = ( A*T )*A' + A*( A*T )',  for TRANS = 'N',
C        A'*X*A = A'*( T*A ) + ( T*A )'*A,  for TRANS = 'T', or 'C',
C
C     which involve BLAS 3 operations (DTRMM and DSYR2K).
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C
C         2             2
C        M x N + 1/2 x N x M
C
C     operations.
C
C     FURTHER COMMENTS
C
C     This is a simpler version for MB01RD.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999.
C
C     REVISIONS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004,
C     Sep. 2013, Dec. 2013.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, HALF
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                  HALF = 0.5D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDA, LDR, LDWORK, LDX, M, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           LTRANS, LUPLO
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR.
     $                  ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N )
     $     .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01RU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0 or N = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the
C     updating formula (see METHOD section).
C     Workspace: need M*N.
C
      CALL DSCAL( N, HALF, X, LDX+1 )
C
      IF( LTRANS ) THEN
C
         CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N )
         CALL DTRMM(  'Left', UPLO, 'NoTranspose', 'Non-unit', N, M,
     $                ONE, X, LDX, DWORK, N )
         CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA,
     $                R, LDR )
C
      ELSE
C
         CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M )
         CALL DTRMM(  'Right', UPLO, 'NoTranspose', 'Non-unit', M, N,
     $                ONE, X, LDX, DWORK, M )
         CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA,
     $                R, LDR )
C
      END IF
C
      CALL DSCAL( N, TWO, X, LDX+1 )
C
      RETURN
C *** Last line of MB01RU ***
      END


      SUBROUTINE ddpoly(c,nc,x,pd,nd)
      INTEGER nc,nd
      REAL x,c(nc),pd(nd)
      INTEGER i,j,nnd
      REAL const
      pd(1)=c(nc)
      do 11 j=2,nd
        pd(j)=0.
11    continue
      do 13 i=nc-1,1,-1
        nnd=min(nd,nc+1-i)
        do 12 j=nnd,2,-1
          pd(j)=pd(j)*x+pd(j-1)
12      continue
        pd(1)=pd(1)*x+c(i)
13    continue
      const=2.
      do 14 i=3,nd
        pd(i)=const*pd(i)
        const=const*i
14    continue
      return
      END

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