Télécharger evolin.eso

Retour à la liste

Numérotation des lignes :

  1. C EVOLIN SOURCE CB215821 19/10/08 21:15:13 10329
  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. N1=MEVOL1.IEVOLL(/1)
  47. N2=MEVOL2.IEVOLL(/1)
  48. C
  49. C ON TETSTE LES OBJETS EVOLUTION
  50. C
  51. IF(N1.NE.1) THEN
  52. MOTERR(1:8)='EVOLUTIO'
  53. INTERR(1)=MEVOL1
  54. CALL ERREUR(110)
  55. IEV3=0
  56. RETURN
  57. ENDIF
  58. IF(N2.NE.1) THEN
  59. MOTERR(1:8)='EVOLUTIO'
  60. INTERR(1)=MEVOL2
  61. CALL ERREUR(110)
  62. IEV3=0
  63. RETURN
  64. ENDIF
  65. IF(MEVOL1.ITYEVO.NE.'REEL '.OR.
  66. $ MEVOL2.ITYEVO.NE.'REEL ') THEN
  67. MOTERR(1:8)='EVOLUTIO'
  68. MOTERR(9:16)='REEL '
  69. CALL ERREUR(79)
  70. IEV3=0
  71. RETURN
  72. ENDIF
  73. KEVOL1=MEVOL1.IEVOLL(1)
  74. KEVOL2=MEVOL2.IEVOLL(1)
  75. SEGACT KEVOL1,KEVOL2
  76. IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.KEVOL1.TYPY.NE.'LISTREEL')THEN
  77. MOTERR(1:8)='EVOLUTIO'
  78. MOTERR(9:16)='LISTREEL'
  79. INTERR(1)=MEVOL1
  80. CALL ERREUR(630)
  81. IEV3=0
  82. RETURN
  83. ENDIF
  84. IF(KEVOL2.TYPX.NE.'LISTREEL'.OR.KEVOL2.TYPY.NE.'LISTREEL')THEN
  85. MOTERR(1:8)='EVOLUTIO'
  86. MOTERR(9:16)='LISTREEL'
  87. INTERR(1)=MEVOL2
  88. CALL ERREUR(630)
  89. IEV3=0
  90. RETURN
  91. ENDIF
  92. IF(KEVOL1.NOMEVX.NE.KEVOL2.NOMEVX) THEN
  93. MOTERR(1:9)='abscisses'
  94. MOTERR(10:17)='EVOLUTIO'
  95. INTERR(1)=MEVOL1
  96. INTERR(2)=MEVOL2
  97. CALL ERREUR(631)
  98. IEV3=0
  99. RETURN
  100. ENDIF
  101. IF(KEVOL1.NOMEVY.NE.KEVOL2.NOMEVY) THEN
  102. MOTERR(1:9)='ordonnees'
  103. MOTERR(10:17)='EVOLUTIO'
  104. INTERR(1)=MEVOL1
  105. INTERR(2)=MEVOL2
  106. CALL ERREUR(631)
  107. IEV3=0
  108. RETURN
  109. ENDIF
  110. C
  111. C ON ACTIVE LES 4 LISTREEL DE DEUX COURBES
  112. C
  113. MLREEL=KEVOL1.IPROGX
  114. MLREE1=KEVOL1.IPROGY
  115. MLREE2=KEVOL2.IPROGX
  116. MLREE3=KEVOL2.IPROGY
  117. JG=PROG(/1)+MLREE2.PROG(/1)
  118. C
  119. C ON DETERNIME LA VARIATION EN X DE DEUX COURBES
  120. C
  121. XMIN=1.E32
  122. XMAX=-1.E32
  123. DO 1 I=1,PROG(/1)
  124. IF(PROG(I).LT.XMIN) XMIN=PROG(I)
  125. IF(PROG(I).GT.XMAX) XMAX=PROG(I)
  126. 1 CONTINUE
  127. DO 2 I=1,MLREE2.PROG(/1)
  128. IF(MLREE2.PROG(I).LT.XMIN) XMIN=MLREE2.PROG(I)
  129. IF(MLREE2.PROG(I).GT.XMAX) XMAX=MLREE2.PROG(I)
  130. 2 CONTINUE
  131. C
  132. C ON CALCULE LA PRECISION
  133. C
  134. XPRE=(XMAX-XMIN)/1.D12
  135. SEGINI MREX
  136. IJ=0
  137. I1=1
  138. I2=1
  139. 3 CONTINUE
  140. IF(PROG(I1).LE.MLREE2.PROG(I2)) THEN
  141. IJ=IJ+1
  142. MREX.PROG(IJ)=PROG(I1)
  143. I1=I1+1
  144. IF(MLREE2.PROG(I2)-XPRE.LT.MREX.PROG(IJ)) I2=I2+1
  145. ELSE
  146. IJ=IJ+1
  147. MREX.PROG(IJ)=MLREE2.PROG(I2)
  148. I2=I2+1
  149. IF(PROG(I1)-XPRE.LT.MREX.PROG(IJ)) I1=I1+1
  150. ENDIF
  151. IF(I1.LE.PROG(/1).AND.I2.LE.MLREE2.PROG(/1)) GO TO 3
  152. IF(I1.GT.PROG(/1)) THEN
  153. IF(I2.GT.MLREE2.PROG(/1)) GOTO 6
  154. DO 4 I=I2,MLREE2.PROG(/1)
  155. IJ=IJ+1
  156. MREX.PROG(IJ)=MLREE2.PROG(I)
  157. 4 CONTINUE
  158. ELSE
  159. DO 5 I=I1,PROG(/1)
  160. IJ=IJ+1
  161. MREX.PROG(IJ)=PROG(I)
  162. 5 CONTINUE
  163. ENDIF
  164. 6 CONTINUE
  165. JG=IJ
  166. SEGADJ MREX
  167. SEGINI MREY,MLENTI,MREY2
  168. JDEB=1
  169. DO 7 I=1,PROG(/1)
  170. DO 8 J=JDEB,MREX.PROG(/1)
  171. XX=MREX.PROG(J)
  172. IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN
  173. LECT(J)=1
  174. MREY.PROG(J)=MLREE1.PROG(I)*XX1
  175. JDEB=J
  176. GO TO 7
  177. ENDIF
  178. 8 CONTINUE
  179. 7 CONTINUE
  180. DO 9 J=1,MREX.PROG(/1)
  181. IF(LECT(J).EQ.1) GO TO 10
  182. MREY.PROG(J)=MLREE1.PROG(1)*XX1
  183. LECT(J)=1
  184. 9 CONTINUE
  185. 10 CONTINUE
  186. DO 11 J=MREX.PROG(/1),1,-1
  187. IF(LECT(J).EQ.1) GO TO 12
  188. MREY.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX1
  189. LECT(J)=1
  190. 11 CONTINUE
  191. 12 CONTINUE
  192. DO 13 J=1,MREX.PROG(/1)
  193. IF(LECT(J).EQ.1) GO TO 13
  194. DO 14 K=J+1,MREX.PROG(/1)
  195. J1=K
  196. IF(LECT(K).EQ.1) GO TO 15
  197. 14 CONTINUE
  198. 15 CONTINUE
  199. MREY.PROG(J)=MREY.PROG(J-1)+((MREY.PROG(J1)-MREY.PROG(J-1))*
  200. $(MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1)))
  201. 13 CONTINUE
  202. DO 16 I=1,LECT(/1)
  203. LECT(I)=0
  204. 16 CONTINUE
  205. MLREEL=MLREE2
  206. MLREE1=MLREE3
  207. JDEB=1
  208. DO 17 I=1,PROG(/1)
  209. DO 18 J=JDEB,MREX.PROG(/1)
  210. XX=MREX.PROG(J)
  211. IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN
  212. LECT(J)=1
  213. MREY2.PROG(J)=MLREE1.PROG(I)*XX2
  214. JDEB=J
  215. GO TO 17
  216. ENDIF
  217. 18 CONTINUE
  218. 17 CONTINUE
  219. DO 19 J=1,MREX.PROG(/1)
  220. IF(LECT(J).EQ.1) GO TO 20
  221. MREY2.PROG(J)=MLREE1.PROG(1)*XX2
  222. LECT(J)=1
  223. 19 CONTINUE
  224. 20 CONTINUE
  225. DO 21 J=MREX.PROG(/1),1,-1
  226. IF(LECT(J).EQ.1) GO TO 22
  227. MREY2.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX2
  228. LECT(J)=1
  229. 21 CONTINUE
  230. 22 CONTINUE
  231. DO 23 J=1,MREX.PROG(/1)
  232. IF(LECT(J).EQ.1) GO TO 23
  233. DO 24 K=J+1,MREX.PROG(/1)
  234. J1=K
  235. IF(LECT(K).EQ.1) GO TO 25
  236. 24 CONTINUE
  237. 25 CONTINUE
  238. MREY2.PROG(J)=MREY2.PROG(J-1)+((MREY2.PROG(J1)-MREY2.PROG(J-1))*
  239. $ (MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1)))
  240. 23 CONTINUE
  241. DO 26 I=1,LECT(/1)
  242. MREY.PROG(I)=MREY.PROG(I)+MREY2.PROG(I)
  243. 26 CONTINUE
  244. SEGSUP MLENTI,MREY2
  245. SEGINI,MEVOLL=MEVOL1
  246. SEGINI,KEVOLL=KEVOL1
  247. IEVOLL(1)=KEVOLL
  248. NUMEVX=2
  249. IPROGX=MREX
  250. IPROGY=MREY
  251. IEV3=MEVOLL
  252. END
  253.  
  254.  

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