Télécharger adevor.eso

Retour à la liste

Numérotation des lignes :

  1. C ADEVOR SOURCE PV 19/02/07 21:15:00 10108
  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 1997 ELOI =
  16. C = MODIFICATION DECE 2018 CB =
  17. C ===================================================================
  18. -INC SMEVOLL
  19. -INC SMLREEL
  20. POINTEUR MLRE1X.MLREEL,MLRE1Y.MLREEL
  21. POINTEUR MLRE2X.MLREEL,MLRE2Y.MLREEL
  22. POINTEUR MLREEX.MLREEL,MLREEY.MLREEL
  23. POINTEUR MLREE4.MLREEL
  24. -INC CCOPTIO
  25. -INC CCREEL
  26. SEGMENT ILIS1(NL1)
  27. SEGMENT ILIS2(NL2)
  28.  
  29. SEGMENT SPOI
  30. INTEGER IPOIX(NL1,3)
  31. INTEGER IPOIY(NL1,3)
  32. C IPOIX : Liste des LISTREELS en ABSCISSES pour EVOL1, EVOL2 et EVOL_resultat
  33. C IPOIY : Liste des LISTREELS en ORDONNEES pour EVOL1, EVOL2 et EVOL_resultat
  34. ENDSEGMENT
  35. C
  36. PARAMETER (NCR=2,NOA=3)
  37. CHARACTER*72 TI
  38. CHARACTER*4 COMREEL(NCR),OKADI(NOA)
  39.  
  40. COMREEL(1)='REEL'
  41. COMREEL(2)='HIST'
  42. OKADI(1) ='REEL'
  43. OKADI(2) ='HIST'
  44. OKADI(3) ='MARQ'
  45. C
  46. IRET=0
  47. C
  48. MEVOL1=IPO1
  49. SEGACT MEVOL1
  50. MEVOL2=IPO2
  51. SEGACT MEVOL2
  52. C
  53. C ON TRAITE LE CAS DES OBJETS EVOLUTION DE SOUS-TYPE "REEL"
  54. C
  55. C LES DIFFERENTES COURBES DOIVENT ETRE DE SOIT DE TYPE "REEL",
  56. C SOIT DE TYPE "MARQ",
  57. C SOIT DE TYPE "HIST"
  58. C
  59. N1 = MEVOL1.IEVOLL(/1)
  60. NL1 = N1
  61. N2 = MEVOL2.IEVOLL(/1)
  62. NL2 = N2
  63.  
  64. SEGINI,ILIS1
  65. SEGINI,ILIS2
  66. NRES10=0
  67. NRES20=0
  68. NDIF12=0
  69. C
  70. C ILIS1 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 1ERE EVOL
  71. C
  72. DO I0=1,NCR
  73. NRES1=0
  74. DO 1 I1=1,N1
  75. KEVOL1=MEVOL1.IEVOLL(I1)
  76. SEGACT KEVOL1
  77. CALL PLACE(OKADI,3,IPLAC,KEVOL1.NUMEVY)
  78. IF (IPLAC.EQ.0) THEN
  79. SEGSUP ILIS1
  80. CALL ERREUR(871)
  81. RETURN
  82. ENDIF
  83. IF (KEVOL1.NUMEVY.EQ.COMREEL(I0)) THEN
  84. NRES1=NRES1+1
  85. NRES10=NRES10+1
  86. ILIS1(NRES10)=I1
  87. ENDIF
  88. 1 CONTINUE
  89. C
  90. C ILIS2 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 2ND EVOL
  91. C
  92. NRES2=0
  93. DO 2 I2=1,N2
  94. KEVOL2=MEVOL2.IEVOLL(I2)
  95. SEGACT KEVOL2
  96. CALL PLACE(OKADI,3,IPLAC,KEVOL2.NUMEVY)
  97. IF (IPLAC.EQ.0) THEN
  98. SEGSUP ILIS2
  99. CALL ERREUR(871)
  100. RETURN
  101. ENDIF
  102. IF (KEVOL2.NUMEVY.EQ.COMREEL(I0)) THEN
  103. NRES2=NRES2+1
  104. NRES20=NRES20+1
  105. ILIS2(NRES20)=I2
  106. ENDIF
  107. 2 CONTINUE
  108. IF (NRES1.NE.NRES2) THEN
  109. NDIF12=1
  110. ENDIF
  111. ENDDO
  112. NL1=NRES10
  113. NL2=NRES20
  114. SEGADJ,ILIS1,ILIS2
  115. C
  116. C LES DEUX EVOLUTIONS DOIVENT AVOIR LE MEME NOMBRE DE COURBES DE TYPE
  117. C "REEL" OU "HIST"
  118. C
  119. IF (NDIF12.NE.0) THEN
  120. C SEGDES MEVOL1,MEVOL2
  121. SEGSUP ILIS1,ILIS2
  122. IF (NRES10.EQ.NRES20) THEN
  123. CALL ERREUR(871)
  124. ELSE
  125. CALL ERREUR(870)
  126. ENDIF
  127. RETURN
  128. ENDIF
  129.  
  130. N=NL1
  131. SEGINI,SPOI,MEVOLL
  132. MEVOLL.ITYEVO=MEVOL1.ITYEVO
  133. MEVOLL.IEVTEX=TITREE
  134. C
  135. C LES ABSCISSES DES COURBES ELIGIBLES DOIVENT ETRE DES PROGRESSIONS STRICTEMENT CROISSANTES
  136. C
  137. DO 3 IL1=1,NL1
  138. KEVOL1=MEVOL1.IEVOLL(ILIS1(IL1))
  139. KEVOL2=MEVOL2.IEVOLL(ILIS2(IL1))
  140. SEGINI,KEVOLL=KEVOL1
  141. MEVOLL.IEVOLL(IL1)=KEVOLL
  142. MLREE1=KEVOL1.IPROGX
  143. MLREE2=KEVOL2.IPROGX
  144. MLREE3=KEVOL1.IPROGY
  145. MLREE4=KEVOL2.IPROGY
  146. SEGACT,MLREE1,MLREE2,MLREE3,MLREE4
  147. SPOI.IPOIX(IL1,1)=MLREE1
  148. SPOI.IPOIX(IL1,2)=MLREE2
  149. SPOI.IPOIY(IL1,1)=KEVOL1.IPROGY
  150. SPOI.IPOIY(IL1,2)=KEVOL2.IPROGY
  151.  
  152. C Test EVOLUTION N°1
  153. NJG1 =MLREE1.PROG(/1)
  154. IF (NJG1.GT.1) THEN
  155. VAL1=MLREE1.PROG(1)
  156. DO 41 IJG=2,NJG1
  157. VAL2=MLREE1.PROG(IJG)
  158. IF (VAL2.LE.VAL1) THEN
  159. SEGSUP,SPOI
  160. CALL ERREUR(872)
  161. RETURN
  162. ENDIF
  163. VAL1=VAL2
  164. 41 CONTINUE
  165. ENDIF
  166.  
  167. C Test EVOLUTION N°2
  168. NJG2 =MLREE2.PROG(/1)
  169. IF(MLREE2 .EQ. MLREE1) THEN
  170. C PRINT *,'ADEVOR:POINTEURS IDENTIQUES',IL1,MLREE1,MLREE2
  171. SPOI.IPOIX(IL1,3)=MLREE1
  172.  
  173. ELSE
  174. C PRINT *,'ADEVOR:POINTEURS DIFFERENTS',IL1,MLREE1,MLREE2
  175. IF (NJG2.GT.1) THEN
  176. VAL1=MLREE2.PROG(1)
  177. DO 42 IJG=2,NJG2
  178. VAL2=MLREE2.PROG(IJG)
  179. IF (VAL2.LE.VAL1) THEN
  180. SEGSUP,SPOI
  181. CALL ERREUR(872)
  182. RETURN
  183. ENDIF
  184. VAL1=VAL2
  185. 42 CONTINUE
  186. ENDIF
  187.  
  188. IF(NJG1 .NE. NJG2)THEN
  189. C PRINT *,'-ADEVOR:TAILLE DIFFERENTS',NJG1,NJG2
  190. GOTO 410
  191.  
  192. ELSE
  193. C PRINT *,'-ADEVOR:TAILLE IDENTIQUE',NJG1,NJG2
  194. C Meme taille ==> Est-ce les memes valeurs a XSZPRE pres ?
  195. C Critère volontairement laxiste
  196. DO II=1,NJG1
  197. VAL1 = ABS(MLREE2.PROG(II) - MLREE1.PROG(II))
  198. VAL2 = MAX(ABS(MLREE2.PROG(II))*XSZPRE,
  199. & ABS(MLREE1.PROG(II))*XSZPRE )
  200. C PRINT *,'--ADEVOR:',II,MLREE1.PROG(II),MLREE2.PROG(II),VAL1
  201. IF(VAL1 .GT. VAL2) GOTO 410
  202. ENDDO
  203. C PRINT *,'-ADEVOR:FINALEMENT MEME VALEURS'
  204. SPOI.IPOIX(IL1,3)=MLREE1
  205. GOTO 411
  206. ENDIF
  207.  
  208. 410 CONTINUE
  209. C PRINT *,'-ADEVOR:CONSTRUCTION NOUVEAU LISTREEL ABSCISSES'
  210. JG=NJG1+NJG2
  211. SEGINI,MLREE3
  212. SPOI.IPOIX(IL1,3)=MLREE3
  213.  
  214. C Construction nouveau LISTREEL ABSCISSES
  215. II1 = 0
  216. II2 = 0
  217. ICOUNT = 0
  218. DO II=1,JG
  219. IF ( II1.EQ.NJG1 .AND. II2.EQ.NJG2)THEN
  220. GOTO 413
  221.  
  222. ELSEIF( II1.EQ.NJG1 )THEN
  223. II2 = II2 + 1
  224. ICOUNT = ICOUNT + 1
  225. MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2)
  226.  
  227. ELSEIF( II2.EQ.NJG2 )THEN
  228. II1 = II1 + 1
  229. ICOUNT = ICOUNT + 1
  230. MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1)
  231.  
  232. ELSEIF(MLREE1.PROG(II1+1) .LT. MLREE2.PROG(II2+1))THEN
  233. II1 = II1 + 1
  234. ICOUNT = ICOUNT + 1
  235. MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1)
  236. ELSE
  237. II2 = II2 + 1
  238. ICOUNT = ICOUNT + 1
  239. MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2)
  240. ENDIF
  241. ENDDO
  242.  
  243. 413 CONTINUE
  244.  
  245. C Retrait des DOUBLONS
  246. IDEC = 0
  247. VAL1 = MLREE3.PROG(1)
  248. DO II=2,JG
  249. VAL2=MLREE3.PROG(II)
  250. IF (VAL2 .EQ. VAL1)THEN
  251. IDEC = IDEC + 1
  252.  
  253. ELSEIF(ABS(VAL2-VAL1) .LE.
  254. & MAX(ABS(VAL2*XSZPRE),ABS(VAL1*XSZPRE)))THEN
  255. IDEC = IDEC + 1
  256.  
  257. ELSE
  258. MLREE3.PROG(II - IDEC)=VAL2
  259. VAL1 = VAL2
  260. ENDIF
  261. ENDDO
  262. IF (IDEC .GT. 0) THEN
  263. JG = JG - IDEC
  264. SEGADJ,MLREE3
  265. ENDIF
  266. SEGACT,MLREE3*NOMOD
  267.  
  268. C Interpolation des ORDONNEES aux nouvelles ABSCISSES MLREE3
  269. MLREEL = SPOI.IPOIX(IL1,1)
  270. MLREE1 = SPOI.IPOIY(IL1,1)
  271. SEGINI,MLREE2
  272. SPOI.IPOIY(IL1,1)=MLREE2
  273. XMIN=MLREEL.PROG(1)
  274. XMAX=MLREEL.PROG(MLREEL.PROG(/1))
  275. DO II=1,JG
  276. XABSCI=MLREE3.PROG(II)
  277. IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN
  278. MLREE2.PROG(II)=0.D0
  279. ELSE
  280. C interpolation
  281. CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET)
  282. IF(IRET .EQ. 0)THEN
  283. CALL ERREUR(21)
  284. RETURN
  285. ENDIF
  286. MLREE2.PROG(II)=FT0
  287. ENDIF
  288. ENDDO
  289. SEGACT,MLREE2*NOMOD
  290.  
  291. MLREEL = SPOI.IPOIX(IL1,2)
  292. MLREE1 = SPOI.IPOIY(IL1,2)
  293. SEGINI,MLREE4
  294. SPOI.IPOIY(IL1,2)=MLREE4
  295. XMIN=MLREEL.PROG(1)
  296. XMAX=MLREEL.PROG(MLREEL.PROG(/1))
  297. DO II=1,JG
  298. XABSCI=MLREE3.PROG(II)
  299. IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN
  300. MLREE4.PROG(II)=0.D0
  301. ELSE
  302. C interpolation
  303. CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET)
  304. IF(IRET .EQ. 0)THEN
  305. CALL ERREUR(21)
  306. RETURN
  307. ENDIF
  308. MLREE4.PROG(II)=FT0
  309. ENDIF
  310. ENDDO
  311. SEGACT,MLREE4*NOMOD
  312. ENDIF
  313.  
  314. 411 CONTINUE
  315. C ICI on va realiser l'ADDITION ou la SOUSTRACTION des ORDONNEES
  316. MLREEL=SPOI.IPOIX(IL1,3)
  317. MLREE1=SPOI.IPOIY(IL1,1)
  318. MLREE2=SPOI.IPOIY(IL1,2)
  319. JG=MLREEL.PROG(/1)
  320. SEGINI,MLREE3
  321. SPOI.IPOIY(IL1,3)=MLREE3
  322. IF (IPM.EQ. 1) THEN
  323. DO II=1,JG
  324. MLREE3.PROG(II) = MLREE1.PROG(II) + MLREE2.PROG(II)
  325. ENDDO
  326. ELSEIF (IPM.EQ.-1) THEN
  327. DO II=1,JG
  328. MLREE3.PROG(II) = MLREE1.PROG(II) - MLREE2.PROG(II)
  329. ENDDO
  330. ELSE
  331. CALL ERREUR(21)
  332. RETURN
  333. ENDIF
  334. SEGACT,MLREE3*NOMOD
  335.  
  336. C DO II=1,JG
  337. C X1=MLREEL.PROG(II)
  338. C Y1=MLREE1.PROG(II)
  339. C Y2=MLREE2.PROG(II)
  340. C Y3=MLREE3.PROG(II)
  341. C PRINT *,'ADEVOR:',II,X1,Y1,Y2,Y3
  342. C ENDDO
  343. 3 CONTINUE
  344.  
  345.  
  346. C Reconstitution de l'EVOLUTION solution
  347. DO II=1,N
  348. KEVOLL=MEVOLL.IEVOLL(II)
  349. KEVOLL.IPROGX=SPOI.IPOIX(II,3)
  350. KEVOLL.IPROGY=SPOI.IPOIY(II,3)
  351. SEGACT,KEVOLL*NOMOD
  352. ENDDO
  353. SEGACT,MEVOLL*NOMOD
  354. IRET=MEVOLL
  355.  
  356. END
  357.  
  358.  
  359.  
  360.  

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