1: !===============================================================================
2: ! RPL/2 (R) version 4.0.9
3: ! Copyright (C) 1989-2010 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
CVSweb interface <joel.bertrand@systella.fr>