Return to fonctions_speciales.F90 CVS log

Up to [local] / rpl / src

Annotation of rpl/src/fonctions_speciales.F90, revision 1.67

1.1       bertrand    1: !===============================================================================
1.66      bertrand    2: ! RPL/2 (R) version 4.1.32
1.67    ! bertrand    3: ! Copyright (C) 1989-2020 Dr. BERTRAND Joël
1.1       bertrand    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: 
1.11      bertrand   21: #include "rplftypes-conv.inc"
1.1       bertrand   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