Return to fonctions_speciales.F90 CVS log

Up to [local] / rpl / src

Ajout des premiers bouts de rplcas.

    1: !===============================================================================
    2: ! RPL/2 (R) version 4.1.0.prerelease.0
    3: ! Copyright (C) 1989-2011 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: <<<<<<< 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: !===============================================================================
   40: 
   41: 
   42: #include "rplftypes-conv.inc"
   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