![]() ![]() | ![]() |
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 trigonometriques diverses 23: C=============================================================================== 24: 25: C------------------------------------------------------------------------------- 26: C Sinus (argument en radians) 27: C------------------------------------------------------------------------------- 28: 29: subroutine F77SIN(ARGUMENT, RESULTAT) 30: 31: implicit none 32: 33: complex*16 ARGUMENT 34: complex*16 RESULTAT 35: 36: RESULTAT = sin(ARGUMENT) 37: return 38: end 39: 40: C------------------------------------------------------------------------------- 41: C Arcsin (argument en radians) 42: C------------------------------------------------------------------------------- 43: 44: subroutine F77ASIN(ARGUMENT, RESULTAT) 45: 46: implicit none 47: 48: complex*16 ARGUMENT 49: complex*16 RESULTAT 50: 51: RESULTAT = (0,-1) * log(((0,1) * ARGUMENT) + sqrt(1 - 52: + (ARGUMENT ** 2))) 53: return 54: end 55: 56: C------------------------------------------------------------------------------- 57: C Cosinus (argument en radians) 58: C------------------------------------------------------------------------------- 59: 60: subroutine F77COS(ARGUMENT, RESULTAT) 61: 62: implicit none 63: 64: complex*16 ARGUMENT 65: complex*16 RESULTAT 66: 67: RESULTAT = cos(ARGUMENT) 68: return 69: end 70: 71: C------------------------------------------------------------------------------- 72: C Arccos (argument en radians) 73: C------------------------------------------------------------------------------- 74: 75: subroutine F77ACOS(ARGUMENT, RESULTAT) 76: 77: implicit none 78: 79: complex*16 ARGUMENT 80: complex*16 RESULTAT 81: 82: RESULTAT = (0,-1) * log(ARGUMENT + sqrt((ARGUMENT ** 2) - 1)) 83: return 84: end 85: 86: C------------------------------------------------------------------------------- 87: C Tangente (argument en radians) 88: C------------------------------------------------------------------------------- 89: 90: subroutine F77TAN(ARGUMENT, RESULTAT, ERREUR) 91: 92: implicit none 93: 94: complex*16 ARGUMENT 95: complex*16 COSINUS 96: complex*16 RESULTAT 97: 98: integer*4 ERREUR 99: 100: ERREUR = 0 101: 102: if (dimag(ARGUMENT).eq.0) then 103: RESULTAT = dtan(dble(ARGUMENT)) 104: else 105: COSINUS = cos(ARGUMENT) 106: 107: if (COSINUS.ne.0) then 108: RESULTAT = sin(ARGUMENT) / COSINUS 109: else 110: RESULTAT = 0 111: ERREUR = -1 112: end if 113: end if 114: return 115: end 116: 117: C------------------------------------------------------------------------------- 118: C Arctg (argument en radians) 119: C------------------------------------------------------------------------------- 120: 121: subroutine F77ATAN(ARGUMENT, RESULTAT, ERREUR) 122: 123: implicit none 124: 125: complex*16 ARGUMENT 126: complex*16 RESULTAT 127: 128: integer*4 ERREUR 129: 130: ERREUR = 0 131: 132: if ((ARGUMENT.ne.(0,1)).and.(ARGUMENT.ne.(0,-1))) then 133: RESULTAT = (0,.5) * log(((0,1) + ARGUMENT) / 134: + ((0,1) - ARGUMENT)) 135: else 136: RESULTAT = 0 137: ERREUR = -1 138: end if 139: return 140: end