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.  
  71. -INC PPARAM
  72. -INC CCOPTIO
  73. -INC SMLREEL
  74. -INC SMLENTI
  75.  
  76. BATAN2 = .FALSE.
  77.  
  78. IARGU = 0
  79. I1 = 0
  80. FLO =REAL(0.D0)
  81. IRET = 0
  82. IPO1 = 0
  83. IPO2 = 0
  84. IOUT = 0
  85. IR = 0
  86. IR1 = 0
  87. IR2 = 0
  88. XR =REAL(0.D0)
  89. XR1 =REAL(0.D0)
  90. XR2 =REAL(0.D0)
  91. XOUT=REAL(0.D0)
  92.  
  93. C IARGU = 0 pour ignorer I1 et FLO
  94. IARGU = 0
  95. I1 = 0
  96. FLO = REAL(0.D0)
  97. C
  98. C CAS DU MCHAML
  99. CALL LIROBJ('MCHAML ',IPO1,0,IRETOU)
  100. IF (IRETOU.EQ.0) GOTO 10
  101. CALL ACTOBJ('MCHAML ',IPO1,1)
  102. CALL LIROBJ('MCHAML ',IPO2,0,IRETOU)
  103. IF(IRETOU .NE. 0) CALL ACTOBJ('MCHAML ',IPO2,1)
  104. CALL OPCHE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  105. IF(IRET .EQ. 1) THEN
  106. CALL ACTOBJ('MCHAML ',IPO2,1)
  107. CALL ECROBJ('MCHAML ',IPO2)
  108. ELSE
  109. CALL ERREUR(26)
  110. ENDIF
  111. RETURN
  112. C
  113. C CAS DU CHPOINT
  114. 10 CONTINUE
  115. CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  116. IF(IRETOU.EQ.0) GOTO 20
  117. CALL ACTOBJ('CHPOINT ',IPO1,1)
  118. CALL LIROBJ('CHPOINT',IPO2,0,IRETOU)
  119. IF (IRETOU.NE.0) THEN
  120. CALL ACTOBJ('CHPOINT ',IPO2,1)
  121. C Pour l'instant l'ATAN2 a 2 arguments est realisee en Sequentiel...
  122. CALL OPCHPO(IPO1,IOPERA,IPO2)
  123. ELSE
  124. CALL OPCHP1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  125. IF(IRET .EQ. 0) THEN
  126. CALL ERREUR(26)
  127. RETURN
  128. ENDIF
  129. ENDIF
  130. CALL ACTOBJ('CHPOINT ',IPO2,1)
  131. CALL ECROBJ('CHPOINT ',IPO2)
  132. RETURN
  133. C
  134. C CAS D''UN LISTREEL
  135. 20 CONTINUE
  136. CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
  137. IF(IRETOU.EQ.0) GOTO 25
  138. MLREEL=IPO1
  139. SEGACT,MLREEL
  140. CALL LIROBJ('LISTREEL',IPO2,0,IRETOU)
  141. IF(IRETOU .NE. 0)THEN
  142. MLREEL=IPO2
  143. SEGACT,MLREEL
  144. ENDIF
  145. CALL OPLRE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  146. IF(IRET .EQ. 0) THEN
  147. CALL ERREUR(26)
  148. RETURN
  149. ENDIF
  150. MLREEL=IPO2
  151. SEGACT,MLREEL*NOMOD
  152. CALL ECROBJ('LISTREEL',IPO2)
  153. RETURN
  154. C
  155. C CAS D''UN ENTIER
  156. 25 CONTINUE
  157. CALL LIRENT(IR1,0,IRETOU)
  158. IF(IRETOU.EQ.0) GO TO 30
  159. IF (IOPERA .EQ. 11) CALL LIRENT(IR2,0,IRETOU)
  160. IF(IRETOU.EQ.0) THEN
  161. CALL OPENTI(IR1,IR ,BATAN2,IOPERA,IOUT,XOUT)
  162. ELSE
  163. BATAN2 = .TRUE.
  164. CALL OPENTI(IR1,IR2,BATAN2,IOPERA,IOUT,XOUT)
  165. ENDIF
  166. C Resultat ENTIER attendu pour ABS (IOPERA = 14 OU 23)
  167. IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
  168. CALL ECRENT(IOUT)
  169. ELSE
  170. CALL ECRREE(XOUT)
  171. ENDIF
  172. RETURN
  173. C
  174. C CAS D''UN FLOTTANT
  175. 30 CONTINUE
  176. CALL LIRREE(XR1,0,IRETOU)
  177. IF(IRETOU.EQ.0) GO TO 40
  178. IF (IOPERA .EQ. 11) CALL LIRREE(XR2,0,IRETOU)
  179. IF(IRETOU.EQ.0) THEN
  180. CALL OPFLOT(XR1,XR ,IR,BATAN2,IOPERA,XOUT)
  181. ELSE
  182. BATAN2 = .TRUE.
  183. CALL OPFLOT(XR1,XR2,IR,BATAN2,IOPERA,XOUT)
  184. ENDIF
  185. CALL ECRREE(XOUT)
  186. RETURN
  187. C
  188. C EVOLUTION
  189. 40 CONTINUE
  190. CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  191. IF (IRETOU.EQ.0) GO TO 50
  192. CALL ACTOBJ('EVOLUTIO',IPO1,1)
  193. C Pas tres clair de donner 2 arguments pour ATAN avec des EVOLUTIONS
  194. C Du coup un seul sera accepté
  195. C IF (IOPERA .EQ. 11) CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  196. CALL OPEVO1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  197. IF(IRET .EQ. 0) THEN
  198. CALL ERREUR(26)
  199. RETURN
  200. ENDIF
  201. CALL ACTOBJ('EVOLUTIO',IPO2,1)
  202. CALL ECROBJ('EVOLUTIO',IPO2)
  203. RETURN
  204. C
  205. C CAS D''UN LISTENTI
  206. 50 CONTINUE
  207. CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
  208. IF(IRETOU.EQ.0) GOTO 60
  209. MLENTI=IPO1
  210. SEGACT,MLENTI
  211. IF (IOPERA .EQ. 11) CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
  212. IF(IRETOU .NE. 0) THEN
  213. MLENTI=IPO2
  214. SEGACT,MLENTI
  215. ENDIF
  216. CALL OPLENT(IPO1,IOPERA,IPO2)
  217. C Resultat LISTENTI attendu pour ABS (IOPERA = 14 OU 23)
  218. IF (IOPERA .EQ. 14 .OR. IOPERA .EQ. 23) THEN
  219. MLENTI=IPO2
  220. SEGACT,MLENTI*NOMOD
  221. CALL ECROBJ('LISTENTI',IPO2)
  222. ELSE
  223. MLREEL=IPO2
  224. SEGACT,MLREEL*NOMOD
  225. CALL ECROBJ('LISTREEL',IPO2)
  226. ENDIF
  227. RETURN
  228. C
  229. C PAS D''OPERANDE CORRECTE TROUVE
  230. 60 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  231. IF(IRETOU.NE.0) THEN
  232. CALL ERREUR (39)
  233. ELSE
  234. CALL ERREUR(533)
  235. ENDIF
  236.  
  237. END
  238.  
  239.  
  240.  

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