Attribute VB_Name = "OPTIM_GRAD_FD_LIBR"
'// PERFECT

'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Option Explicit     'Requires that all variables to be declared explicitly.
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Option Base 1       'The "Option Base" statement allows to specify 0 or 1 as the
                    'default first index of arrays.
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------

'************************************************************************************
'************************************************************************************
'© Copyright NicoSystem 2009. All rights reserved by Rafael Nicolas Fermin Cota,
'San Francisco, CA. USA  www.rnfc.org
'nfermincota.hba2005@ivey.ca
'************************************************************************************
'************************************************************************************
'FUNCTION      : UNIVAR_FD_GRAD_APPROX_FUNC
'DESCRIPTION   : Approximate the gradient with finite differences for
'univariate functions
'LIBRARY       : OPTIMIZATION
'GROUP         : GRAD_FD
'ID            : 001
'AUTHOR        : RAFAEL NICOLAS FERMIN COTA
'LAST UPDATE   : 02/13/2009
'************************************************************************************
'************************************************************************************

Function UNIVAR_FD_GRAD_APPROX_FUNC(ByVal FUNC_STR_NAME As String, _
ByVal XTEMP_VAL As Double)

Dim j As Long

Dim TEMP_DG As Double
Dim TEMP_GN As Double
Dim TEMP_DGN As Double
Dim TEMP_GRAD As Double
Dim TEMP_DELTA As Double

Dim ATEMP_VAL As Double
Dim BTEMP_VAL As Double
Dim CTEMP_VAL As Double

Dim EPSILON As Double
    
On Error GoTo ERROR_LABEL
    
    EPSILON = 4 * 10 ^ -4
    j = 0
    Do
        ATEMP_VAL = XTEMP_VAL
        ATEMP_VAL = ATEMP_VAL + EPSILON / 2
        CTEMP_VAL = Excel.Application.Run(FUNC_STR_NAME, ATEMP_VAL)
        
        ATEMP_VAL = XTEMP_VAL
        ATEMP_VAL = ATEMP_VAL - EPSILON / 2
        BTEMP_VAL = Excel.Application.Run(FUNC_STR_NAME, ATEMP_VAL)
        
        TEMP_DELTA = (CTEMP_VAL - BTEMP_VAL) / EPSILON
        If j > 0 Then 'difference norm criterion
            TEMP_DG = TEMP_DELTA - TEMP_GRAD
            TEMP_DGN = (TEMP_DG)
            TEMP_GN = (TEMP_DELTA)
            If TEMP_DGN < 0.2 * TEMP_GN Then: Exit Do
        End If
        
        TEMP_GRAD = TEMP_DELTA  'save gradient
        EPSILON = EPSILON / 4
        j = j + 1
    Loop Until EPSILON < 10 ^ -9
    
    UNIVAR_FD_GRAD_APPROX_FUNC = TEMP_DELTA

Exit Function
ERROR_LABEL:
    UNIVAR_FD_GRAD_APPROX_FUNC = Err.number
End Function


'************************************************************************************
'************************************************************************************
'© Copyright NicoSystem 2009. All rights reserved by Rafael Nicolas Fermin Cota,
'San Francisco, CA. USA  www.rnfc.org
'nfermincota.hba2005@ivey.ca
'************************************************************************************
'************************************************************************************
'FUNCTION      : MULTVAR_FD_GRAD_VALID_FUNC
'DESCRIPTION   : Finite-difference gradient validation function
'LIBRARY       : OPTIMIZATION
'GROUP         : GRAD_FD
'ID            : 002
'AUTHOR        : RAFAEL NICOLAS FERMIN COTA
'LAST UPDATE   : 02/13/2009
'************************************************************************************
'************************************************************************************

Function MULTVAR_FD_GRAD_VALID_FUNC(ByVal FUNC_STR_NAME As String, _
ByVal GRAD_STR_NAME As String, _
ByRef PARAM_RNG As Variant, _
Optional ByRef SCALE_RNG As Variant, _
Optional ByVal MIN_FLAG As Boolean = True)

Dim i As Long
Dim NSIZE As Long

Dim TEMP_ERR As Double
Dim TEMP_ABS As Double
Dim TEMP_NORM As Double

Dim FTEMP_VECTOR As Variant
Dim GTEMP_VECTOR As Variant

Dim PARAM_VECTOR As Variant
Dim SCALE_VECTOR As Variant

On Error GoTo ERROR_LABEL

    PARAM_VECTOR = PARAM_RNG
    If UBound(PARAM_VECTOR, 1) = 1 Then: PARAM_VECTOR = MATRIX_TRANSPOSE_FUNC(PARAM_VECTOR)
    NSIZE = UBound(PARAM_VECTOR, 1)
    
    If IsArray(SCALE_RNG) = True Then
        SCALE_VECTOR = SCALE_RNG
        If UBound(SCALE_VECTOR, 1) = 1 Then: _
            SCALE_VECTOR = MATRIX_TRANSPOSE_FUNC(SCALE_VECTOR)
    Else
        ReDim SCALE_VECTOR(1 To NSIZE, 1 To 1)
        For i = 1 To NSIZE
            SCALE_VECTOR(i, 1) = 1
        Next i
    End If
    
    GTEMP_VECTOR = MULTVAR_CALL_GRAD_FUNC(GRAD_STR_NAME, PARAM_VECTOR, _
                   SCALE_VECTOR, MIN_FLAG)
                                                        
    FTEMP_VECTOR = MULTVAR_FD_GRAD_APPROX_FUNC(FUNC_STR_NAME, _
                   PARAM_VECTOR, SCALE_VECTOR, MIN_FLAG)
    
    TEMP_ERR = 0
    For i = 1 To NSIZE
        TEMP_ERR = TEMP_ERR + Abs(GTEMP_VECTOR(i, 1) - FTEMP_VECTOR(i, 1))
    Next i
    
    TEMP_NORM = 0 'return the Euclidean norm of a vector
    For i = 1 To UBound(FTEMP_VECTOR, 1)
        TEMP_NORM = TEMP_NORM + FTEMP_VECTOR(i, 1) ^ 2
    Next i
    TEMP_ABS = (TEMP_NORM) ^ 0.5
        
    If TEMP_ERR > 0.001 * TEMP_ABS Then
        MULTVAR_FD_GRAD_VALID_FUNC = False
    Else
        MULTVAR_FD_GRAD_VALID_FUNC = True
    End If

Exit Function
ERROR_LABEL:
    MULTVAR_FD_GRAD_VALID_FUNC = Err.number
End Function

'************************************************************************************
'************************************************************************************
'© Copyright NicoSystem 2009. All rights reserved by Rafael Nicolas Fermin Cota,
'San Francisco, CA. USA  www.rnfc.org
'nfermincota.hba2005@ivey.ca
'************************************************************************************
'************************************************************************************
'FUNCTION      : MULTVAR_FD_GRAD_APPROX_FUNC
'DESCRIPTION   : Approximate the gradient with finite differences
'LIBRARY       : OPTIMIZATION
'GROUP         : GRAD_FD
'ID            : 003
'AUTHOR        : RAFAEL NICOLAS FERMIN COTA
'LAST UPDATE   : 02/13/2009
'************************************************************************************
'************************************************************************************

Function MULTVAR_FD_GRAD_APPROX_FUNC(ByVal FUNC_STR_NAME As String, _
ByRef PARAM_RNG As Variant, _
Optional ByRef SCALE_RNG As Variant, _
Optional ByVal MIN_FLAG As Boolean = True)

Dim i As Long
Dim j As Long
Dim NSIZE As Long

Dim ATEMP_VAL As Double
Dim BTEMP_VAL As Double

Dim TEMP_MULT As Double
Dim TEMP_NORM As Double
Dim TEMP_DELTA As Double
Dim TEMP_BOUND As Double
Dim TEMP_FACTOR As Double

Dim CTEMP_VECTOR As Variant
Dim DTEMP_VECTOR As Variant

Dim DELTA_VECTOR As Variant
Dim GRAD_VECTOR As Variant
Dim PARAM_VECTOR As Variant
Dim SCALE_VECTOR As Variant

