Return to fonctions_speciales.F90 CVS log

Up to [local] / rpl / src

Modification du copyright.

    1: !===============================================================================
    2: ! RPL/2 (R) version 4.1.32
    3: ! Copyright (C) 1989-2020 Dr. BERTRAND Joël
    4: !
    5: ! This file is part of RPL/2.
    6: !
    7: ! RPL/2 is free software; you can redistribute it and/or modify it
    8: ! under the terms of the CeCILL V2 License as published by the french
    9: ! CEA, CNRS and INRIA.
   10: !
   11: ! RPL/2 is distributed in the hope that it will be useful, but WITHOUT
   12: ! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   13: ! FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
   14: ! for more details.
   15: !
   16: ! You should have received a copy of the CeCILL License
   17: ! along with RPL/2. If not, write to info@cecill.info.
   18: !===============================================================================
   19: 
   20: 
   21: #include "rplftypes-conv.inc"
   22: 
   23: 
   24: !===============================================================================
   25: ! Fonction renvoyant le logarithme népérien de la fonction GAMMA(X).
   26: ! Le logarithme de GAMMA est bien plus facile à calculer que la fonction
   27: ! GAMMA.
   28: !===============================================================================
   29: 
   30: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
   31:     use iso_c_binding
   32:     implicit none
   33: 
   34:     integer(rpl_integer8), intent(out), optional ::     ERREUR
   35:     integer(rpl_integer8)                               ERREUR_GAMMA
   36: 
   37:     real(rpl_real8), intent(in) ::                      X
   38:     real(rpl_real8), intent(out) ::                     RESULTAT
   39:     real(rpl_real8), intent(out), optional ::           SIGNE
   40:     real(rpl_real8)                                     SIGNE_GAMMA
   41: 
   42:     type, bind(C) :: GSL_SF_RESULT
   43:         real(c_double)          VALEUR
   44:         real(c_double)          ERREUR
   45:     end type
   46: 
   47:     type(GSL_SF_RESULT)                                 STRUCT_RESULTAT
   48: 
   49:     interface
   50:         integer(c_int) function gsl_sf_lngamma_sgn_e(X, &
   51:                 RESULTAT, SIGNE) bind(C, name='gsl_sf_lngamma_sgn_e')
   52:             use iso_c_binding
   53:             import :: GSL_SF_RESULT
   54:             implicit none
   55:             real(c_double), intent(in), value ::        X
   56:             type(GSL_SF_RESULT), intent(out) ::         RESULTAT
   57:             real(c_double), intent(out) ::              SIGNE
   58:         end function
   59:     end interface
   60: 
   61:     ERREUR_GAMMA = gsl_sf_lngamma_sgn_e(X, STRUCT_RESULTAT, &
   62:             SIGNE_GAMMA)
   63:     RESULTAT = STRUCT_RESULTAT%VALEUR
   64: 
   65:     if (present(SIGNE)) then
   66:         SIGNE = SIGNE_GAMMA
   67:     end if
   68: 
   69:     if (present(ERREUR)) then
   70:         ERREUR = ERREUR_GAMMA
   71:     end if
   72: 
   73:     return
   74: end subroutine
   75: 
   76: ! vim: ts=4