Télécharger evolin.eso

Retour à la liste

Numérotation des lignes :

  1. C EVOLIN SOURCE CHAT 05/01/12 23:47:22 5004
  2. SUBROUTINE EVOLIN (IEV1,XX1,IEV2,XX2,IEV3)
  3. *____________________________________________________________________
  4. *
  5. * Interpolation d'une courbe (type EVOLUTION)
  6. * en fouction de deux autres courbes (type EVOLUTION)
  7. *
  8. * ENTREES :
  9. * ---------
  10. *
  11. * IEV1 Pointeur sur un objet de type EVOLUTION
  12. * IEV2 Pointeur sur le deuxieme objet de type EVOLUTION
  13. * XX1 Flottant donnant le rapport entre la courbe
  14. * a calculer et la courbe designee par IEV2
  15. * XX2 Flottant donnant le rapport entre la courbe
  16. * a calculer et la courbe designee par IEV1.
  17. * Il existe la relation (XX1 + XX2)=1
  18. *
  19. *
  20. * SORTIE :
  21. * --------
  22. *
  23. * IEV3 Pointeur sur l'objet EVOLUTION resultat
  24. * =0 si operation impossible
  25. *
  26. *____________________________________________________________________
  27. *
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8(A-H,O-Z)
  30. -INC CCOPTIO
  31. -INC SMEVOLL
  32. -INC SMLREEL
  33. -INC SMLENTI
  34. POINTEUR MREX.MLREEL,MREY.MLREEL,MREY2.MLREEL
  35. MEVOL1=IEV1
  36. MEVOL2=IEV2
  37. IF(MEVOL1.EQ.0.OR.MEVOL2.EQ.0) THEN
  38. MOTERR(1:8)='EVOLUTIO'
  39. CALL ERREUR(37)
  40. IEV3=0
  41. RETURN
  42. ENDIF
  43. C
  44. C ACTIVATION DES EVOLUTIONS
  45. C
  46. SEGACT MEVOL1,MEVOL2
  47. N1=MEVOL1.IEVOLL(/1)
  48. N2=MEVOL2.IEVOLL(/1)
  49. C
  50. C ON TETSTE LES OBJETS EVOLUTION
  51. C
  52. IF(N1.NE.1) THEN
  53. MOTERR(1:8)='EVOLUTIO'
  54. INTERR(1)=MEVOL1
  55. CALL ERREUR(110)
  56. SEGDES MEVOL1,MEVOL2
  57. IEV3=0
  58. RETURN
  59. ENDIF
  60. IF(N2.NE.1) THEN
  61. MOTERR(1:8)='EVOLUTIO'
  62. INTERR(1)=MEVOL2
  63. CALL ERREUR(110)
  64. SEGDES MEVOL1,MEVOL2
  65. IEV3=0
  66. RETURN
  67. ENDIF
  68. IF(MEVOL1.ITYEVO.NE.'REEL '.OR.
  69. $ MEVOL2.ITYEVO.NE.'REEL ') THEN
  70. MOTERR(1:8)='EVOLUTIO'
  71. MOTERR(9:16)='REEL '
  72. CALL ERREUR(79)
  73. SEGDES MEVOL1,MEVOL2
  74. IEV3=0
  75. RETURN
  76. ENDIF
  77. KEVOL1=MEVOL1.IEVOLL(1)
  78. KEVOL2=MEVOL2.IEVOLL(1)
  79. SEGACT KEVOL1,KEVOL2
  80. IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.KEVOL1.TYPY.NE.'LISTREEL')THEN
  81. MOTERR(1:8)='EVOLUTIO'
  82. MOTERR(9:16)='LISTREEL'
  83. INTERR(1)=MEVOL1
  84. CALL ERREUR(630)
  85. SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2
  86. IEV3=0
  87. RETURN
  88. ENDIF
  89. IF(KEVOL2.TYPX.NE.'LISTREEL'.OR.KEVOL2.TYPY.NE.'LISTREEL')THEN
  90. MOTERR(1:8)='EVOLUTIO'
  91. MOTERR(9:16)='LISTREEL'
  92. INTERR(1)=MEVOL2
  93. CALL ERREUR(630)
  94. SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2
  95. IEV3=0
  96. RETURN
  97. ENDIF
  98. IF(KEVOL1.NOMEVX.NE.KEVOL2.NOMEVX) THEN
  99. MOTERR(1:9)='abscisses'
  100. MOTERR(10:17)='EVOLUTIO'
  101. INTERR(1)=MEVOL1
  102. INTERR(2)=MEVOL2
  103. CALL ERREUR(631)
  104. SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2
  105. IEV3=0
  106. RETURN
  107. ENDIF
  108. IF(KEVOL1.NOMEVY.NE.KEVOL2.NOMEVY) THEN
  109. MOTERR(1:9)='ordonnees'
  110. MOTERR(10:17)='EVOLUTIO'
  111. INTERR(1)=MEVOL1
  112. INTERR(2)=MEVOL2
  113. CALL ERREUR(631)
  114. SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2
  115. IEV3=0
  116. RETURN
  117. ENDIF
  118. C
  119. C ON ACTIVE LES 4 LISTREEL DE DEUX COURBES
  120. C
  121. SEGDES MEVOL1,MEVOL2
  122. MLREEL=KEVOL1.IPROGX
  123. MLREE1=KEVOL1.IPROGY
  124. MLREE2=KEVOL2.IPROGX
  125. MLREE3=KEVOL2.IPROGY
  126. SEGDES KEVOL1,KEVOL2
  127. SEGACT MLREEL,MLREE1,MLREE2,MLREE3
  128. JG=PROG(/1)+MLREE2.PROG(/1)
  129. C
  130. C ON DETERNIME LA VARIATION EN X DE DEUX COURBES
  131. C
  132. XMIN=1.E32
  133. XMAX=-1.E32
  134. DO 1 I=1,PROG(/1)
  135. IF(PROG(I).LT.XMIN) XMIN=PROG(I)
  136. IF(PROG(I).GT.XMAX) XMAX=PROG(I)
  137. 1 CONTINUE
  138. DO 2 I=1,MLREE2.PROG(/1)
  139. IF(MLREE2.PROG(I).LT.XMIN) XMIN=MLREE2.PROG(I)
  140. IF(MLREE2.PROG(I).GT.XMAX) XMAX=MLREE2.PROG(I)
  141. 2 CONTINUE
  142. C
  143. C ON CALCULE LA PRECISION
  144. C
  145. XPRE=(XMAX-XMIN)/1.D12
  146. SEGINI MREX
  147. IJ=0
  148. I1=1
  149. I2=1
  150. 3 CONTINUE
  151. IF(PROG(I1).LE.MLREE2.PROG(I2)) THEN
  152. IJ=IJ+1
  153. MREX.PROG(IJ)=PROG(I1)
  154. I1=I1+1
  155. IF(MLREE2.PROG(I2)-XPRE.LT.MREX.PROG(IJ)) I2=I2+1
  156. ELSE
  157. IJ=IJ+1
  158. MREX.PROG(IJ)=MLREE2.PROG(I2)
  159. I2=I2+1
  160. IF(PROG(I1)-XPRE.LT.MREX.PROG(IJ)) I1=I1+1
  161. ENDIF
  162. IF(I1.LE.PROG(/1).AND.I2.LE.MLREE2.PROG(/1)) GO TO 3
  163. IF(I1.GT.PROG(/1)) THEN
  164. IF(I2.GT.MLREE2.PROG(/1)) GOTO 6
  165. DO 4 I=I2,MLREE2.PROG(/1)
  166. IJ=IJ+1
  167. MREX.PROG(IJ)=MLREE2.PROG(I)
  168. 4 CONTINUE
  169. ELSE
  170. DO 5 I=I1,PROG(/1)
  171. IJ=IJ+1
  172. MREX.PROG(IJ)=PROG(I)
  173. 5 CONTINUE
  174. ENDIF
  175. 6 CONTINUE
  176. JG=IJ
  177. SEGADJ MREX
  178. SEGINI MREY,MLENTI,MREY2
  179. JDEB=1
  180. DO 7 I=1,PROG(/1)
  181. DO 8 J=JDEB,MREX.PROG(/1)
  182. XX=MREX.PROG(J)
  183. IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN
  184. LECT(J)=1
  185. MREY.PROG(J)=MLREE1.PROG(I)*XX1
  186. JDEB=J
  187. GO TO 7
  188. ENDIF
  189. 8 CONTINUE
  190. 7 CONTINUE
  191. DO 9 J=1,MREX.PROG(/1)
  192. IF(LECT(J).EQ.1) GO TO 10
  193. MREY.PROG(J)=MLREE1.PROG(1)*XX1
  194. LECT(J)=1
  195. 9 CONTINUE
  196. 10 CONTINUE
  197. DO 11 J=MREX.PROG(/1),1,-1
  198. IF(LECT(J).EQ.1) GO TO 12
  199. MREY.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX1
  200. LECT(J)=1
  201. 11 CONTINUE
  202. 12 CONTINUE
  203. DO 13 J=1,MREX.PROG(/1)
  204. IF(LECT(J).EQ.1) GO TO 13
  205. DO 14 K=J+1,MREX.PROG(/1)
  206. J1=K
  207. IF(LECT(K).EQ.1) GO TO 15
  208. 14 CONTINUE
  209. 15 CONTINUE
  210. MREY.PROG(J)=MREY.PROG(J-1)+((MREY.PROG(J1)-MREY.PROG(J-1))*
  211. $(MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1)))
  212. 13 CONTINUE
  213. DO 16 I=1,LECT(/1)
  214. LECT(I)=0
  215. 16 CONTINUE
  216. SEGDES MLREEL,MLREE1
  217. SEGDES MLREE2,MLREE3
  218. MLREEL=MLREE2
  219. MLREE1=MLREE3
  220. SEGACT MLREEL,MLREE1
  221. JDEB=1
  222. DO 17 I=1,PROG(/1)
  223. DO 18 J=JDEB,MREX.PROG(/1)
  224. XX=MREX.PROG(J)
  225. IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN
  226. LECT(J)=1
  227. MREY2.PROG(J)=MLREE1.PROG(I)*XX2
  228. JDEB=J
  229. GO TO 17
  230. ENDIF
  231. 18 CONTINUE
  232. 17 CONTINUE
  233. DO 19 J=1,MREX.PROG(/1)
  234. IF(LECT(J).EQ.1) GO TO 20
  235. MREY2.PROG(J)=MLREE1.PROG(1)*XX2
  236. LECT(J)=1
  237. 19 CONTINUE
  238. 20 CONTINUE
  239. DO 21 J=MREX.PROG(/1),1,-1
  240. IF(LECT(J).EQ.1) GO TO 22
  241. MREY2.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX2
  242. LECT(J)=1
  243. 21 CONTINUE
  244. 22 CONTINUE
  245. DO 23 J=1,MREX.PROG(/1)
  246. IF(LECT(J).EQ.1) GO TO 23
  247. DO 24 K=J+1,MREX.PROG(/1)
  248. J1=K
  249. IF(LECT(K).EQ.1) GO TO 25
  250. 24 CONTINUE
  251. 25 CONTINUE
  252. MREY2.PROG(J)=MREY2.PROG(J-1)+((MREY2.PROG(J1)-MREY2.PROG(J-1))*
  253. $ (MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1)))
  254. 23 CONTINUE
  255. DO 26 I=1,LECT(/1)
  256. MREY.PROG(I)=MREY.PROG(I)+MREY2.PROG(I)
  257. 26 CONTINUE
  258. SEGDES MLREEL,MLREE1,MREY,MREX
  259. SEGSUP MLENTI,MREY2
  260. SEGINI,MEVOLL=MEVOL1
  261. SEGINI,KEVOLL=KEVOL1
  262. IEVOLL(1)=KEVOLL
  263. NUMEVX=2
  264. IPROGX=MREX
  265. IPROGY=MREY
  266. SEGDES MEVOLL,KEVOLL
  267. IEV3=MEVOLL
  268. RETURN
  269. END
  270.  
  271.  
  272.  

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