Télécharger openti.eso

Retour à la liste

Numérotation des lignes :

  1. C OPENTI SOURCE GOUNAND 19/07/23 21:15:15 10267
  2. SUBROUTINE OPENTI(IIN1,IIN2,BATAN2,IOPERA,IOUT,XOUT)
  3. C=======================================================================
  4. C EFFECTUE DIVERSES OPERATIONS SUR LES ENTIERS
  5. C=======================================================================
  6. C ENTREES
  7. C IIN1= ENTIER sur lequel on effectue l'operation
  8. C IIN2= deuxieme argument ENTIER pour l'operation ATAN2
  9. C
  10. C BATAN2= TRUE Booleen permettant de faire l'operation ATAN2
  11. C = FALSE Booleen permettant de faire l'operation ATAN
  12. C IOPERA= 1 COSINUS
  13. C = 2 SINUS
  14. C = 3 TANGENTE
  15. C = 4 ARCOSINUS
  16. C = 5 ARCSINUS
  17. C = 6 ARCTANGENTE
  18. C = 7 EXPONENTIELLE
  19. C = 8 LOGARITHME
  20. C = 9 VALEUR ABSOLUE
  21. C = 10 COSINUS HYPERBOLIQUE
  22. C = 11 SINUS HYPERBOLIQUE
  23. C = 12 TANGENTE HYPERBOLIQUE
  24. C = 13 ERF FONCTION D'ERRREUR DE GAUSS
  25. C = 14 ERFC FONCTION D'ERRREUR complementaire DE GAUSS (1-erf(x))
  26. C = 15 ARGCH (Fonction reciproque de COSH)
  27. C = 16 ARGSH (Fonction reciproque de SINH)
  28. C = 17 ARGTH (Fonction reciproque de TANH)
  29. C = 18 SIGN(1.D0,IIN1)
  30. C
  31. C = 19 PRODUIT IIN1 * IIN2
  32. C = 20 DIVISION IIN1 / IIN2
  33. C = 21 PUISSANCE IIN1 ** IIN2
  34. C
  35. C
  36. C SORTIES
  37. C IOUT=ENTIER RESULTAT
  38. C XOUT=FLOTTANT RESULTAT
  39. C
  40. C HISTORIQUE :
  41. C - CB215821 2014 --> Creation
  42. C - CB215821 05/06/2018 --> Ajout de la fonction SIGN a un argument
  43. C
  44. C=======================================================================
  45.  
  46. IMPLICIT INTEGER(I-N)
  47. IMPLICIT REAL*8(A-H,O-Z)
  48.  
  49. LOGICAL BATAN2
  50. INTEGER IOPERA,IIN1,IIN2,IOUT
  51. REAL*8 XOUT,XCONV,XVNOC
  52.  
  53.  
  54. -INC PPARAM
  55. -INC CCOPTIO
  56. -INC CCREEL
  57. C
  58. IOUT = 0
  59. XOUT = XZERO
  60. C
  61. GOTO(1 ,2 ,3 ,4 ,5 ,6 ,7 ,8 ,9 ,10,11,12,13,14,15,
  62. & 16,17,18,19,20,21),(IOPERA-5)
  63. C
  64. C COSINUS
  65. 1 CONTINUE
  66. XCONV = XPI / 180.D0
  67. XOUT=COS(XCONV*REAL(IIN1))
  68. GOTO 166
  69. C
  70. C SINUS
  71. 2 CONTINUE
  72. XCONV = XPI / 180.D0
  73. XOUT=SIN(XCONV*REAL(IIN1))
  74. GOTO 166
  75. C
  76. C TANGENTE
  77. 3 CONTINUE
  78. XCONV = XPI / 180.D0
  79. C Le cas 90° +/- n*180° n'est pas défini pour les Entiers
  80. C Pour les réels on laisse couler (Voir opflot.eso)
  81. IF ((MOD(IIN1-90,180).EQ.0)) THEN
  82. INTERR(1)=IIN1
  83. CALL ERREUR(36)
  84. ELSE
  85. XOUT=TAN(XCONV*REAL(IIN1))
  86. ENDIF
  87. GOTO 166
  88. C
  89. C ARCOSINUS
  90. 4 CONTINUE
  91. XVNOC = 180.D0 / XPI
  92. IF ( (IIN1 .GE. -1) .AND. (IIN1 .LE. 1)) THEN
  93. XOUT=XVNOC*ACOS(REAL(IIN1))
  94. ELSE
  95. GOTO 165
  96. ENDIF
  97. GOTO 166
  98. C
  99. C ARCSINUS
  100. 5 CONTINUE
  101. XVNOC = 180.D0 / XPI
  102. IF ( (IIN1 .GE. -1) .AND. (IIN1 .LE. 1)) THEN
  103. XOUT=XVNOC*ASIN(REAL(IIN1))
  104. ELSE
  105. GOTO 165
  106. ENDIF
  107. GOTO 166
  108. C
  109. C ARCTANGENTE
  110. 6 CONTINUE
  111. XVNOC = 180.D0 / XPI
  112.  
  113.  
  114. IF (BATAN2 .EQV. .TRUE.) THEN
  115. IF ( IIN2 .EQ. 0 ) THEN
  116. IF ( IIN1 .GT. 0 ) THEN
  117. XOUT = 90.D0
  118. ELSEIF ( IIN1 .LT. 0 ) THEN
  119. XOUT = -90
  120. ELSE
  121. INTERR(1)=IIN1
  122. CALL ERREUR(36)
  123. ENDIF
  124. ELSE
  125. XOUT=XVNOC*ATAN2(REAL(IIN1),REAL(IIN2))
  126. ENDIF
  127. ELSE
  128. XOUT=XVNOC*ATAN(REAL(IIN1))
  129. ENDIF
  130. GOTO 166
  131. C
  132. C EXPONENTIELLE
  133. 7 CONTINUE
  134. XOUT=EXP(REAL(IIN1))
  135. GOTO 166
  136. C
  137. C LOGARITHME
  138. 8 CONTINUE
  139. IF ( IIN1 .GT. 0) THEN
  140. XOUT=LOG(REAL(IIN1))
  141. ELSE
  142. GOTO 165
  143. ENDIF
  144. GOTO 166
  145. C
  146. C VALEUR ABSOLUE
  147. 9 CONTINUE
  148. IOUT=ABS(IIN1)
  149. RETURN
  150. C
  151. C COSINUS HYPERBOLIQUE
  152. 10 CONTINUE
  153. XOUT=COSH(REAL(IIN1))
  154. GOTO 166
  155. C
  156. C SINUS HYPERBOLIQUE
  157. 11 CONTINUE
  158. XOUT=SINH(REAL(IIN1))
  159. GOTO 166
  160. C
  161. C TANGENTE HYPERBOLIQUE
  162. 12 CONTINUE
  163. XOUT=TANH(REAL(IIN1))
  164. GOTO 166
  165. C
  166. C FONCTION D'ERREUR ERF
  167. 13 CONTINUE
  168. XOUT=ERF(REAL(IIN1))
  169. GOTO 166
  170. C
  171. C ERFC (Complementaire de ERF --> 1-ERF(x) )
  172. 14 CONTINUE
  173. XOUT=ERFC(REAL(IIN1))
  174. GOTO 166
  175. C
  176. C ARGCH (Reciproque de COSINUS HYPERBOLIQUE)
  177. 15 CONTINUE
  178. IF ( IIN1 .GE. 1 ) THEN
  179. XIN=REAL(IIN1)
  180. XOUT=LOG(XIN + SQRT(XIN*XIN-1.D0))
  181. ELSE
  182. GOTO 165
  183. ENDIF
  184. GOTO 166
  185. C
  186. C ARGSH (Reciproque de SINUS HYPERBOLIQUE)
  187. 16 CONTINUE
  188. XIN=REAL(IIN1)
  189. XOUT=LOG(XIN + SQRT(XIN*XIN+1.D0))
  190. GOTO 166
  191. C
  192. C ARGTH (Reciproque de TANGENTE HYPERBOLIQUE)
  193. 17 CONTINUE
  194. XIN=REAL(IIN1)
  195. IF ( ABS(IIN1) .NE. 1 ) THEN
  196. XOUT=0.5D0 * LOG((1.D0+XIN)/(1.D0-XIN))
  197. ELSE
  198. GOTO 165
  199. ENDIF
  200. GOTO 166
  201.  
  202. C 'SIGN' (SIGN a un argument)
  203. 18 CONTINUE
  204. IOUT=SIGN(1,IIN1)
  205. RETURN
  206. C
  207. C '*' (Produit de 2 ENTIERS)
  208. 19 CONTINUE
  209. IOUT = IIN1 * IIN2
  210. RETURN
  211. C
  212. C '/' (Division de 2 ENTIERS)
  213. 20 CONTINUE
  214. IF (IIN2 .EQ. 0) THEN
  215. GOTO 165
  216. ELSE
  217. IOUT = IIN1 / IIN2
  218. RETURN
  219. ENDIF
  220.  
  221. C '**' (Puissance de 2 ENTIERS)
  222. 21 CONTINUE
  223. IF ((IIN1 .EQ. 0) .AND. (IIN2.LT.0)) THEN
  224. GOTO 165
  225. ELSE
  226. IOUT = IIN1 ** IIN2
  227. RETURN
  228. ENDIF
  229.  
  230. C Arrivee ici en cas d'erreur sur le domaine de validite de l'operation
  231. 165 CONTINUE
  232. INTERR(1)=IIN1
  233. CALL ERREUR(36)
  234. RETURN
  235.  
  236. C Arrivee ici apres avoir effectue l'operation
  237. 166 CONTINUE
  238. C Verification que le resultat obtenu est bien un nombre (Pas Nan ni Inf)
  239. IF (.NOT. (ABS(XOUT) .LE. XGRAND)) THEN
  240. INTERR(1)=IIN1
  241. CALL ERREUR(36)
  242. ENDIF
  243. RETURN
  244. END
  245.  
  246.  
  247.  
  248.  
  249.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales