Return to fonctions_speciales.F90 CVS log

Up to [local] / rpl / src

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

1.1       bertrand    1: !===============================================================================
1.17      bertrand    2: ! RPL/2 (R) version 4.1.0.prerelease.0
1.15      bertrand    3: ! Copyright (C) 1989-2011 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: !===============================================================================
1.18    ! bertrand   19: <<<<<<< fonctions_speciales.F90
        !            20: ! RPL/2 (R) version 4.1.0.prerelease.0
        !            21: =======
        !            22: ! RPL/2 (R) version 4.0.23
        !            23: >>>>>>> 1.16.2.2
        !            24: ! Copyright (C) 1989-2011 Dr. BERTRAND Joël
        !            25: !
        !            26: ! This file is part of RPL/2.
        !            27: !
        !            28: ! RPL/2 is free software; you can redistribute it and/or modify it
        !            29: ! under the terms of the CeCILL V2 License as published by the french
        !            30: ! CEA, CNRS and INRIA.
        !            31: !
        !            32: ! RPL/2 is distributed in the hope that it will be useful, but WITHOUT
        !            33: ! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
        !            34: ! FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
        !            35: ! for more details.
        !            36: !
        !            37: ! You should have received a copy of the CeCILL License
        !            38: ! along with RPL/2. If not, write to info@cecill.info.
        !            39: !===============================================================================
1.1       bertrand   40: 
                     41: 
1.11      bertrand   42: #include "rplftypes-conv.inc"
1.1       bertrand   43: 
                     44: 
                     45: !===============================================================================
                     46: ! Fonction renvoyant le logarithme népérien de la fonction GAMMA(X).
                     47: ! Le logarithme de GAMMA est bien plus facile à calculer que la fonction
                     48: ! GAMMA.
                     49: !===============================================================================
                     50: 
                     51: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
                     52:    use iso_c_binding
                     53:    implicit none
                     54: 
                     55:    integer(rpl_integer8), intent(out), optional ::     ERREUR
                     56:    integer(rpl_integer8)                               ERREUR_GAMMA
                     57: 
                     58:    real(rpl_real8), intent(in) ::                      X
                     59:    real(rpl_real8), intent(out) ::                     RESULTAT
                     60:    real(rpl_real8), intent(out), optional ::           SIGNE
                     61:    real(rpl_real8)                                     SIGNE_GAMMA
                     62: 
                     63:    type, bind(C) :: GSL_SF_RESULT
                     64:        real(c_double)          VALEUR
                     65:        real(c_double)          ERREUR
                     66:    end type
                     67: 
                     68:    type(GSL_SF_RESULT)                                 STRUCT_RESULTAT
                     69: 
                     70:    interface
                     71:        integer(c_int) function gsl_sf_lngamma_sgn_e(X, &
                     72:                RESULTAT, SIGNE) bind(C, name='gsl_sf_lngamma_sgn_e')
                     73:            use iso_c_binding
                     74:            import :: GSL_SF_RESULT
                     75:            implicit none
                     76:            real(c_double), intent(in), value ::        X
                     77:            type(GSL_SF_RESULT), intent(out) ::         RESULTAT
                     78:            real(c_double), intent(out) ::              SIGNE
                     79:        end function
                     80:    end interface
                     81: 
                     82:    ERREUR_GAMMA = gsl_sf_lngamma_sgn_e(X, STRUCT_RESULTAT, &
                     83:            SIGNE_GAMMA)
                     84:    RESULTAT = STRUCT_RESULTAT%VALEUR
                     85: 
                     86:    if (present(SIGNE)) then
                     87:        SIGNE = SIGNE_GAMMA
                     88:    end if
                     89: 
                     90:    if (present(ERREUR)) then
                     91:        ERREUR = ERREUR_GAMMA
                     92:    end if
                     93: 
                     94:    return
                     95: end subroutine
                     96: 
                     97: ! vim: ts=4