Télécharger adevor.eso

Retour à la liste

Numérotation des lignes :

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

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