File:
[local] /
rpl /
src /
bibliotheque_logarithmique.f
Revision
1.22:
download - view:
text,
annotated -
select for diffs -
revision graph
Tue Jun 21 15:26:27 2011 UTC (12 years, 10 months ago) by
bertrand
Branches:
MAIN
CVS tags:
HEAD
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: C===============================================================================
2: C RPL/2 (R) version 4.1.0.prerelease.2
3: C Copyright (C) 1989-2011 Dr. BERTRAND Joël
4: C
5: C This file is part of RPL/2.
6: C
7: C RPL/2 is free software; you can redistribute it and/or modify it
8: C under the terms of the CeCILL V2 License as published by the french
9: C CEA, CNRS and INRIA.
10: C
11: C RPL/2 is distributed in the hope that it will be useful, but WITHOUT
12: C ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13: C FITNESS FOR A PARTICULAR PURPOSE. See the CeCILL V2 License
14: C for more details.
15: C
16: C You should have received a copy of the CeCILL License
17: C along with RPL/2. If not, write to info@cecill.info.
18: C===============================================================================
19:
20:
21: C===============================================================================
22: C Fonctions logarithmiques diverses
23: C===============================================================================
24:
25: C-------------------------------------------------------------------------------
26: C Logarithme naturel
27: C-------------------------------------------------------------------------------
28:
29: subroutine F77LNIP(ARGUMENT, RESULTAT, ERREUR)
30:
31: implicit none
32:
33: integer*4 ERREUR
34:
35: integer*8 ARGUMENT
36:
37: real*8 RESULTAT
38:
39: if (ARGUMENT.ne.0) then
40: RESULTAT = log(dble(ARGUMENT))
41: ERREUR = 0
42: else
43: RESULTAT = 0
44: ERREUR = -1
45: end if
46: return
47: end
48:
49: subroutine F77LNIN(ARGUMENT, RESULTAT, ERREUR)
50:
51: implicit none
52:
53: complex*16 RESULTAT
54:
55: integer*4 ERREUR
56:
57: integer*8 ARGUMENT
58:
59: if (ARGUMENT.ne.0) then
60: RESULTAT = log(dble(ARGUMENT) + (0,0))
61: ERREUR = 0
62: else
63: RESULTAT = 0
64: ERREUR = -1
65: end if
66: return
67: end
68:
69: subroutine F77LNRP(ARGUMENT, RESULTAT, ERREUR)
70:
71: implicit none
72:
73: integer*4 ERREUR
74:
75: real*8 ARGUMENT
76: real*8 RESULTAT
77:
78: if (ARGUMENT.ne.0) then
79: RESULTAT = log(ARGUMENT)
80: ERREUR = 0
81: else
82: RESULTAT = 0
83: ERREUR = -1
84: end if
85: return
86: end
87:
88: subroutine F77LNRN(ARGUMENT, RESULTAT, ERREUR)
89:
90: implicit none
91:
92: complex*16 RESULTAT
93:
94: integer*4 ERREUR
95:
96: real*8 ARGUMENT
97:
98: if (ARGUMENT.ne.0) then
99: RESULTAT = log(ARGUMENT + (0,0))
100: ERREUR = 0
101: else
102: RESULTAT = 0
103: ERREUR = -1
104: end if
105: return
106: end
107:
108: subroutine F77LNC(ARGUMENT, RESULTAT, ERREUR)
109:
110: implicit none
111:
112: complex*16 ARGUMENT
113: complex*16 RESULTAT
114:
115: integer*4 ERREUR
116:
117: if (ARGUMENT.ne.0) then
118: RESULTAT = log(ARGUMENT)
119: ERREUR = 0
120: else
121: RESULTAT = 0
122: ERREUR = -1
123: end if
124: return
125: end
126:
127: C-------------------------------------------------------------------------------
128: C Logarithme vulgaire
129: C-------------------------------------------------------------------------------
130:
131: subroutine F77LOGIP(ARGUMENT, RESULTAT, ERREUR)
132:
133: implicit none
134:
135: integer*4 ERREUR
136:
137: integer*8 ARGUMENT
138:
139: real*8 RESULTAT
140:
141: if (ARGUMENT.ne.0) then
142: RESULTAT = log(dble(ARGUMENT)) / log(1D1)
143: ERREUR = 0
144: else
145: RESULTAT = 0
146: ERREUR = -1
147: end if
148: return
149: end
150:
151: subroutine F77LOGIN(ARGUMENT, RESULTAT, ERREUR)
152:
153: implicit none
154:
155: complex*16 RESULTAT
156:
157: integer*4 ERREUR
158:
159: integer*8 ARGUMENT
160:
161: if (ARGUMENT.ne.0) then
162: RESULTAT = log(dble(ARGUMENT) + (0,0)) / log(1D1)
163: ERREUR = 0
164: else
165: RESULTAT = 0
166: ERREUR = -1
167: end if
168: return
169: end
170:
171: subroutine F77LOGRP(ARGUMENT, RESULTAT, ERREUR)
172:
173: implicit none
174:
175: integer*4 ERREUR
176:
177: real*8 ARGUMENT
178: real*8 RESULTAT
179:
180: if (ARGUMENT.ne.0) then
181: RESULTAT = log(ARGUMENT) / log(1D1)
182: ERREUR = 0
183: else
184: RESULTAT = 0
185: ERREUR = -1
186: end if
187: return
188: end
189:
190: subroutine F77LOGRN(ARGUMENT, RESULTAT, ERREUR)
191:
192: implicit none
193:
194: complex*16 RESULTAT
195: integer*4 ERREUR
196:
197: real*8 ARGUMENT
198:
199: if (ARGUMENT.ne.0) then
200: RESULTAT = log(ARGUMENT + (0,0)) / log(1D1)
201: ERREUR = 0
202: else
203: RESULTAT = 0
204: ERREUR = -1
205: end if
206: return
207: end
208:
209: subroutine F77LOGC(ARGUMENT, RESULTAT, ERREUR)
210:
211: implicit none
212:
213: complex*16 ARGUMENT
214: complex*16 RESULTAT
215:
216: integer*4 ERREUR
217:
218: if (ARGUMENT.ne.0) then
219: RESULTAT = log(ARGUMENT) / log(1D1)
220: ERREUR = 0
221: else
222: RESULTAT = 0
223: ERREUR = -1
224: end if
225: return
226: end
227:
228: C-------------------------------------------------------------------------------
229: C Sinus hyperbolique
230: C-------------------------------------------------------------------------------
231:
232: subroutine F77SINH(ARGUMENT, RESULTAT)
233:
234: implicit none
235:
236: complex*16 ARGUMENT
237: complex*16 RESULTAT
238:
239: RESULTAT = (exp(ARGUMENT) - exp(-ARGUMENT)) / 2
240: return
241: end
242:
243: subroutine F77ASINHC(ARGUMENT, RESULTAT)
244:
245: implicit none
246:
247: complex*16 ARGUMENT
248: complex*16 RESULTAT
249:
250: RESULTAT = log(ARGUMENT + sqrt((ARGUMENT ** 2) + 1))
251: return
252: end
253:
254: subroutine F77ASINHI(ARGUMENT, RESULTAT)
255:
256: implicit none
257:
258: integer*8 ARGUMENT
259: real*8 RESULTAT
260:
261: RESULTAT = log(ARGUMENT + sqrt((dble(ARGUMENT) ** 2) + 1))
262: return
263: end
264:
265: subroutine F77ASINHR(ARGUMENT, RESULTAT)
266:
267: implicit none
268:
269: real*8 ARGUMENT
270: real*8 RESULTAT
271:
272: RESULTAT = log(ARGUMENT + sqrt((dble(ARGUMENT) ** 2) + 1))
273: return
274: end
275:
276: C-------------------------------------------------------------------------------
277: C Cosinus hyperbolique
278: C-------------------------------------------------------------------------------
279:
280: subroutine F77COSH(ARGUMENT, RESULTAT)
281:
282: implicit none
283:
284: complex*16 ARGUMENT
285: complex*16 RESULTAT
286:
287: RESULTAT = (exp(ARGUMENT) + exp(-ARGUMENT)) / 2
288: return
289: end
290:
291: subroutine F77ACOSHC(ARGUMENT, RESULTAT)
292:
293: implicit none
294:
295: complex*16 ARGUMENT
296: complex*16 RESULTAT
297:
298: RESULTAT = log(ARGUMENT + sqrt((ARGUMENT ** 2) - 1))
299: return
300: end
301:
302: subroutine F77ACOSHI(ARGUMENT, RESULTAT)
303:
304: implicit none
305:
306: integer*8 ARGUMENT
307: real*8 RESULTAT
308:
309: RESULTAT = log(ARGUMENT + sqrt((dble(ARGUMENT) ** 2) - 1))
310: return
311: end
312:
313: subroutine F77ACOSHR(ARGUMENT, RESULTAT)
314:
315: implicit none
316:
317: real*8 ARGUMENT
318: real*8 RESULTAT
319:
320: RESULTAT = log(ARGUMENT + sqrt((dble(ARGUMENT) ** 2) - 1))
321: return
322: end
323:
324: C-------------------------------------------------------------------------------
325: C Tangente hyperbolique
326: C-------------------------------------------------------------------------------
327:
328: subroutine F77TANH(ARGUMENT, RESULTAT, ERREUR)
329:
330: implicit none
331:
332: complex*16 ARGUMENT
333: complex*16 COSINUSH
334: complex*16 RESULTAT
335: complex*16 SINUSH
336:
337: integer*4 ERREUR
338:
339: ERREUR = 0
340:
341: if (dimag(ARGUMENT).eq.0) then
342: RESULTAT = dtan(dble(ARGUMENT))
343: else
344: call F77COSH(ARGUMENT, COSINUSH)
345:
346: if (COSINUSH.ne.0) then
347: call F77SINH(ARGUMENT, SINUSH)
348: RESULTAT = SINUSH / COSINUSH
349: else
350: RESULTAT = 0
351: ERREUR = -1
352: end if
353: end if
354: return
355: end
356:
357: subroutine F77ATANHC(ARGUMENT, RESULTAT)
358:
359: implicit none
360:
361: complex*16 ARGUMENT
362: complex*16 RESULTAT
363:
364: RESULTAT = log((1 + ARGUMENT) / (1 - ARGUMENT)) / 2
365: return
366: end
367:
368: subroutine F77ATANHI(ARGUMENT, RESULTAT)
369:
370: implicit none
371:
372: integer*8 ARGUMENT
373: real*8 RESULTAT
374:
375: RESULTAT = log((1 + dble(ARGUMENT)) / (1 - dble(ARGUMENT))) / 2
376: return
377: end
378:
379: subroutine F77ATANHR(ARGUMENT, RESULTAT)
380:
381: implicit none
382:
383: real*8 ARGUMENT
384: real*8 RESULTAT
385:
386: RESULTAT = log((1 + ARGUMENT) / (1 - ARGUMENT)) / 2
387: return
388: end
389:
390: C-------------------------------------------------------------------------------
391: C Exponentielle complexe
392: C-------------------------------------------------------------------------------
393:
394: subroutine F77EXPC(ARGUMENT, RESULTAT)
395:
396: implicit none
397:
398: complex*16 ARGUMENT
399: complex*16 RESULTAT
400:
401: RESULTAT = exp(ARGUMENT)
402: return
403: end
404:
405: C-------------------------------------------------------------------------------
406: C Alog complexe
407: C-------------------------------------------------------------------------------
408:
409: subroutine F77ALOGC(ARGUMENT, RESULTAT)
410:
411: implicit none
412:
413: complex*16 ARGUMENT
414: complex*16 RESULTAT
415:
416: RESULTAT = 10 ** ARGUMENT
417: return
418: end
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to bibliotheque_logarithmique.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / src