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