On Error GoTo ERROR_LABEL

    If MIN_FLAG = True Then
        TEMP_FACTOR = 1
    Else
        TEMP_FACTOR = -1
    End If

    PARAM_VECTOR = PARAM_RNG
    If UBound(PARAM_VECTOR, 1) = 1 Then: PARAM_VECTOR = MATRIX_TRANSPOSE_FUNC(PARAM_VECTOR)
        
    NSIZE = UBound(PARAM_VECTOR, 1)
    
    If IsArray(SCALE_RNG) = True Then
        SCALE_VECTOR = SCALE_RNG
        If UBound(SCALE_VECTOR, 1) = 1 Then: SCALE_VECTOR = MATRIX_TRANSPOSE_FUNC(SCALE_VECTOR)
    Else
        ReDim SCALE_VECTOR(1 To NSIZE, 1 To 1)
        For i = 1 To NSIZE
            SCALE_VECTOR(i, 1) = 1
        Next i
    End If
    
    For i = 1 To NSIZE
        PARAM_VECTOR(i, 1) = SCALE_VECTOR(i, 1) * PARAM_VECTOR(i, 1)
    Next i
    
    ReDim GRAD_VECTOR(1 To NSIZE, 1 To 1)
    ReDim DELTA_VECTOR(1 To NSIZE, 1 To 1)
    
    TEMP_DELTA = 4 * 10 ^ -4
    j = 0
    
'--------------------------------------------------------------------------------------
    Do
'--------------------------------------------------------------------------------------
        
        For i = 1 To NSIZE
            
            DTEMP_VECTOR = PARAM_VECTOR
            DTEMP_VECTOR(i, 1) = DTEMP_VECTOR(i, 1) + TEMP_DELTA / 2
            
            BTEMP_VAL = MULTVAR_CALL_OBJ_FUNC(FUNC_STR_NAME, _
                        DTEMP_VECTOR, "", MIN_FLAG)
            
            DTEMP_VECTOR = PARAM_VECTOR
            DTEMP_VECTOR(i, 1) = DTEMP_VECTOR(i, 1) - TEMP_DELTA / 2
            
            ATEMP_VAL = MULTVAR_CALL_OBJ_FUNC(FUNC_STR_NAME, _
                        DTEMP_VECTOR, "", MIN_FLAG)
            
            GRAD_VECTOR(i, 1) = (BTEMP_VAL - ATEMP_VAL) / TEMP_DELTA
        Next i
'--------------------------------------------------------------------------------------
        If j > 0 Then
'--------------------------------------------------------------------------------------
            'difference norm criterion
            For i = 1 To NSIZE
                DELTA_VECTOR(i, 1) = GRAD_VECTOR(i, 1) - CTEMP_VECTOR(i, 1)
            Next i
            
            TEMP_NORM = 0 'return the Euclidean norm of a vector
            For i = 1 To NSIZE
                TEMP_NORM = TEMP_NORM + DELTA_VECTOR(i, 1) ^ 2
            Next i
            TEMP_BOUND = (TEMP_NORM) ^ 0.5
            
            TEMP_NORM = 0 'return the Euclidean norm of a vector
            For i = 1 To NSIZE
                TEMP_NORM = TEMP_NORM + GRAD_VECTOR(i, 1) ^ 2
            Next i
            TEMP_MULT = (TEMP_NORM) ^ 0.5

            If TEMP_BOUND < 0.2 * TEMP_MULT Then Exit Do
'--------------------------------------------------------------------------------------
        End If
'--------------------------------------------------------------------------------------
        CTEMP_VECTOR = GRAD_VECTOR  'save gradient
        TEMP_DELTA = TEMP_DELTA / 4
        j = j + 1
'--------------------------------------------------------------------------------------
    Loop Until TEMP_DELTA < 10 ^ -9
'--------------------------------------------------------------------------------------
    
    MULTVAR_FD_GRAD_APPROX_FUNC = GRAD_VECTOR

Exit Function
ERROR_LABEL:
    MULTVAR_FD_GRAD_APPROX_FUNC = Err.number
End Function