1: !===============================================================================
2: ! RPL/2 (R) version 4.1.4
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 la valeur de la combinaison C(n,k)
26: !===============================================================================
27: ! Entrées :
28: ! integer*8 N
29: ! integer*8 K
30: !-------------------------------------------------------------------------------
31: ! Sortie :
32: ! real*8 donnant C(N, K)
33: !-------------------------------------------------------------------------------
34: ! Effets de bord : néant
35: !===============================================================================
36:
37: subroutine F90COMBINAISON(N, K, RESULTAT) bind(C, name='f90combinaison')
38: use iso_c_binding
39: implicit none
40:
41: integer(rpl_integer8), intent(in) :: K
42: integer(rpl_integer8), intent(in) :: N
43:
44: real(rpl_real8), intent(out) :: RESULTAT
45:
46: real(rpl_real8) GAMMA_LN1
47: real(rpl_real8) GAMMA_LN2
48: real(rpl_real8) GAMMA_LN3
49:
50: interface
51: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
52: use iso_c_binding
53: implicit none
54: real(rpl_real8), intent(in) :: X
55: integer(rpl_integer8), intent(out), optional :: ERREUR
56: real(rpl_real8), intent(out) :: RESULTAT
57: real(rpl_real8), intent(out), optional :: SIGNE
58: end subroutine
59: end interface
60:
61: call F90GAMMALN(dble(N + 1), GAMMA_LN1)
62: call F90GAMMALN(dble(K + 1), GAMMA_LN2)
63: call F90GAMMALN(dble(N - K + 1), GAMMA_LN3)
64:
65: RESULTAT = exp(GAMMA_LN1 - GAMMA_LN2 - GAMMA_LN3)
66:
67: return
68: end subroutine
69:
70:
71: !===============================================================================
72: ! Fonction renvoyant la valeur de l'arrangement A(n,k)
73: !===============================================================================
74: ! Entrées :
75: ! integer*8 N
76: ! integer*8 K
77: !-------------------------------------------------------------------------------
78: ! Sortie :
79: ! real*8 donnant A(N, K)
80: !-------------------------------------------------------------------------------
81: ! Effets de bord : néant
82: !===============================================================================
83:
84: subroutine F90ARRANGEMENT(N, K, RESULTAT) bind(C, name='f90arrangement')
85: use iso_c_binding
86: implicit none
87:
88: integer(rpl_integer8), intent(in) :: K
89: integer(rpl_integer8), intent(in) :: N
90:
91: real(rpl_real8), intent(out) :: RESULTAT
92:
93: real(rpl_real8) GAMMA_LN1
94: real(rpl_real8) GAMMA_LN2
95:
96: interface
97: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
98: use iso_c_binding
99: implicit none
100: real(rpl_real8), intent(in) :: X
101: integer(rpl_integer8), intent(out), optional :: ERREUR
102: real(rpl_real8), intent(out) :: RESULTAT
103: real(rpl_real8), intent(out), optional :: SIGNE
104: end subroutine
105: end interface
106:
107: call F90GAMMALN(dble(N + 1), GAMMA_LN1)
108: call F90GAMMALN(dble(N - K + 1), GAMMA_LN2)
109:
110: RESULTAT = exp(GAMMA_LN1 - GAMMA_LN2)
111:
112: return
113: end subroutine
114:
115: ! vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>