Return to fonctions_speciales.F90 CVS log

Up to [local] / rpl / src

Correction d'une réinitialisation sauvage de la pile des variables par niveau
dans la copie de la structure de description du processus. Cela corrige
la fonction SPAWN qui échouait sur un segmentation fault car la pile des
variables par niveau était vide alors même que l'arbre des variables contenait
bien les variables. Passage à la prerelease 2.

    1: !===============================================================================
    2: ! RPL/2 (R) version 4.1.0.prerelease.2
    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: 
   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