Télécharger opobje.eso

Retour à la liste

Numérotation des lignes :

  1. C OPOBJE SOURCE CB215821 16/11/28 21:15:18 9202
  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.  
  63. C-INC CCREEL
  64. -INC CCOPTIO
  65.  
  66. BATAN2 = .FALSE.
  67.  
  68. IPO1=0
  69. IPO2=0
  70. IOUT=0
  71. IR =0
  72. IR1 =0
  73. IR2 =0
  74. XR =REAL(0.D0)
  75. XR1 =REAL(0.D0)
  76. XR2 =REAL(0.D0)
  77. XOUT=REAL(0.D0)
  78.  
  79. C IARGU = 0 pour ignorer I1 et FLO
  80. IARGU = 0
  81. I1 = 0
  82. FLO = REAL(0.D0)
  83. C
  84. C CAS DU MCHAML
  85. CALL LIROBJ('MCHAML',IPO1,0,IRETOU)
  86. IF (IRETOU.EQ.0) GOTO 10
  87. CALL LIROBJ('MCHAML',IPO2,0,IRETOU)
  88. CALL OPCHE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  89. IF(IRET .EQ. 1) THEN
  90. CALL ECROBJ('MCHAML',IPO2)
  91. ELSE
  92. CALL ERREUR(26)
  93. ENDIF
  94. RETURN
  95. C
  96. C CAS DU CHPOINT
  97. 10 CONTINUE
  98. CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  99. IF(IRETOU.EQ.0) GOTO 20
  100. CALL LIROBJ('CHPOINT',IPO2,0,IRETOU)
  101. IF (IRETOU.NE.0) THEN
  102. C Pour l'instant l'ATAN2 a 2 arguments est realisee en Sequentiel...
  103. CALL OPCHPO(IPO1,IOPERA,IPO2)
  104. CALL ECROBJ('CHPOINT',IPO2)
  105. ELSE
  106. CALL OPCHP1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  107. IF(IRET .EQ. 1) THEN
  108. CALL ECROBJ('CHPOINT',IPO2)
  109. ELSE
  110. CALL ERREUR(26)
  111. ENDIF
  112. ENDIF
  113. RETURN
  114. C
  115. C CAS D''UN LISTREEL
  116. 20 CONTINUE
  117. CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
  118. IF(IRETOU.EQ.0) GOTO 25
  119. CALL LIROBJ('LISTREEL',IPO2,0,IRETOU)
  120. CALL OPLRE1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  121. IF(IRET .EQ. 1) THEN
  122. CALL ECROBJ('LISTREEL',IPO2)
  123. ELSE
  124. CALL ERREUR(26)
  125. ENDIF
  126. RETURN
  127. C
  128. C CAS D''UN ENTIER
  129. 25 CONTINUE
  130. CALL LIRENT(IR1,0,IRETOU)
  131. IF(IRETOU.EQ.0) GO TO 30
  132. IF (IOPERA .EQ. 11) CALL LIRENT(IR2,0,IRETOU)
  133. IF(IRETOU.EQ.0) THEN
  134. CALL OPENTI(IR1,IR ,BATAN2,IOPERA,IOUT,XOUT)
  135. ELSE
  136. BATAN2 = .TRUE.
  137. CALL OPENTI(IR1,IR2,BATAN2,IOPERA,IOUT,XOUT)
  138. ENDIF
  139. C Resultat ENTIER attendu pour ABS (IOPERA = 14)
  140. IF (IOPERA .EQ. 14) THEN
  141. CALL ECRENT(IOUT)
  142. ELSE
  143. CALL ECRREE(XOUT)
  144. ENDIF
  145. RETURN
  146. C
  147. C CAS D''UN FLOTTANT
  148. 30 CONTINUE
  149. CALL LIRREE(XR1,0,IRETOU)
  150. IF(IRETOU.EQ.0) GO TO 40
  151. IF (IOPERA .EQ. 11) CALL LIRREE(XR2,0,IRETOU)
  152. IF(IRETOU.EQ.0) THEN
  153. CALL OPFLOT(XR1,XR ,IR,BATAN2,IOPERA,XOUT)
  154. ELSE
  155. BATAN2 = .TRUE.
  156. CALL OPFLOT(XR1,XR2,IR,BATAN2,IOPERA,XOUT)
  157. ENDIF
  158. CALL ECRREE(XOUT)
  159. RETURN
  160. C
  161. C EVOLUTION
  162. 40 CONTINUE
  163. CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  164. IF (IRETOU.EQ.0) GO TO 50
  165. C Pas tres clair de donner 2 arguments pour ATAN avec des EVOLUTIONS
  166. C Du coup un seul sera accepté
  167. C IF (IOPERA .EQ. 11) CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  168. CALL OPEVO1(IPO1,IOPERA,IARGU,I1,FLO,IPO2,IRET)
  169. IF(IRET .EQ. 1) THEN
  170. CALL ECROBJ('EVOLUTIO',IPO2)
  171. ELSE
  172. CALL ERREUR(26)
  173. ENDIF
  174. RETURN
  175. C
  176. C CAS D''UN LISTENTI
  177. 50 CONTINUE
  178. CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
  179. IF(IRETOU.EQ.0) GOTO 60
  180. IF (IOPERA .EQ. 11) CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
  181. CALL OPLENT(IPO1,IOPERA,IPO2)
  182. C Resultat LISTENTI attendu pour ABS (IOPERA = 14)
  183. IF (IOPERA .EQ. 14) THEN
  184. CALL ECROBJ('LISTENTI',IPO2)
  185. ELSE
  186. CALL ECROBJ('LISTREEL',IPO2)
  187. ENDIF
  188. RETURN
  189. C
  190. C PAS D''OPERANDE CORRECTE TROUVE
  191. 60 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  192. IF(IRETOU.NE.0) THEN
  193. CALL ERREUR (39)
  194. ELSE
  195. CALL ERREUR(533)
  196. ENDIF
  197.  
  198. RETURN
  199. END
  200.  
  201.  

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