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

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