Télécharger opobje.eso

Retour à la liste

Numérotation des lignes :

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

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