Télécharger puiscp.eso

Retour à la liste

Numérotation des lignes :

  1. C PUISCP SOURCE BP208322 15/05/11 21:15:17 8528
  2. SUBROUTINE PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C=======================================================================
  7. C = =
  8. C = APPELE PAR PUIS =
  9. C = =
  10. C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE =
  11. C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTION DE SOUS-TYPE =
  12. C = COMPLEXE =
  13. C = =
  14. C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) =
  15. C = =
  16. C = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX =
  17. C = OBJETS EVOLUTION DE SOUS-TYPE COMPLEXE EVOLF ET EVOLV. =
  18. C = LES ABSCISSES DE PROD, L'OBJET AINSI CREE, SONT CELLES =
  19. C = DE EVOLF ET EVOLV. =
  20. C = =
  21. C = =
  22. C = CREATION : 4/12/87 =
  23. C = F.ROULLIER =
  24. C = =
  25. C=======================================================================
  26. C
  27. -INC CCOPTIO
  28. -INC SMEVOLL
  29. -INC SMLREEL
  30. SEGMENT TEMPP
  31. IMPLIED DR(NPT),DI(NPT),DM(NPT),DP(NPT)
  32. IMPLIED AA(NPT),AB(NPT),BA(NPT),BB(NPT),DENOM(NPT)
  33. ENDSEGMENT
  34. C
  35. CHARACTER*72 TI
  36. CHARACTER*4 ITYP1,ITYP2
  37. C
  38. C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE SOUS-TYPE COMPLEXE
  39. C
  40. MEVOL1=IPEV1
  41. MEVOL2=IPEV2
  42. SEGACT MEVOL1,MEVOL2
  43. ITYP1=MEVOL1.ITYEVO
  44. ITYP2=MEVOL1.ITYEVO
  45. IF (ITYP1.EQ.'COMP') GO TO 198
  46. 197 MOTERR(1:8)='EVOLUTIO'
  47. CALL ERREUR(302)
  48. SEGDES MEVOL1,MEVOL2
  49. RETURN
  50. C
  51. C BOUCLE SUR LES COURBES
  52. C
  53. 198 NC1=MEVOL1.IEVOLL(/1)
  54. NC2=MEVOL2.IEVOLL(/1)
  55. IF(NC1.NE.NC2) THEN
  56. CALL ERREUR(111)
  57. RETURN
  58. ENDIF
  59. NC=NC1
  60. C
  61. C CREATION DE L'OBJET PRODUIT DE TYPE EVOLUTION (COMPLEXE)
  62. C
  63. N=NC1
  64. SEGINI MEVOLL
  65. IRET=MEVOLL
  66. TI(1:72)=TITREE
  67. IEVTEX=TI
  68. ITYEVO=MEVOL1.ITYEVO
  69. C
  70. DO 201 IC=1,NC,2
  71. KEVOL1=MEVOL1.IEVOLL(IC)
  72. KEVOL2=MEVOL2.IEVOLL(IC)
  73. SEGACT KEVOL1,KEVOL2
  74. C
  75. C TEST DES SOUS-TYPES
  76. C
  77. ITYP1=KEVOL1.NUMEVY
  78. ITYP2=KEVOL2.NUMEVY
  79. C
  80. MLREE1=KEVOL1.IPROGX
  81. MLREE2=KEVOL2.IPROGX
  82. C
  83. C TEST DES LONGUEURS DES 2 SOUS-OBJETS EVOLUTION
  84. C
  85. SEGACT MLREE1,MLREE2
  86. L1=MLREE1.PROG(/1)
  87. L2=MLREE2.PROG(/1)
  88. IF(L1.EQ.L2) GO TO 10
  89. CALL ERREUR(337)
  90. GOTO 400
  91. 10 CONTINUE
  92. C
  93. C LES ABSCISSES DOIVENT ETRE IDENTIQUES
  94. C
  95. CALL VERIPR(MLREE1.PROG,MLREE2.PROG,L1,IRETOU,1.D-2)
  96. IF(IRETOU.NE.0) GO TO 11
  97. CALL ERREUR(394)
  98. GO TO 400
  99. 11 CONTINUE
  100. SEGDES MLREE1,MLREE2
  101. C
  102. C DEFINITION DES PARAMETRES POUR IC
  103. C
  104. SEGINI KEVOLL
  105. IEVOLL(IC)=KEVOLL
  106. TYPX='LISTREEL'
  107. TYPY='LISTREEL'
  108. c KEVTEX=TI
  109. KEVTEX=KEVOL1.KEVTEX
  110. C
  111. NOMEVX=KEVOL1.NOMEVX
  112. NOMEVY=KEVOL1.NOMEVY
  113. NUMEVX=ICOUL
  114. NUMEVY=KEVOL1.NUMEVY
  115. C
  116. C DEFINITION DE PROGX POUR IC
  117. C
  118. MLREE1=KEVOL1.IPROGX
  119. SEGACT MLREE1
  120. JG=L1
  121. SEGINI MLREEL
  122. IPROGX=MLREEL
  123. DO 20 I=1,L1
  124. PROG(I)=MLREE1.PROG(I)
  125. 20 CONTINUE
  126. SEGDES KEVOLL,MLREEL,MLREE1
  127. SEGDES KEVOL1
  128. C
  129. C DEFINITION DES PARAMETRES POUR IC+1
  130. C
  131. SEGINI KEVOLL
  132. TYPX='LISTREEL'
  133. TYPY='LISTREEL'
  134. IEVOLL(IC+1)=KEVOLL
  135. KEVOL1=MEVOL1.IEVOLL(IC+1)
  136. SEGACT KEVOL1
  137. MLREE1=KEVOL1.IPROGX
  138. SEGACT MLREE1
  139. KEVTEX=TI
  140. C
  141. NOMEVX=KEVOL1.NOMEVX
  142. NOMEVY=KEVOL1.NOMEVY
  143. NUMEVX=ICOUL
  144. NUMEVY=KEVOL1.NUMEVY
  145. C
  146. C DEFINITION DE PROGX POUR IC+1
  147. C
  148. JG=L1
  149. SEGINI MLREEL
  150. IPROGX=MLREEL
  151. DO 21 I=1,L1
  152. PROG(I)=MLREE1.PROG(I)
  153. 21 CONTINUE
  154. SEGDES KEVOLL,MLREEL,KEVOL1,KEVOL2
  155. C
  156. C
  157. NPT=L1
  158. C
  159. C
  160. IF (ITYP1.EQ.'MODU') GO TO 200
  161. C
  162. SEGINI TEMPP
  163. KEVOL1=MEVOL1.IEVOLL(IC)
  164. SEGACT KEVOL1
  165. MLREE1=KEVOL1.IPROGY
  166. SEGACT MLREE1
  167. DO 100 I=1,L1
  168. AB(I)=MLREE1.PROG(I)
  169. 100 CONTINUE
  170. SEGDES KEVOL1,MLREE1
  171. C
  172. KEVOL1=MEVOL1.IEVOLL(IC+1)
  173. SEGACT KEVOL1
  174. MLREE1=KEVOL1.IPROGY
  175. SEGACT MLREE1
  176. DO 120 I=1,L1
  177. BB(I)=MLREE1.PROG(I)
  178. 120 CONTINUE
  179. SEGDES KEVOL1,MLREE1
  180. C
  181. KEVOL1=MEVOL2.IEVOLL(IC)
  182. KEVOL2=MEVOL2.IEVOLL(IC+1)
  183. SEGACT KEVOL1,KEVOL2
  184. MLREE1=KEVOL1.IPROGY
  185. MLREE2=KEVOL2.IPROGY
  186. SEGACT MLREE1,MLREE2
  187. IF (ITYP2.EQ.'MODU') THEN
  188. DO 130 I=1,L1
  189. DM(I)=MLREE1.PROG(I)
  190. DP(I)=MLREE2.PROG(I)
  191. 130 CONTINUE
  192. CALL CONVCP(DR,DI,DM,DP,L1,-1)
  193. ELSE
  194. DO 131 I=1,L1
  195. DR(I)=MLREE1.PROG(I)
  196. DI(I)=MLREE2.PROG(I)
  197. 131 CONTINUE
  198. ENDIF
  199. DO 140 I=1,L1
  200. AA(I)=AB(I)*DR(I)
  201. AB(I)=AB(I)*DI(I)
  202. BA(I)=BB(I)*DR(I)
  203. BB(I)=BB(I)*DI(I)
  204. 140 CONTINUE
  205. IF (INV.EQ.1) GO TO 142
  206. DO 143 I=1,L1
  207. A=MLREE1.PROG(I)
  208. B=MLREE2.PROG(I)
  209. DENOM(I)=A*A+B*B
  210. 143 CONTINUE
  211. 142 CONTINUE
  212. SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2
  213. C
  214. C
  215. KEVOLL=MEVOLL.IEVOLL(IC)
  216. SEGACT KEVOLL*MOD
  217. JG=L1
  218. SEGINI MLREEL
  219. IPROGY=MLREEL
  220. C
  221. IF(INV.EQ.1) THEN
  222. DO 30 I=1,L1
  223. PROG(I)=AA(I)-BB(I)
  224. 30 CONTINUE
  225. ELSE
  226. DO 31 I=1,L1
  227. IF(DENOM(I).GT.1.D-20) THEN
  228. PROG(I)=(AA(I)+BB(I))/DENOM(I)
  229. ELSE
  230. WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  231. & 'DIVISEUR : RESULTAT MIS A 0'
  232. PROG(I)=0.D0
  233. GOTO 31
  234. ENDIF
  235. 31 CONTINUE
  236. ENDIF
  237. C
  238. SEGDES KEVOLL,MLREEL
  239. C
  240. KEVOLL=MEVOLL.IEVOLL(IC+1)
  241. SEGACT KEVOLL*MOD
  242. JG=L1
  243. SEGINI MLREEL
  244. IPROGY=MLREEL
  245. C
  246. C
  247. IF(INV.EQ.1) THEN
  248. DO 32 I=1,L1
  249. PROG(I)=AB(I)+BA(I)
  250. 32 CONTINUE
  251. ELSE
  252. DO 33 I=1,L1
  253. IF(DENOM(I).GT.1.D-20) THEN
  254. PROG(I)=(BA(I)-AB(I))/DENOM(I)
  255. ELSE
  256. WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  257. & 'DIVISEUR : RESULTAT MIS A 0'
  258. PROG(I)=0.D0
  259. GOTO 33
  260. ENDIF
  261. 33 CONTINUE
  262. ENDIF
  263. C
  264. SEGSUP TEMPP
  265. SEGDES KEVOLL,KEVOL1,KEVOL2
  266. C
  267. GO TO 201
  268. 200 CONTINUE
  269. SEGINI TEMPP
  270. KEVOL1=MEVOL1.IEVOLL(IC)
  271. KEVOL2=MEVOL1.IEVOLL(IC+1)
  272. SEGACT KEVOL1,KEVOL2
  273. MLREE1=KEVOL1.IPROGY
  274. MLREE2=KEVOL2.IPROGY
  275. SEGACT MLREE1,MLREE2
  276. DO 210 I=1,L1
  277. AA(I)=MLREE1.PROG(I)
  278. BB(I)=MLREE2.PROG(I)
  279. 210 CONTINUE
  280. SEGDES KEVOL1,MLREE1
  281. SEGDES KEVOL2,MLREE2
  282. C
  283. KEVOL1=MEVOL2.IEVOLL(IC)
  284. KEVOL2=MEVOL2.IEVOLL(IC+1)
  285. SEGACT KEVOL1,KEVOL2
  286. MLREE1=KEVOL1.IPROGY
  287. MLREE2=KEVOL2.IPROGY
  288. SEGACT MLREE1,MLREE2
  289. IF (ITYP2.EQ.'PREE') THEN
  290. DO 230 I=1,L1
  291. DR(I)=MLREE1.PROG(I)
  292. DI(I)=MLREE2.PROG(I)
  293. 230 CONTINUE
  294. CALL CONVCP(DR,DI,DM,DP,L1,1)
  295. ELSE
  296. DO 231 I=1,L1
  297. DM(I)=MLREE1.PROG(I)
  298. DP(I)=MLREE2.PROG(I)
  299. 231 CONTINUE
  300. ENDIF
  301. IF (INV.EQ.1) THEN
  302. DO 240 I=1,L1
  303. AA(I)=AA(I)*DM(I)
  304. BB(I)=BB(I)+DP(I)
  305. 240 CONTINUE
  306. ELSE
  307. DO 243 I=1,L1
  308. IF(DM(I).GT.1.D-20) THEN
  309. AA(I)=AA(I)/DM(I)
  310. ELSE
  311. WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  312. & 'DIVISEUR : RESULTAT MIS A 0'
  313. AA(I)=0.D0
  314. ENDIF
  315. BB(I)=BB(I)-DP(I)
  316. 243 CONTINUE
  317. ENDIF
  318. DO 244 I=1,L1
  319. IF (BB(I).GT.180.D0) THEN
  320. BB(I)=BB(I)-360.D0
  321. ELSE IF(BB(I).LT.-180.D0) THEN
  322. BB(I)=BB(I)+360.D0
  323. ENDIF
  324. 244 CONTINUE
  325. SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2
  326. C
  327. KEVOLL=MEVOLL.IEVOLL(IC)
  328. SEGACT KEVOLL*MOD
  329. JG=L1
  330. SEGINI MLREEL
  331. IPROGY=MLREEL
  332. C
  333. DO 330 I=1,L1
  334. PROG(I)=AA(I)
  335. 330 CONTINUE
  336. SEGDES KEVOLL,MLREEL
  337. C
  338. KEVOLL=MEVOLL.IEVOLL(IC+1)
  339. SEGACT KEVOLL*MOD
  340. SEGINI MLREEL
  341. IPROGY=MLREEL
  342. C
  343. DO 332 I=1,L1
  344. PROG(I)=BB(I)
  345. 332 CONTINUE
  346. SEGDES MLREEL
  347. C
  348. SEGSUP TEMPP
  349. SEGDES KEVOLL,KEVOL1,KEVOL2
  350. C
  351. SEGDES MEVOLL,MEVOL1,MEVOL2
  352. 201 CONTINUE
  353. C
  354. 400 CONTINUE
  355. RETURN
  356. END
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  

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