Télécharger puis.eso

Retour à la liste

Numérotation des lignes :

  1. C PUIS SOURCE BP208322 16/11/18 21:20:35 9177
  2. SUBROUTINE PUIS(IPEV1,IPEV2,IRET,INV)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. CHARACTER *72 TI
  6. CHARACTER*4 ITYP1
  7. CHARACTER*12 MOTX
  8. CHARACTER*4 MOTY(8),MOTY1,MOTY2,MOTY3,MOTY4
  9. C
  10. C=======================================================================
  11. C = =
  12. C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE =
  13. C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTIO =
  14. C = =
  15. C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) =
  16. C = =
  17. C = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX =
  18. C = OBJETS DE TYPE EVOLUTIO EVOLF ET EVOLV. LES ABSCISSES DE PROD, =
  19. C = L'OBJET AINSI CREE, RESTENT CELLES DE EVOLF ET EVOLV. =
  20. C = =
  21. C = =
  22. C = =
  23. C = MEVOL1 : POINTEUR SUR MEVOLF (OBJET EVOLUTION) =
  24. C = MEVOL2 : POINTEUR SUR MEVOLV " " =
  25. C = KEVOL1 : POINTEUR SUR KEVOLF =
  26. C = KEVOL2 : POINTEUR SUR KEVOLV =
  27. C = MLREE1 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF =
  28. C = MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV =
  29. C = =
  30. C = =
  31. C = ADAPTE AUX OBJETS "EVOLUTION" DE TYPE SOUS-TYPE "COMPLEXE" =
  32. C = PAR APPEL A PUISCP PAR F.ROULLIER
  33. C=======================================================================
  34. C
  35. -INC CCGEOME
  36. -INC CCOPTIO
  37. -INC SMEVOLL
  38. -INC SMLREEL
  39. -INC SMLMOTS
  40. POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
  41. C
  42. DATA MOTY2,MOTY4/' * ',' / '/
  43. DATA MOTY(1),MOTY(2),MOTY(3),MOTY(4)/'DEPL','VITE','ACCE','FORC'/
  44. DATA MOTY(5),MOTY(6),MOTY(7),MOTY(8)/'BRUI','REEL','IMAG','LIAI'/
  45. C
  46. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  47. IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
  48. ICOUL=ICOUL-1
  49. C
  50. C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR
  51. C L'UN EST UNE FORCE, L'AUTRE UNE VITESSE
  52. C
  53. MEVOL1=IPEV1
  54. SEGACT MEVOL1
  55. MEVOL2=IPEV2
  56. SEGACT MEVOL2
  57. C
  58. C TEST SUR LE SOUS-TYPE
  59. C
  60. ITYP1=MEVOL1.ITYEVO
  61. IF (ITYP1.NE.'COMP') GO TO 199
  62. SEGDES MEVOL1,MEVOL2
  63. CALL PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL)
  64. RETURN
  65. 199 CONTINUE
  66. C
  67. C BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT
  68. C
  69. NC1=MEVOL1.IEVOLL(/1)
  70. NC2=MEVOL2.IEVOLL(/1)
  71. IF(NC1.EQ.NC2) GOTO 200
  72. CALL ERREUR(111)
  73. RETURN
  74. C
  75. 200 CONTINUE
  76. N=NC1
  77. SEGINI MEVOLL
  78. IRET=MEVOLL
  79. TI(1:72)=TITREE
  80. IEVTEX=TI
  81. ITYEVO='REEL'
  82. DO 201 IC=1,NC1
  83. C
  84. KEVOL1=MEVOL1.IEVOLL(IC)
  85. SEGACT KEVOL1
  86. DO 50 I=1,3
  87. DO 50 J=1,8
  88. IF(KEVOL1.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN
  89. MOTY1=KEVOL1.NOMEVY(I*4-3:I*4)
  90. GOTO 51
  91. ENDIF
  92. 50 CONTINUE
  93. MOTY1=KEVOL1.NOMEVY(1:4)
  94. C
  95. C
  96. 51 MLREE1=KEVOL1.IPROGY
  97. IF (KEVOL1.NUMEVY.NE.'REEL'.AND.KEVOL1.NUMEVY.NE.'HIST') GOTO 1000
  98. SEGACT MLREE1
  99. IF(KEVOL1.TYPY.NE.'LISTMOTS')THEN
  100. L1=MLREE1.PROG(/1)
  101. ELSE
  102. MLMOT1=KEVOL1.IPROGY
  103. SEGACT MLMOT1
  104. L1=MLMOT1.MOTS(/2)
  105. SEGDES MLMOT1
  106. ENDIF
  107. C
  108. KEVOL2=MEVOL2.IEVOLL(IC)
  109. SEGACT KEVOL2
  110. MOTX=KEVOL2.NOMEVX
  111. DO 52 I=1,3
  112. DO 52 J=1,8
  113. IF(KEVOL2.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN
  114. MOTY3=KEVOL2.NOMEVY(I*4-3:I*4)
  115. GOTO 53
  116. ENDIF
  117. 52 CONTINUE
  118. MOTY3=KEVOL2.NOMEVY(1:4)
  119. C
  120. C
  121. 53 MLREE2=KEVOL2.IPROGY
  122. IF (KEVOL2.NUMEVY.NE.'REEL'.AND.KEVOL2.NUMEVY.NE.'HIST') GOTO 1001
  123. SEGACT MLREE2
  124. IF(KEVOL2.TYPY.NE.'LISTMOTS')THEN
  125. L2=MLREE2.PROG(/1)
  126. ELSE
  127. MLMOT2=KEVOL2.IPROGY
  128. SEGACT MLMOT2
  129. L2=MLMOT2.MOTS(/2)
  130. SEGDES MLMOT2
  131. ENDIF
  132. C
  133. C LES LISTREEL ONT-ILS MEME LONGUEUR ?
  134. IF(L1.EQ.L2)GOTO 10
  135. CALL ERREUR(337)
  136. GOTO 100
  137. C
  138. C CREATION DE L'OBJET PROD DE TYPE EVOLUTIO
  139. C
  140. 10 CONTINUE
  141. SEGDES MLREE1
  142. SEGDES MLREE2
  143. C
  144. C LES LISTREEL DES ABSCISSES SONT ILS IDENTIQUES ?
  145. MLREE1=KEVOL1.IPROGX
  146. MLREE3=KEVOL2.IPROGX
  147. SEGACT MLREE1,MLREE3
  148. CALL VERIPR(MLREE1.PROG,MLREE3.PROG,L1,IRETOU,1.D-2)
  149. IF(IRETOU.EQ.0) THEN
  150. CALL ERREUR(394)
  151. RETURN
  152. ENDIF
  153. SEGDES MLREE1
  154. C
  155. MLREE1=KEVOL1.IPROGY
  156. MLREE2=KEVOL2.IPROGY
  157. SEGACT MLREE1,MLREE2,MLREE3
  158. SEGINI KEVOLL
  159. IEVOLL(IC)=KEVOLL
  160. TYPX='LISTREEL'
  161. TYPY='LISTREEL'
  162. c KEVTEX=TI
  163. C
  164. NOMEVX=MOTX
  165. IF (INV.EQ.1) THEN
  166. NOMEVY=MOTY1//MOTY2//MOTY3
  167. ELSE
  168. NOMEVY=MOTY1//MOTY4//MOTY3
  169. ENDIF
  170. KEVTEX=NOMEVY
  171. NUMEVX=ICOUL
  172. NUMEVY='REEL'
  173. C
  174. JG=L1
  175. SEGINI MLREE4
  176. IPROGX=MLREE4
  177. SEGINI MLREE5
  178. IPROGY=MLREE5
  179. C
  180. C
  181. C
  182. C
  183. IF(INV.EQ.1) THEN
  184. DO 20 I=1,L1
  185. FORC=MLREE1.PROG(I)
  186. VITE=MLREE2.PROG(I)
  187. TIM=MLREE3.PROG(I)
  188. C
  189. C TIM ET FORC*VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR *
  190. C
  191. MLREE4.PROG(I)=TIM
  192. MLREE5.PROG(I)=VITE*FORC
  193. C
  194. 20 CONTINUE
  195. ELSE
  196. DO 21 I=1,L1
  197. FORC=MLREE1.PROG(I)
  198. VITE=MLREE2.PROG(I)
  199. TIM=MLREE3.PROG(I)
  200. C
  201. C TIM ET FORC/VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR *
  202. C
  203. MLREE4.PROG(I)=TIM
  204. IF(ABS(VITE).GT.1.E-20) THEN
  205. MLREE5.PROG(I)=FORC/VITE
  206. ELSE
  207. WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  208. & 'DIVISEUR : RESULTAT MIS A 0'
  209. MLREE5.PROG(I)=0.D0
  210. GOTO 21
  211. ENDIF
  212. C
  213. 21 CONTINUE
  214. ENDIF
  215. C
  216. C DESACTIVE LES LISTREEL
  217. C
  218. SEGDES MLREE4,MLREE5
  219. SEGDES MLREE3,MLREE1,MLREE2
  220. C
  221. C DESACTIVE LES KEVOL
  222. C
  223. SEGDES KEVOLL
  224. SEGDES KEVOL1,KEVOL2
  225. C
  226. 201 CONTINUE
  227. C
  228. C DESACTIVE LES MEVOL
  229. C
  230. SEGDES MEVOLL
  231. SEGDES MEVOL1,MEVOL2
  232. C
  233. 100 CONTINUE
  234. RETURN
  235. 1000 CONTINUE
  236. moterr(1:8 )='EVOLUTIO'
  237. moterr(9:13)=KEVOL1.NUMEVY
  238. call erreur(131)
  239. return
  240. 1001 CONTINUE
  241. moterr(1:8 )='EVOLUTIO'
  242. moterr(9:13)=KEVOL2.NUMEVY
  243. call erreur(131)
  244. RETURN
  245.  
  246.  
  247. END
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  

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