Télécharger adevor.eso

Retour à la liste

Numérotation des lignes :

  1. C ADEVOR SOURCE PASCAL 09/02/16 21:15:00 6282
  2. SUBROUTINE ADEVOR(IPO1,IPO2,IRET,IPM)
  3. C
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. C
  7. C ===================================================================
  8. C = OPERATEUR : =
  9. C = SOMME (OU DIFFERENCE) DE DEUX OBJETS DE TYPE EVOLUTION = =
  10. C = - X1 ET X2 VARIENT DE FACON STRICTEMENT CROISSANTE =
  11. C = - Y1 ET Y2 SONT DE MEME NATURE =
  12. C = APPELE PAR ADEVOL =
  13. C = =
  14. C = REECRITURE DE L'ADDITION D'OBJETS EVOLUTION DE SOUS-TYPE REELS = =
  15. C = MODIFICATION AOUT 97 ELOI =
  16. C ===================================================================
  17. -INC SMEVOLL
  18. -INC SMLREEL
  19. POINTEUR MLRE1X.MLREEL,MLRE1Y.MLREEL
  20. POINTEUR MLRE2X.MLREEL,MLRE2Y.MLREEL
  21. POINTEUR MLREEX.MLREEL,MLREEY.MLREEL
  22. -INC CCOPTIO
  23. SEGMENT ILIS1(NL1)
  24. SEGMENT ILIS2(NL2)
  25. SEGMENT ITAB1(NP)
  26. SEGMENT ITAB2(NP)
  27. C
  28. PARAMETER (NCR=2,NOA=3)
  29. CHARACTER*72 TI
  30. CHARACTER*4 COMREEL(NCR),OKADI(NOA)
  31. COMREEL(1)='REEL'
  32. COMREEL(2)='HIST'
  33. OKADI(1)='REEL'
  34. OKADI(2)='HIST'
  35. OKADI(3)='MARQ'
  36. C
  37. IRET=0
  38. C
  39. MEVOL1=IPO1
  40. SEGACT MEVOL1
  41. MEVOL2=IPO2
  42. SEGACT MEVOL2
  43. C
  44. C ON TRAITE LE CAS DES OBJETS EVOLUTION DE SOUS-TYPE "REEL"
  45. C
  46. C LES DIFFERENTES COURBES DOIVENT ETRE DE SOIT DE TYPE "REEL",
  47. C SOIT DE TYPE "MARQ",
  48. C SOIT DE TYPE "HIST"
  49. C
  50. N1=MEVOL1.IEVOLL(/1)
  51. NL1=N1
  52. N2=MEVOL2.IEVOLL(/1)
  53. NL2=N2
  54. SEGINI,ILIS1
  55. SEGINI,ILIS2
  56. NRES10=0
  57. NRES20=0
  58. NDIF12=0
  59. C
  60. C ILIS1 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 1ERE EVOL
  61. C
  62. DO I0=1,NCR
  63. NRES1=0
  64. DO 1 I1=1,N1
  65. KEVOL1=MEVOL1.IEVOLL(I1)
  66. SEGACT KEVOL1
  67. CALL PLACE(OKADI,3,IPLAC,KEVOL1.NUMEVY)
  68. IF (IPLAC.EQ.0) THEN
  69. SEGDES KEVOL1
  70. SEGDES MEVOL1,MEVOL2
  71. SEGSUP ILIS1
  72. CALL ERREUR(871)
  73. RETURN
  74. ENDIF
  75. IF (KEVOL1.NUMEVY.EQ.COMREEL(I0)) THEN
  76. NRES1=NRES1+1
  77. NRES10=NRES10+1
  78. ILIS1(NRES10)=I1
  79. ENDIF
  80. SEGDES KEVOL1
  81. 1 CONTINUE
  82. C
  83. C ILIS2 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 2ND EVOL
  84. C
  85. NRES2=0
  86. DO 2 I2=1,N2
  87. KEVOL2=MEVOL2.IEVOLL(I2)
  88. SEGACT KEVOL2
  89. CALL PLACE(OKADI,3,IPLAC,KEVOL2.NUMEVY)
  90. IF (IPLAC.EQ.0) THEN
  91. SEGDES KEVOL2
  92. SEGDES MEVOL1,MEVOL2
  93. SEGSUP ILIS2
  94. CALL ERREUR(871)
  95. RETURN
  96. ENDIF
  97. IF (KEVOL2.NUMEVY.EQ.COMREEL(I0)) THEN
  98. NRES2=NRES2+1
  99. NRES20=NRES20+1
  100. ILIS2(NRES20)=I2
  101. ENDIF
  102. SEGDES KEVOL2
  103. 2 CONTINUE
  104. IF (NRES1.NE.NRES2) THEN
  105. NDIF12=1
  106. ENDIF
  107. ENDDO
  108. NL1=NRES10
  109. NL2=NRES20
  110. SEGADJ,ILIS1,ILIS2
  111. C
  112. C LES DEUX EVOLUTIONS DOIVENT AVOIR LE MEME NOMBRE DE COURBES DE TYPE
  113. C "REEL" OU "HIST"
  114. C
  115. IF (NDIF12.NE.0) THEN
  116. SEGDES MEVOL1,MEVOL2
  117. SEGSUP ILIS1,ILIS2
  118. IF (NRES10.EQ.NRES20) THEN
  119. CALL ERREUR(871)
  120. ELSE
  121. CALL ERREUR(870)
  122. ENDIF
  123. RETURN
  124. ENDIF
  125. C
  126. C LES DIFFERENTES ABSCISSES DOIVENT ETRE DES PROGRESSIONS STRICTEMENT
  127. C CROISSANTES
  128. C
  129. DO 3 I1=1,N1
  130. KEVOL1=MEVOL1.IEVOLL(I1)
  131. SEGACT KEVOL1
  132. MLREEL=KEVOL1.IPROGX
  133. SEGACT MLREEL
  134. NJG=PROG(/1)
  135. IF (NJG.GT.1) THEN
  136. VAL1=PROG(1)
  137. DO 4 IJG=2,NJG
  138. VAL2=PROG(IJG)
  139. IF (VAL2.LE.VAL1) THEN
  140. SEGDES MLREEL
  141. SEGDES KEVOL1
  142. SEGDES MEVOL1,MEVOL2
  143. SEGSUP ILIS1,ILIS2
  144. CALL ERREUR(872)
  145. RETURN
  146. ENDIF
  147. VAL1=VAL2
  148. 4 CONTINUE
  149. ENDIF
  150. SEGDES MLREEL
  151. SEGDES KEVOL1
  152. 3 CONTINUE
  153. C
  154. DO 5 I2=1,N2
  155. KEVOL2=MEVOL2.IEVOLL(I2)
  156. SEGACT KEVOL2
  157. MLREEL=KEVOL2.IPROGX
  158. SEGACT MLREEL
  159. NJG=PROG(/1)
  160. IF (NJG.GT.1) THEN
  161. VAL1=PROG(1)
  162. DO 6 IJG=2,NJG
  163. VAL2=PROG(IJG)
  164. IF (VAL2.LE.VAL1) THEN
  165. SEGDES MLREEL
  166. SEGDES KEVOL2
  167. SEGDES MEVOL1,MEVOL2
  168. SEGSUP ILIS1,ILIS2
  169. CALL ERREUR(872)
  170. RETURN
  171. ENDIF
  172. VAL1=VAL2
  173. 6 CONTINUE
  174. ENDIF
  175. SEGDES MLREEL
  176. SEGDES KEVOL2
  177. 5 CONTINUE
  178. C DD
  179. EPS=1.D-12
  180. C
  181. N=NRES10
  182. SEGINI MEVOLL
  183. C
  184. DO 7 IN=1,NRES10
  185. IL1=ILIS1(IN)
  186. KEVOL1=MEVOL1.IEVOLL(IL1)
  187. SEGACT KEVOL1
  188. MLRE1X=KEVOL1.IPROGX
  189. SEGACT MLRE1X
  190. NJG1=MLRE1X.PROG(/1)
  191. IL2=ILIS2(IN)
  192. KEVOL2=MEVOL2.IEVOLL(IL2)
  193. SEGACT KEVOL2
  194. MLRE2X=KEVOL2.IPROGX
  195. SEGACT MLRE2X
  196. NJG2=MLRE2X.PROG(/1)
  197. NP=MAX(NJG1,NJG2)
  198. SEGINI ITAB1
  199. SEGINI ITAB2
  200. IDEP=1
  201. NP3=0
  202. DO 8 IJG1=1,NJG1
  203. VAL1=MLRE1X.PROG(IJG1)
  204. DO 9 IJG2=IDEP,NJG2
  205. VAL2=MLRE2X.PROG(IJG2)
  206. IF ((ABS(VAL2 - VAL1)).LT.EPS) THEN
  207. NP3=NP3+1
  208. ITAB1(NP3)=IJG1
  209. ITAB2(NP3)=IJG2
  210. IDEP=IJG2
  211. GOTO 10
  212. ENDIF
  213. 9 CONTINUE
  214. 10 CONTINUE
  215. 8 CONTINUE
  216. IF (NP3.EQ.0) THEN
  217. SEGDES MLRE1X
  218. SEGDES MLRE2X
  219. SEGDES KEVOL1
  220. SEGDES KEVOL2
  221. SEGDES MEVOL1,MEVOL2
  222. SEGSUP ITAB1,ITAB2
  223. SEGSUP ILIS1,ILIS2
  224. IF (IN.GT.1) THEN
  225. DO 11 IIN=1,IN-1
  226. KEVOLL=IEVOLL(IIN)
  227. MLREEX=IPROGX
  228. SEGSUP MLREEX
  229. MLREEY=IPROGY
  230. SEGSUP MLREEY
  231. SEGSUP KEVOLL
  232. 11 CONTINUE
  233. ENDIF
  234. SEGSUP MEVOLL
  235. CALL ERREUR(310)
  236. RETURN
  237. ELSE
  238. NP=NP3
  239. SEGADJ ITAB1
  240. SEGADJ ITAB2
  241. JG=NP
  242. SEGINI MLREEX
  243. SEGINI MLREEY
  244. DO 12 IP=1,NP
  245. MLREEX.PROG(IP)=MLRE1X.PROG(ITAB1(IP))
  246. 12 CONTINUE
  247. C
  248. C IPM VAUT 1 DANS LE CAS DE L'ADDITION
  249. C IPM VAUT -1 DANS LE CAS DE LA SOUSTRACTION
  250. C
  251. MLRE1Y=KEVOL1.IPROGY
  252. SEGACT MLRE1Y
  253. MLRE2Y=KEVOL2.IPROGY
  254. SEGACT MLRE2Y
  255. IF (IPM.EQ.1) THEN
  256. DO 13 IP=1,NP
  257. MLREEY.PROG(IP)=
  258. # MLRE1Y.PROG(ITAB1(IP)) + MLRE2Y.PROG(ITAB2(IP))
  259. 13 CONTINUE
  260. ELSEIF (IPM.EQ.-1) THEN
  261. DO 14 IP=1,NP
  262. MLREEY.PROG(IP)=
  263. # MLRE1Y.PROG(ITAB1(IP)) - MLRE2Y.PROG(ITAB2(IP))
  264. 14 CONTINUE
  265. ENDIF
  266. SEGINI KEVOLL
  267. IPROGX=MLREEX
  268. IPROGY=MLREEY
  269. NUMEVX=KEVOL1.NUMEVX
  270. NUMEVY=KEVOL1.NUMEVY
  271. TYPX=KEVOL1.TYPX
  272. TYPY=KEVOL1.TYPY
  273. NOMEVX=KEVOL1.NOMEVX
  274. NOMEVY=KEVOL1.NOMEVY
  275. KEVTEX=KEVOL1.KEVTEX
  276. IEVOLL(IN)=KEVOLL
  277. SEGDES MLREEX
  278. SEGDES MLREEY
  279. SEGDES KEVOLL
  280. SEGDES MLRE1X
  281. SEGDES MLRE1Y
  282. SEGDES MLRE2X
  283. SEGDES MLRE2Y
  284. SEGDES KEVOL2
  285. ENDIF
  286. SEGDES KEVOL1
  287. SEGSUP ITAB1,ITAB2
  288. 7 CONTINUE
  289. SEGSUP ILIS1,ILIS2
  290. TI(1:72)=TITREE
  291. IEVTEX=TI
  292. ITYEVO=MEVOL1.ITYEVO
  293. IRET=MEVOLL
  294. SEGDES MEVOLL
  295. SEGDES MEVOL1
  296. SEGDES MEVOL2
  297. C
  298. RETURN
  299. END
  300.  
  301.  
  302.  
  303.  
  304.  

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