diff --git a/doc/specs/stdlib_specialfunctions_activations.md b/doc/specs/stdlib_specialfunctions_activations.md new file mode 100644 index 000000000..ecbb91b5b --- /dev/null +++ b/doc/specs/stdlib_specialfunctions_activations.md @@ -0,0 +1,579 @@ +--- +title: specialfunctions +--- + +# Special functions - Neural Networks activations and their gradients + +[TOC] + +## `Gaussian` - Gaussian function + +### Status + +Experimental + +### Description + +Computes the gaussian function: +$$f(x)=\exp(-x^2)$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gaussian(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Gaussian_grad` - Gradient of the Gaussian function + +### Status + +Experimental + +### Description + +Computes the gradient of the gaussian function: +$$f(x)=-2 * x * \exp( - x ^ 2)$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gaussian_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Elu` - Exponential Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gaussian function: +$$ +\text{f}(x) = +\begin{cases} +x, & \text{if } x \geq 0 \\ +a * (\exp(x) - 1), & \text{otherwise} +\end{cases} +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):elu(interface)]] ` (x,a)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. +`a`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Elu_grad` - Gradient of the Exponential Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gradient of the gaussian function: +$$ +\text{f}(x) = +\begin{cases} +1, & \text{if } x \geq 0 \\ +a * \exp(x), & \text{otherwise} +\end{cases} +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):elu_grad(interface)]] ` (x,a)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. +`a`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Relu` - Rectified Linear Unit function + +### Status + +Experimental + +### Description + +Computes the Rectified Linear Unit function: +$$f(x) = \text{max}(0,x)$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):relu(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Relu_grad` - Gradient of the Rectified Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gradient of the gaussian function: +$$ +f(x) = +\begin{cases} +1, & \text{if } x \geq 0 \\ +0, & \text{otherwise} +\end{cases} +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):relu_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Gelu` - Gaussian Error Linear Unit function + +### Status + +Experimental + +### Description + +Computes the Gaussian Error Linear Unit function: +$$f(x) = \frac{1}{2} x ( 1 + \text{erf}(\frac{x}{\sqrt{2}}) ) $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gelu(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Gelu_grad` - Gradient of the Gaussian Error Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gradient of the gaussian error linear unit function: +$$ +f(x) = \frac{1}{2} ( 1 + \text{erf}(x \sqrt{2}) ) + x \sqrt{2} \exp( -\frac{1}{2} x^2) +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gelu_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Gelu_approx` - Approximation of the Gaussian Error Linear Unit function + +### Status + +Experimental + +### Description + +Computes a fast approximation of the Gaussian Error Linear Unit function using a fast $\text{erf}$ approximation: +$$f(x) = \frac{1}{2} x ( 1 + \text{ferf}(\frac{x}{\sqrt{2}}) ) $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gelu_approx(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Gelu_approx_grad` - Gradient of the Approximated Gaussian Error Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gradient of the gaussian error linear unit function using a fast $\text{erf}$ approximation: +$$ +f(x) = \frac{1}{2} ( 1 + \text{ferf}(x \sqrt{2}) ) + x \sqrt{2} \exp( -\frac{1}{2} x^2) +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):gelu_approx_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Sigmoid` - Sigmoid function + +### Status + +Experimental + +### Description + +Computes the sigmoid function: +$$f(x) = \frac{1}{1+\exp(-x)} $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Sigmoid(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Sigmoid_grad` - Gradient of the Sigmoid function + +### Status + +Experimental + +### Description + +Computes the gradient of the Sigmoid function: +$$f(x) = \frac{\exp(x)}{(1+\exp(x))^2} $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Sigmoid_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `SiLU` - Sigmoid Linear Unit function + +### Status + +Experimental + +### Description + +Computes the Sigmoid Linear Unit function: +$$f(x) = \frac{x}{1+\exp(-x)} $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):silu(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Silu_grad` - Gradient of the Sigmoid Linear Unit function + +### Status + +Experimental + +### Description + +Computes the gradient of the Sigmoid function: +$$f(x) = \frac{\exp(x)*(x+(1+\exp(x))^2)}{(1+\exp(x))^2} $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):silu_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Step` - Step function + +### Status + +Experimental + +### Description + +Computes the step function: +$$ +f(x) = +\begin{cases} +1, & \text{if } x > 0 \\ +0, & \text{otherwise} +\end{cases} +$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Step(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Step_grad` - Gradient of the Step function + +### Status + +Experimental + +### Description + +Computes the gradient of the Sigmoid function: +$$f(x) = 0 $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Step_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Softmax` - Softmax function + +### Status + +Experimental + +### Description + +Computes the Softmax function: +$$f(x) = \frac{\exp(x)-\text{max}(x_j)}{\sum_j{\exp(x)-\text{max}(x_j)}}$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Softmax(interface)]] ` (x,dim)` + +### Class + +Pure function for ranks 1 to 4. + +### Arguments + +`x`: Shall be an array of rank 1 to 4 of any `real` kind. +`dim`: integer scalar indicating upon which dimension to apply the normalization. + +### Return value + +The function returns an array with the same rank and kind as the input argument `x`. + +## `Softmax_grad` - Gradient of the Softmax function + +### Status + +Experimental + +### Description + +Computes the gradient of the Softmax function: +$$f(x,dim) = \text{Softmax}(x,dim)*(1-\text{Softmax}(x,dim)) $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Softmax_grad(interface)]] ` (x,dim)` + +### Class + +Pure function for ranks 1 to 4. + +### Arguments + +`x`: Shall be an array of rank 1 to 4 of any `real` kind. +`dim`: integer scalar indicating upon which dimension to apply the normalization. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Softplus` - Softplus function + +### Status + +Experimental + +### Description + +Computes the Softplus function: +$$f(x) = \log(\exp(x)+1)$$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Softplus(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. + +## `Softplus_grad` - Gradient of the Softplus function + +### Status + +Experimental + +### Description + +Computes the gradient of the Softplus function: +$$f(x) = \frac{\exp(x)}{\exp(x)+1} $$ + +### Syntax + +`result = ` [[stdlib_specialfunctions(module):Softplus_grad(interface)]] ` (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a scalar or array of any `real` kind. + +### Return value + +The function returns a value with the same type and kind as input argument. \ No newline at end of file diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 82cb2c450..8090b5775 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -41,7 +41,9 @@ set(fppFiles stdlib_sorting_ord_sort.fypp stdlib_sorting_sort.fypp stdlib_sorting_sort_index.fypp + stdlib_specialfunctions_activations.fypp stdlib_specialfunctions_gamma.fypp + stdlib_specialfunctions.fypp stdlib_stats.fypp stdlib_stats_corr.fypp stdlib_stats_cov.fypp @@ -113,7 +115,6 @@ set(SRC stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 - stdlib_specialfunctions.f90 stdlib_specialfunctions_legendre.f90 stdlib_quadrature_gauss.f90 stdlib_stringlist_type.f90 diff --git a/src/stdlib_specialfunctions.f90 b/src/stdlib_specialfunctions.f90 deleted file mode 100644 index a8f37bfac..000000000 --- a/src/stdlib_specialfunctions.f90 +++ /dev/null @@ -1,34 +0,0 @@ -module stdlib_specialfunctions - use stdlib_kinds, only: sp, dp, xdp, qp - - implicit none - - private - - public :: legendre - public :: dlegendre - - - interface legendre - !! version: experimental - !! - !! Legendre polynomial - pure elemental module function legendre_fp64(n,x) result(leg) - integer, intent(in) :: n - real(dp), intent(in) :: x - real(dp) :: leg - end function - end interface - - interface dlegendre - !! version: experimental - !! - !! First derivative Legendre polynomial - pure elemental module function dlegendre_fp64(n,x) result(dleg) - integer, intent(in) :: n - real(dp), intent(in) :: x - real(dp) :: dleg - end function - end interface - -end module stdlib_specialfunctions diff --git a/src/stdlib_specialfunctions.fypp b/src/stdlib_specialfunctions.fypp new file mode 100644 index 000000000..4864459b5 --- /dev/null +++ b/src/stdlib_specialfunctions.fypp @@ -0,0 +1,379 @@ +#:include "common.fypp" +module stdlib_specialfunctions + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + + implicit none + + private + + interface legendre + !! version: experimental + !! + !! Legendre polynomial + pure elemental module function legendre_fp64(n,x) result(leg) + integer, intent(in) :: n + real(dp), intent(in) :: x + real(dp) :: leg + end function + end interface + public :: legendre + + interface dlegendre + !! version: experimental + !! + !! First derivative Legendre polynomial + pure elemental module function dlegendre_fp64(n,x) result(dleg) + integer, intent(in) :: n + real(dp), intent(in) :: x + real(dp) :: dleg + end function + end interface + public :: dlegendre + + interface gaussian + !! Version: experimental + !! + !! gaussian function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gaussian_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gaussian + + interface gaussian_grad + !! Version: experimental + !! + !! gradient of the gaussian function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gaussian_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gaussian_grad + + interface elu + !! Version: experimental + !! + !! exponential linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function elu_${rk}$( x , a ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$, intent(in) :: a + ${rt}$ :: y + end function + #:endfor + end interface + public :: elu + + interface elu_grad + !! Version: experimental + !! + !! gradient of the exponential linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function elu_grad_${rk}$( x , a ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$, intent(in) :: a + ${rt}$ :: y + end function + #:endfor + end interface + public :: elu_grad + + interface relu + !! Version: experimental + !! + !! Rectified linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function relu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: relu + + interface relu_grad + !! Version: experimental + !! + !! Gradient rectified linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function relu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: relu_grad + + interface gelu + !! Version: experimental + !! + !! Gaussian error linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gelu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gelu + + interface gelu_grad + !! Version: experimental + !! + !! Gradient of the gaussian error linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gelu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gelu_grad + + interface gelu_approx + !! Version: experimental + !! + !! Approximated gaussian error linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gelu_approx_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gelu_approx + + interface gelu_approx_grad + !! Version: experimental + !! + !! Gradient of the approximated gaussian error linear unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function gelu_approx_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: gelu_approx_grad + + interface sigmoid + !! Version: experimental + !! + !! Sigmoid function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function sigmoid_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: sigmoid + + interface sigmoid_grad + !! Version: experimental + !! + !! Gradient of the sigmoid function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function sigmoid_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: sigmoid_grad + + interface silu + !! Version: experimental + !! + !! Sigmoid Linear Unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function silu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: silu + + interface silu_grad + !! Version: experimental + !! + !! Gradient of the Sigmoid Linear Unit function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function silu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: silu_grad + + interface step + !! Version: experimental + !! + !! Step function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function step_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: step + + interface step_grad + !! Version: experimental + !! + !! Gradient of the step function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function step_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: step_grad + + interface tanh + !! Version: experimental + !! + !! gaussian function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function tanh_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: tanh + + interface tanh_grad + !! Version: experimental + !! + !! gradient of the gaussian function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function tanh_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: tanh_grad + + interface Softmax + !! Version: experimental + !! + !! Softmax function. Available for ranks 1 to 4 + #:for rk, rt in REAL_KINDS_TYPES + pure module function Softmax_r1_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x(:) + ${rt}$ :: y(size(x)) + end function + pure module function Softmax_r2_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2)) + integer, intent(in), optional :: dim + end function + pure module function Softmax_r3_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3)) + integer, intent(in), optional :: dim + end function + pure module function Softmax_r4_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3),size(x,dim=4)) + integer, intent(in), optional :: dim + end function + #:endfor + end interface + public :: softmax + + interface Softmax_grad + !! Version: experimental + !! + !! Gradient of the softmax function. Available for ranks 1 to 4 + #:for rk, rt in REAL_KINDS_TYPES + pure module function Softmax_grad_r1_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x(:) + ${rt}$ :: y(size(x)) + end function + pure module function Softmax_grad_r2_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2)) + integer, intent(in), optional :: dim + end function + pure module function Softmax_grad_r3_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3)) + integer, intent(in), optional :: dim + end function + pure module function Softmax_grad_r4_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3),size(x,dim=4)) + integer, intent(in), optional :: dim + end function + #:endfor + end interface + public :: Softmax_grad + + interface Softplus + !! Version: experimental + !! + !! Softplus function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function Softplus_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: Softplus + + interface Softplus_grad + !! Version: experimental + !! + !! Gradient of the softplus function + #:for rk, rt in REAL_KINDS_TYPES + elemental module function Softplus_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: Softplus_grad + + interface ftanh + !! Version: experimental + !! + !! Fast approximation of the tanh function + !! Source: https://fortran-lang.discourse.group/t/fastgpt-faster-than-pytorch-in-300-lines-of-fortran/5385/31 + #:for rk, rt in REAL_KINDS_TYPES + elemental module function ftanh_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: ftanh + + interface ferf + !! Version: experimental + !! + !! Fast approximation of the erf function + !! Source: https://fortran-lang.discourse.group/t/fastgpt-faster-than-pytorch-in-300-lines-of-fortran/5385/31 + #:for rk, rt in REAL_KINDS_TYPES + elemental module function ferf_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + end function + #:endfor + end interface + public :: ferf + +end module stdlib_specialfunctions diff --git a/src/stdlib_specialfunctions_activations.fypp b/src/stdlib_specialfunctions_activations.fypp new file mode 100644 index 000000000..c8a50710b --- /dev/null +++ b/src/stdlib_specialfunctions_activations.fypp @@ -0,0 +1,364 @@ +#:include "common.fypp" +submodule(stdlib_specialfunctions) stdlib_specialfunctions_activations + implicit none + + #:for rk, rt in REAL_KINDS_TYPES + ${rt}$, parameter :: isqrt2_${rk}$ = 1._${rk}$ / sqrt(2._${rk}$) + #:endfor + +contains + +!================================================== +! Gaussian +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function gaussian_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = exp(-x**2) +end function + +elemental module function gaussian_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = -2._${rk}$ * x * exp(-x**2) +end function + +#:endfor + +!================================================== +! Exponential Linear Unit +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function elu_${rk}$( x , a ) result ( y ) + ${rt}$, intent(in) :: x + ${rt}$, intent(in) :: a + ${rt}$ :: y + if(x >= 0._${rk}$)then + y = x + else + y = a * (exp(x) - 1._${rk}$) + end if +end function + +elemental module function elu_grad_${rk}$( x , a ) result ( y ) + ${rt}$, intent(in) :: x + ${rt}$, intent(in) :: a + ${rt}$ :: y + if(x >= 0._${rk}$)then + y = 1._${rk}$ + else + y = a * exp(x) + end if +end function + +#:endfor + +!================================================== +! Rectified Linear Unit +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function relu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = max(0._${rk}$, x) +end function + +elemental module function relu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + if(x > 0._${rk}$)then + y = 1._${rk}$ + else + y = 0._${rk}$ + end if +end function + +#:endfor + +!================================================== +! GELU: Gaussian Error Linear Units function +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function gelu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 0.5_${rk}$ * x * (1._${rk}$ + erf(x * isqrt2_${rk}$)) +end function + +elemental module function gelu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 0.5_${rk}$ * (1._${rk}$ + erf(x * isqrt2_${rk}$) ) + y = y + x * isqrt2_${rk}$ * exp( - 0.5_${rk}$ * x**2 ) +end function + +#:endfor + +#:for rk, rt in REAL_KINDS_TYPES +elemental module function gelu_approx_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 0.5_${rk}$ * x * (1._${rk}$ + ferf(x * isqrt2_${rk}$)) +end function + +elemental module function gelu_approx_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 0.5_${rk}$ * (1._${rk}$ + ferf(x * isqrt2_${rk}$) ) + y = y + x * isqrt2_${rk}$ * exp( - 0.5_${rk}$ * x**2 ) +end function + +#:endfor + +!================================================== +! Sigmoid +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function sigmoid_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 1._${rk}$ / (1._${rk}$ + exp(-x)) +end function + +elemental module function sigmoid_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = exp(x) / (1._${rk}$ + exp(x))**2 +end function + +#:endfor + +!================================================== +! SiLU: Sigmoid Linear Unit +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function silu_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = x / (1._${rk}$ + exp(-x)) +end function + +elemental module function silu_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = (1._${rk}$ + exp(x))**2 + y = exp(x) * ( x + y ) / y +end function + +#:endfor + +!================================================== +! Step +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function Step_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + if(x > 0._${rk}$)then + y = 1._${rk}$ + else + y = 0._${rk}$ + end if +end function + +elemental module function Step_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 0._${rk}$ +end function + +#:endfor + +!================================================== +! tanh +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function tanh_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = ftanh(x) +end function + +elemental module function tanh_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = 1._${rk}$ - ftanh(x)**2 +end function + +#:endfor + +!================================================== +! Softmax +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +pure module function Softmax_r1_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x(:) + ${rt}$ :: y(size(x)) + + y = exp(x - maxval(x)) + y = y / sum(y) +end function + +pure module function Softmax_r2_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2)) + + integer, intent(in), optional :: dim + integer :: dim_, j + + dim_ = 1; if(present(dim)) dim_ = dim + + if(dim_==1)then + do j = 1, size(x,dim=2) + y(:,j) = Softmax( x(:,j) ) + end do + else + do j = 1, size(x,dim=1) + y(j,:) = Softmax( x(j,:) ) + end do + end if +end function + +pure module function Softmax_r3_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3)) + + integer, intent(in), optional :: dim + integer :: dim_, j + + dim_ = 1; if(present(dim)) dim_ = dim + + if(dim_<=2)then + do j = 1, size(x,dim=3) + y(:,:,j) = Softmax( x(:,:,j) , dim = dim_ ) + end do + else + do j = 1, size(x,dim=1) + y(j,:,:) = Softmax( x(j,:,:) , dim = 2 ) + end do + end if +end function + +pure module function Softmax_r4_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3),size(x,dim=4)) + + integer, intent(in), optional :: dim + integer :: dim_, j + + dim_ = 1; if(present(dim)) dim_ = dim + + if(dim_<=3)then + do j = 1, size(x,dim=4) + y(:,:,:,j) = Softmax( x(:,:,:,j) , dim = dim_ ) + end do + else + do j = 1, size(x,dim=1) + y(j,:,:,:) = Softmax( x(j,:,:,:) , dim = 3 ) + end do + end if +end function + +pure module function Softmax_grad_r1_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x(:) + ${rt}$ :: y(size(x)) + + y = Softmax(x) + y = y * (1._${rk}$ - y) +end function + +pure module function Softmax_grad_r2_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2)) + + integer, intent(in), optional :: dim + integer :: dim_ + + dim_ = 1; if(present(dim)) dim_ = dim + + y = Softmax(x,dim_) + y = y * (1._${rk}$ - y) +end function + +pure module function Softmax_grad_r3_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3)) + + integer, intent(in), optional :: dim + integer :: dim_ + + dim_ = 1; if(present(dim)) dim_ = dim + + y = Softmax(x,dim_) + y = y * (1._${rk}$ - y) +end function + +pure module function Softmax_grad_r4_${rk}$( x , dim ) result( y ) + ${rt}$, intent(in) :: x(:,:,:,:) + ${rt}$ :: y(size(x,dim=1),size(x,dim=2),size(x,dim=3),size(x,dim=4)) + + integer, intent(in), optional :: dim + integer :: dim_ + + dim_ = 1; if(present(dim)) dim_ = dim + + y = Softmax(x,dim_) + y = y * (1._${rk}$ - y) +end function + +#:endfor + +!================================================== +! Softplus +!================================================== +#:for rk, rt in REAL_KINDS_TYPES +elemental module function Softplus_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = log(exp(x) + 1._${rk}$) +end function + +elemental module function Softplus_grad_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + y = exp(x) / (exp(x) + 1._${rk}$) +end function + +#:endfor + +!================================================== +! Fast intrinsics for accelerated activations +!================================================== + +#:for rk, rt in REAL_KINDS_TYPES +elemental module function ftanh_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + ${rt}$ :: x2, a, b + + if (x > 5._${rk}$) then + y = 1._${rk}$ + elseif (x < -5._${rk}$) then + y = -1._${rk}$ + else + x2 = x*x + a = x * (135135.0_${rk}$ + x2 * (17325.0_${rk}$ + x2 * (378.0_${rk}$ + x2))) + b = 135135.0_${rk}$ + x2 * (62370.0_${rk}$ + x2 * (3150.0_${rk}$ + x2 * 28.0_${rk}$)) + y = a / b + end if +end function + +elemental module function ferf_${rk}$( x ) result( y ) + ${rt}$, intent(in) :: x + ${rt}$ :: y + ${rt}$ :: abs_x + + abs_x = abs(x) + y = 1._${rk}$ - 1._${rk}$ / (1._${rk}$+ 0.278393_${rk}$*abs_x + 0.230389_${rk}$*abs_x**2 + 0.000972_${rk}$*abs_x**3 + 0.078108_${rk}$*abs_x**4)**4 + y = y * sign(1.0_${rk}$,x) +end function + +#:endfor + +end submodule \ No newline at end of file diff --git a/test/specialfunctions/CMakeLists.txt b/test/specialfunctions/CMakeLists.txt index caa3a96b5..46ede5f15 100644 --- a/test/specialfunctions/CMakeLists.txt +++ b/test/specialfunctions/CMakeLists.txt @@ -2,6 +2,7 @@ # Create a list of the files to be preprocessed set(fppFiles + test_specialfunctions_activations.fypp test_specialfunctions_gamma.fypp ) diff --git a/test/specialfunctions/test_specialfunctions_activations.fypp b/test/specialfunctions/test_specialfunctions_activations.fypp new file mode 100644 index 000000000..cc33c7b6a --- /dev/null +++ b/test/specialfunctions/test_specialfunctions_activations.fypp @@ -0,0 +1,163 @@ +#:include "common.fypp" +#:set R_KINDS_TYPES = [KT for KT in REAL_KINDS_TYPES if KT[0] in ["sp","dp"]] + +module test_specialfunctions_activation + use testdrive, only : new_unittest, unittest_type, error_type, check + use stdlib_kinds + use stdlib_specialfunctions + use stdlib_math, only: linspace + implicit none + private + + public :: collect_specialfunctions_activation + + #:for k1, t1 in R_KINDS_TYPES + ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) + #:endfor + +contains + + subroutine collect_specialfunctions_activation(testsuite) + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("sigmoid", test_sigmoid), & + new_unittest("gelu" , test_gelu ), & + new_unittest("softmax", test_softmax) & + ] + end subroutine collect_specialfunctions_activation + + subroutine test_sigmoid(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 10 + real(sp) :: x(n), y(n), y_ref(n) + + y_ref = [0.119202919304371, 0.174285307526588, 0.247663781046867,& + 0.339243650436401, 0.444671928882599, 0.555328071117401,& + 0.660756349563599, 0.752336204051971, 0.825714707374573,& + 0.880797028541565] + x = linspace(-2._sp, 2._sp, n) + y = sigmoid( x ) + call check(error, norm2(y-y_ref) < n*tol_sp ) + if (allocated(error)) return + end subroutine + + subroutine test_gelu(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 10 + real(sp) :: x(n), y(n), y_ref(n) + + y_ref = [-0.0455002784729 , -0.093188509345055, -0.148066952824593,& + -0.168328359723091, -0.0915712043643 , 0.130650997161865,& + 0.498338282108307, 0.963044226169586, 1.462367057800293,& + 1.9544997215271 ] + x = linspace(-2._sp, 2._sp, n) + y = gelu( x ) + call check(error, norm2(y-y_ref) < n*tol_sp ) + if (allocated(error)) return + + y = gelu_approx( x ) + call check(error, norm2(y-y_ref) < n*tol_sp ) + if (allocated(error)) return + end subroutine + + subroutine test_softmax(error) + type(error_type), allocatable, intent(out) :: error + + real(sp) :: x(3,3,3), y(3,3,3), y_ref(3,3,3) + + x = reshape( [ 0.82192878, 0.76998032, 0.98611263,& + 0.8621334 , 0.65358045, 0.26387113,& + 0.12743663, 0.35237132, 0.23801647,& + + 0.69773567, 0.40568874, 0.44789482,& + 0.42930753, 0.49579193, 0.53139985,& + 0.03035799, 0.65293157, 0.47613957,& + + 0.21088634, 0.9356926 , 0.0991312 ,& + 0.46070181, 0.02943479, 0.17557538,& + 0.10541313, 0.33946349, 0.34804323 ] ,[3,3,3] ) + + !> Softmax on dim = 1 + y = Softmax(x,dim=1) + + y_ref = reshape( [ 0.319712639, 0.303528070, 0.376759291,& + 0.423455358, 0.343743294, 0.232801422,& + 0.296809316, 0.371676773, 0.331513911,& + + 0.395936400, 0.295658976, 0.308404684,& + 0.314838648, 0.336482018, 0.348679334,& + 0.225966826, 0.421138495, 0.352894694,& + + 0.252614945, 0.521480858, 0.225904226,& + 0.416388273, 0.270521373, 0.313090324,& + 0.282621205, 0.357150704, 0.360228121 ] ,[3,3,3] ) + + call check(error, norm2(y-y_ref) < tol_sp ) + if (allocated(error)) return + + !> Softmax on dim = 2 + y = Softmax(x,dim=2) + + y_ref = reshape( [ 0.393646270, 0.392350882, 0.510482967,& + 0.409795105, 0.349239051, 0.247922391,& + 0.196558580, 0.258410037, 0.241594598,& + + 0.439052343, 0.296315849, 0.320951223,& + 0.335690796, 0.324254662, 0.348903090,& + 0.225256786, 0.379429489, 0.330145657,& + + 0.314101219, 0.511530280, 0.297435701,& + 0.403239518, 0.206675291, 0.321064562,& + 0.282659233, 0.281794399, 0.381499708 ] ,[3,3,3] ) + + call check(error, norm2(y-y_ref) < tol_sp ) + if (allocated(error)) return + + !> Softmax on dim = 3 + y = Softmax(x,dim=3) + + y_ref = reshape( [ 0.412202179, 0.347835541, 0.501081109,& + 0.431399941, 0.418453932, 0.310344934,& + 0.346536130, 0.299599379, 0.295405835,& + + 0.364060789, 0.241637364, 0.292525023,& + 0.279837668, 0.357372403, 0.405537367,& + 0.314476222, 0.404643506, 0.374830246,& + + 0.223737061, 0.410527140, 0.206393898,& + 0.288762331, 0.224173695, 0.284117699,& + 0.338987619, 0.295757085, 0.329763889 ] ,[3,3,3] ) + + call check(error, norm2(y-y_ref) < tol_sp ) + if (allocated(error)) return + + end subroutine test_softmax + + +end module test_specialfunctions_activation + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_specialfunctions_activation, only : collect_specialfunctions_activation + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [new_testsuite("activation functions", & + collect_specialfunctions_activation)] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program tester \ No newline at end of file