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
CVSweb interface <joel.bertrand@systella.fr>