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: <<<<<<< combinaisons.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 la valeur de la combinaison C(n,k)
47: !===============================================================================
48: ! Entrées :
49: ! integer*8 N
50: ! integer*8 K
51: !-------------------------------------------------------------------------------
52: ! Sortie :
53: ! real*8 donnant C(N, K)
54: !-------------------------------------------------------------------------------
55: ! Effets de bord : néant
56: !===============================================================================
57:
58: subroutine F90COMBINAISON(N, K, RESULTAT) bind(C, name='f90combinaison')
59: use iso_c_binding
60: implicit none
61:
62: integer(rpl_integer8), intent(in) :: K
63: integer(rpl_integer8), intent(in) :: N
64:
65: real(rpl_real8), intent(out) :: RESULTAT
66:
67: real(rpl_real8) GAMMA_LN1
68: real(rpl_real8) GAMMA_LN2
69: real(rpl_real8) GAMMA_LN3
70:
71: interface
72: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
73: use iso_c_binding
74: implicit none
75: real(rpl_real8), intent(in) :: X
76: integer(rpl_integer8), intent(out), optional :: ERREUR
77: real(rpl_real8), intent(out) :: RESULTAT
78: real(rpl_real8), intent(out), optional :: SIGNE
79: end subroutine
80: end interface
81:
82: call F90GAMMALN(dble(N + 1), GAMMA_LN1)
83: call F90GAMMALN(dble(K + 1), GAMMA_LN2)
84: call F90GAMMALN(dble(N - K + 1), GAMMA_LN3)
85:
86: RESULTAT = exp(GAMMA_LN1 - GAMMA_LN2 - GAMMA_LN3)
87:
88: return
89: end subroutine
90:
91:
92: !===============================================================================
93: ! Fonction renvoyant la valeur de l'arrangement A(n,k)
94: !===============================================================================
95: ! Entrées :
96: ! integer*8 N
97: ! integer*8 K
98: !-------------------------------------------------------------------------------
99: ! Sortie :
100: ! real*8 donnant A(N, K)
101: !-------------------------------------------------------------------------------
102: ! Effets de bord : néant
103: !===============================================================================
104:
105: subroutine F90ARRANGEMENT(N, K, RESULTAT) bind(C, name='f90arrangement')
106: use iso_c_binding
107: implicit none
108:
109: integer(rpl_integer8), intent(in) :: K
110: integer(rpl_integer8), intent(in) :: N
111:
112: real(rpl_real8), intent(out) :: RESULTAT
113:
114: real(rpl_real8) GAMMA_LN1
115: real(rpl_real8) GAMMA_LN2
116:
117: interface
118: subroutine F90GAMMALN(X, RESULTAT, SIGNE, ERREUR)
119: use iso_c_binding
120: implicit none
121: real(rpl_real8), intent(in) :: X
122: integer(rpl_integer8), intent(out), optional :: ERREUR
123: real(rpl_real8), intent(out) :: RESULTAT
124: real(rpl_real8), intent(out), optional :: SIGNE
125: end subroutine
126: end interface
127:
128: call F90GAMMALN(dble(N + 1), GAMMA_LN1)
129: call F90GAMMALN(dble(N - K + 1), GAMMA_LN2)
130:
131: RESULTAT = exp(GAMMA_LN1 - GAMMA_LN2)
132:
133: return
134: end subroutine
135:
136: ! vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>