Télécharger opobje.eso

Retour à la liste

Numérotation des lignes :

  1. C OPOBJE SOURCE CB215821 19/07/09 21:15:28 10252
  2. SUBROUTINE OPOBJE(IOPERA)
  3. C----------------------------------------------------------------------C
  4. C Cette source permet de faire les opérations elementaires sur
  5. C les OBJETS suivants :
  6. C - MCHAML
  7. C - CHPOINT
  8. C - LISTREEL
  9. C - FLOTTANT
  10. C - EVOLUTION (travail effectue sur les ordonnees seulement)
  11. C Nouveau 2014 ==> Certaines fonctions ne le geraient pas
  12. C - LISTENTI (Nouveau 2014 ==> Renvoie un LISTREEL sauf pour ABS)
  13. C - ENTIER (Nouveau 2014 ==> Renvoie un FLOTTANT sauf pour ABS)
  14. C
  15. C
  16. C ENTREE
  17. C Operations elementaires entre les OBJETS et un ENTIER ou FLOTTANT
  18. C IOPERA= 1 PUISSANCE
  19. C = 2 PRODUIT
  20. C = 3 ADDITION
  21. C = 4 SOUSTRACTION
  22. C = 5 DIVISION
  23. C
  24. C Fonctions sur les OBJETS
  25. C IOPERA= 6 COSINUS
  26. C = 7 SINUS
  27. C = 8 TANGENTE
  28. C = 9 ARCOSINUS
  29. C = 10 ARCSINUS
  30. C = 11 ARCTANGENTE
  31. C = 12 EXPONENTIELLE
  32. C = 13 LOGARITHME
  33. C = 14 VALEUR ABSOLUE
  34. C = 15 COSINUS HYPERBOLIQUE
  35. C = 16 SINUS HYPERBOLIQUE
  36. C = 17 TANGENTE HYPERBOLIQUE
  37. C = 18 ERF FONCTION D''ERRREUR DE GAUSS
  38. C = 19 ERFC FONCTION D''ERRREUR complementaire DE GAUSS (1-erf(x))
  39. C = 20 ARGCH (Fonction reciproque de COSH)
  40. C = 21 ARGSH (Fonction reciproque de SINH)
  41. C = 22 ARGTH (Fonction reciproque de TANH)
  42. C = 23 SIGN (renvoie -1 ou +1, resultat du meme type)
  43. C
  44. C IARGU = 0 ==> ARGUMENT I1 ET FLO INUTILISES
  45. C IARGU = 1 ==> ARGUMENT I1 UTILISE
  46. C IARGU = 11 ==> ARGUMENT I1 UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
  47. C IARGU = 2 ==> ARGUMENT FLO UTILISE
  48. C IARGU = 21 ==> ARGUMENT FLO UTILISE MAIS COMMUTE AVEC LE TABLEAU (SOUSTRACTION, DIVISION : POSITIONNEL)
  49. C
  50. C HISTORIQUE :
  51. C - CB215821 24/07/2014 --> Remise en conformite
  52. C - CB215821 10/12/2015 --> Parallelisation des operations sur les CHPOINTS
  53. C - CB215821 31/08/2016 --> Mise a jour des Commentaires
  54. C - CB215821 05/06/2018 --> Ajout de la fonction SIGN a un argument
  55. C----------------------------------------------------------------------C
  56.  
  57. IMPLICIT INTEGER(I-N)
  58. IMPLICIT REAL*8 (A-H,O-Z)
  59.  
  60. LOGICAL BATAN2
  61. INTEGER IPO1,IPO2,IR,IR1,IR2,IOUT,IOPERA
  62. REAL*8 XR,XR1,XR2,XOUT
  63. INTEGER IARGU
  64. INTEGER I1
  65. REAL*8 FLO
  66. INTEGER IRET
  67.  
  68.  
  69. C-INC CCREEL
  70. -INC CCOPTIO
  71. -INC SMLREEL
  72. -INC SMLENTI
  73.  
  74. BATAN2 = .FALSE.
  75.  
  76. IARGU = 0
  77. I1 = 0
  78. FLO =REAL(0.D0)
  79. IRET = 0
  80. IPO1 = 0
  81. IPO2 = 0
  82. IOUT = 0
  83. IR = 0
  84. IR1 = 0
  85. IR2 = 0
  86. XR =REAL(0.D0)
  87. XR1 =REAL(0.D0)
  88. XR2 =REAL(0.D0)
  89. XOUT=REAL(0.D0)
  90.  
  91. C IARGU = 0 pour ignorer I1 et FLO
  92. IARGU = 0
  93. I1 = 0
  94. FLO = REAL(0.D0)
  95. C
  96. C CAS DU MCHAML
  97. CALL LIROBJ('MCHAML ',IPO1,0,IRETOU)
  98. IF (IRETOU.EQ.0) GOTO 10
  99. CALL ACTOBJ('MCHAML ',IPO1,1)
  100. CALL LIROBJ('MCHAML ',IPO2,0,IRETOU)
  101. IF(IRETOU .NE. 0) CALL ACTOBJ('MCHAML ',IPO2,1)
  102. CALL OPCHE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  103. IF(IRET .EQ. 1) THEN
  104. CALL ACTOBJ('MCHAML ',IPO2,1)
  105. CALL ECROBJ('MCHAML ',IPO2)
  106. ELSE
  107. CALL ERREUR(26)
  108. ENDIF
  109. RETURN
  110. C
  111. C CAS DU CHPOINT
  112. 10 CONTINUE
  113. CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  114. IF(IRETOU.EQ.0) GOTO 20
  115. CALL ACTOBJ('CHPOINT ',IPO1,1)
  116. CALL LIROBJ('CHPOINT',IPO2,0,IRETOU)
  117. IF (IRETOU.NE.0) THEN
  118. CALL ACTOBJ('CHPOINT ',IPO2,1)
  119. C Pour l'instant l'ATAN2 a 2 arguments est realisee en Sequentiel...
  120. CALL OPCHPO(IPO1,IOPERA,IPO2)
  121. ELSE
  122. CALL OPCHP1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  123. IF(IRET .EQ. 0) THEN
  124. CALL ERREUR(26)
  125. RETURN
  126. ENDIF
  127. ENDIF
  128. CALL ACTOBJ('CHPOINT ',IPO2,1)
  129. CALL ECROBJ('CHPOINT ',IPO2)
  130. RETURN
  131. C
  132. C CAS D''UN LISTREEL
  133. 20 CONTINUE
  134. CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
  135. IF(IRETOU.EQ.0) GOTO 25
  136. MLREEL=IPO1
  137. SEGACT,MLREEL
  138. CALL LIROBJ('LISTREEL',IPO2,0,IRETOU)
  139. IF(IRETOU .NE. 0)THEN
  140. MLREEL=IPO2
  141. SEGACT,MLREEL
  142. ENDIF
  143. CALL OPLRE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  144. IF(IRET .EQ. 0) THEN
  145. CALL ERREUR(26)
  146. RETURN
  147. ENDIF
  148. MLREEL=IPO2
  149. SEGACT,MLREEL*NOMOD
  150. CALL ECROBJ('LISTREEL',IPO2)
  151. RETURN
  152. C
  153. C CAS D''UN ENTIER
  154. 25 CONTINUE
  155. CALL LIRENT(IR1,0,IRETOU)
  156. IF(IRETOU.EQ.0) GO TO 30
  157. IF (IOPERA .EQ. 11) CALL LIRENT(IR2,0,IRETOU)
  158. IF(IRETOU.EQ.0) THEN
  159. CALL OPENTI(IR1,IR ,BATAN2,IOPERA,IOUT,XOUT)
  160. ELSE
  161. BATAN2 = .TRUE.
  162. CALL OPENTI(IR1,IR2,BATAN2,IOPERA,IOUT,XOUT)
  163. ENDIF
  164. C Resultat ENTIER attendu pour ABS (IOPERA = 14 OU 23)
  165. IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
  166. CALL ECRENT(IOUT)
  167. ELSE
  168. CALL ECRREE(XOUT)
  169. ENDIF
  170. RETURN
  171. C
  172. C CAS D''UN FLOTTANT
  173. 30 CONTINUE
  174. CALL LIRREE(XR1,0,IRETOU)
  175. IF(IRETOU.EQ.0) GO TO 40
  176. IF (IOPERA .EQ. 11) CALL LIRREE(XR2,0,IRETOU)
  177. IF(IRETOU.EQ.0) THEN
  178. CALL OPFLOT(XR1,XR ,IR,BATAN2,IOPERA,XOUT)
  179. ELSE
  180. BATAN2 = .TRUE.
  181. CALL OPFLOT(XR1,XR2,IR,BATAN2,IOPERA,XOUT)
  182. ENDIF
  183. CALL ECRREE(XOUT)
  184. RETURN
  185. C
  186. C EVOLUTION
  187. 40 CONTINUE
  188. CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  189. IF (IRETOU.EQ.0) GO TO 50
  190. CALL ACTOBJ('EVOLUTIO',IPO1,1)
  191. C Pas tres clair de donner 2 arguments pour ATAN avec des EVOLUTIONS
  192. C Du coup un seul sera accepté
  193. C IF (IOPERA .EQ. 11) CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  194. CALL OPEVO1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  195. IF(IRET .EQ. 0) THEN
  196. CALL ERREUR(26)
  197. RETURN
  198. ENDIF
  199. CALL ACTOBJ('EVOLUTIO',IPO2,1)
  200. CALL ECROBJ('EVOLUTIO',IPO2)
  201. RETURN
  202. C
  203. C CAS D''UN LISTENTI
  204. 50 CONTINUE
  205. CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
  206. IF(IRETOU.EQ.0) GOTO 60
  207. MLENTI=IPO1
  208. SEGACT,MLENTI
  209. IF (IOPERA .EQ. 11) CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
  210. IF(IRETOU .NE. 0) THEN
  211. MLENTI=IPO2
  212. SEGACT,MLENTI
  213. ENDIF
  214. CALL OPLENT(IPO1,IOPERA,IPO2)
  215. C Resultat LISTENTI attendu pour ABS (IOPERA = 14 OU 23)
  216. IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
  217. MLENTI=IPO2
  218. SEGACT,MLENTI*NOMOD
  219. CALL ECROBJ('LISTENTI',IPO2)
  220. ELSE
  221. MLREEL=IPO2
  222. SEGACT,MLREEL*NOMOD
  223. CALL ECROBJ('LISTREEL',IPO2)
  224. ENDIF
  225. RETURN
  226. C
  227. C PAS D''OPERANDE CORRECTE TROUVE
  228. 60 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  229. IF(IRETOU.NE.0) THEN
  230. CALL ERREUR (39)
  231. ELSE
  232. CALL ERREUR(533)
  233. ENDIF
  234.  
  235. END
  236.  
  237.  
  238.  

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