![]() ![]() | ![]() |
Passage de la branche 4.1 en branche stable.
1: C=============================================================================== 2: C RPL/2 (R) version 4.1.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: 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