Télécharger puevol.eso

Retour à la liste

Numérotation des lignes :

  1. C PUEVOL SOURCE BP208322 16/11/18 21:20:35 9177
  2. SUBROUTINE PUEVOL(IPEV1,XP1,IP1,IEVPU,IRETO)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. CHARACTER *72 TI
  6. CHARACTER*4 CTYP1,MOTY3
  7. CHARACTER*12 MOTX1
  8. CHARACTER*4 MOTY(8),MOTY1
  9. LOGICAL INF1,TEST1
  10. C
  11. C=======================================================================
  12. C
  13. C CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LA PUISSANCE
  14. C ENTIERE D'UN OBJET EVOLUTIOn
  15. C
  16. C SYNTAXE : PUIS = EVOLF ** NN
  17. C
  18. C ON EXECUTE LA PUISSANCE ENTIERE DES ORDONNEES DE L'EVOLUTIOn.
  19. C L'ABSCISSE DE L'OBJET AINSI CREE RESTE CELLE DE L'EVOLUTIOn EN
  20. C ENTREE.
  21. C
  22. C ENTREES :
  23. C IPEV1 = POINTEUR SUR L'OBJET EVOLUTIOn E ELEVER A LA PUISSANCE
  24. C XP1 = PUISSANCE REELLE
  25. C IP1 = PUISSANCE ENTIERE
  26. C IRETO = 2 SI PUISSANCE REELLE
  27. C = 1 SI PUISSANCE ENTIERE
  28. C
  29. C SORTIES :
  30. C IEVPU = POINTEUR SUR L'OBJET EVOLUTIOn RESULTAT
  31. C = 0 SI PB
  32. C IRETO = 1
  33. C = 0 SI UNE COMPOSANTE EST NEGATIVE
  34. C
  35. C VARIABLES LOCALES :
  36. C
  37. C MEVOL1 : POINTEUR SUR MEVOLL (OBJET EVOLUTION)
  38. C KEVOL1 : POINTEUR SUR KEVOLL
  39. C MLREE1 : POINTEUR SUR LA LISTREEL ABSCISSE DE EVOLL
  40. C MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLL
  41. C
  42. C
  43. C=======================================================================
  44. C
  45. -INC CCGEOME
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMEVOLL
  50. -INC SMLREEL
  51. -INC SMLMOTS
  52. -INC CCREEL
  53. C
  54. POINTEUR MLREE4.MLREEL
  55. C
  56. DATA MOTY(1),MOTY(2),MOTY(3),MOTY(4)/'DEPL','VITE','ACCE','FORC'/
  57. DATA MOTY(5),MOTY(6),MOTY(7),MOTY(8)/'BRUI','REEL','IMAG','LIAI'/
  58. C
  59. XGRNEG=-1.D0*XGRAND
  60. c
  61. IEVPU=0
  62. IFLO=IRETO
  63. IRETO=1
  64. C
  65. cbp Lecture eventuelle d'une couleur pour toutes les sous evolutions
  66. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  67. cbp IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
  68. cbp ICOUL=ICOUL-1
  69.  
  70.  
  71. C
  72. C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR
  73. C L'UN EST UNE FORCE, L'AUTRE UNE VITESSE
  74. C
  75. MEVOL1=IPEV1
  76. SEGACT MEVOL1
  77. C
  78. C TEST SUR LE SOUS-TYPE
  79. C
  80. CTYP1=MEVOL1.ITYEVO
  81. IF (CTYP1.NE.'COMP') GO TO 199
  82. SEGDES MEVOL1
  83. RETURN
  84. 199 CONTINUE
  85. C
  86. C BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT
  87. C
  88. NC1=MEVOL1.IEVOLL(/1)
  89. N=NC1
  90. SEGINI MEVOLL
  91. IEVPU=MEVOLL
  92. TI(1:72)=TITREE
  93. IEVTEX=TI
  94. ITYEVO='REEL'
  95. DO 201 IC=1,NC1
  96. KEVOL1=MEVOL1.IEVOLL(IC)
  97. SEGACT KEVOL1
  98. DO 50 I=1,3
  99. DO 50 J=1,8
  100. IF (KEVOL1.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN
  101. MOTY1=KEVOL1.NOMEVY(I*4-3:I*4)
  102. GOTO 51
  103. ENDIF
  104. 50 CONTINUE
  105. MOTX1=KEVOL1.NOMEVX(1:4)
  106. MOTY1=KEVOL1.NOMEVY(1:4)
  107. C
  108. C
  109. 51 MLREE2=KEVOL1.IPROGY
  110. IF (KEVOL1.NUMEVY.NE.'REEL'.AND.
  111. & KEVOL1.NUMEVY.NE.'HIST') GOTO 1000
  112. SEGACT MLREE2
  113. IF (KEVOL1.TYPY.NE.'LISTMOTS') THEN
  114. L1=MLREE2.PROG(/1)
  115. ELSE
  116. MLMOT1=KEVOL1.IPROGY
  117. SEGACT MLMOT1
  118. L1=MLMOT1.MOTS(/2)
  119. SEGDES MLMOT1
  120. ENDIF
  121. SEGDES MLREE2
  122. C
  123. C
  124. C CREATION DE L'OBJET PROD DE TYPE EVOLUTIO
  125. C
  126. C
  127. MLREE1=KEVOL1.IPROGX
  128. MLREE2=KEVOL1.IPROGY
  129. SEGACT MLREE1,MLREE2
  130. SEGINI KEVOLL
  131. IEVOLL(IC)=KEVOLL
  132. C
  133. TYPX='LISTREEL'
  134. TYPY='LISTREEL'
  135. c KEVTEX=TI
  136. KEVTEX=KEVOL1.KEVTEX
  137. NOMEVX=MOTX1
  138. IF (IFLO.EQ.1) THEN
  139. WRITE(MOTY3,'(I4)') INT(XP1)
  140. NOMEVY=MOTY1(1:4)//'**'//MOTY3(1:4)
  141. ELSE
  142. WRITE(MOTY3,'(F4.1)') XP1
  143. NOMEVY=MOTY1(1:4)//'** '//MOTY3(1:4)
  144. ENDIF
  145. cbp NUMEVX=ICOUL
  146. cbp tant qu'on peut, on conserve la couleur
  147. if(ICOUL.ne.0) then
  148. NUMEVX = ICOUL-1
  149. else
  150. NUMEVX = KEVOL1.NUMEVX
  151. endif
  152. NUMEVY='REEL'
  153. C
  154. JG=L1
  155. SEGINI,MLREE3=MLREE1
  156. IPROGX=MLREE3
  157. SEGINI,MLREE4
  158. IPROGY=MLREE4
  159. c IF (XP1.GT.0.) THEN
  160. c DO 20 I=1,L1
  161. c X=MLREE1.PROG(I)
  162. c Y=MLREE2.PROG(I)
  163. c MLREE3.PROG(I)=X
  164. c MLREE4.PROG(I)=Y**XP1
  165. c 20 CONTINUE
  166. c ELSE
  167. c DO 21 I=1,L1
  168. c X=MLREE1.PROG(I)
  169. c Y=MLREE2.PROG(I)
  170. c MLREE3.PROG(I)=X
  171. c IF (Y.GT.1.E-20) THEN
  172. c MLREE4.PROG(I)=Y**XP1
  173. c ELSE
  174. c GOTO 1001
  175. c ENDIF
  176. c 21 CONTINUE
  177. c ENDIF
  178. c
  179. c bp: ci dessus donne des NAN si Y<0 et XP1>0, on préfère :
  180. c
  181. IF (IFLO.EQ.1) THEN
  182. DO 20 I=1,L1
  183. cbp2012 X=MLREE1.PROG(I)
  184. Y=MLREE2.PROG(I)
  185. cbp2012 MLREE3.PROG(I)=X
  186. MLREE4.PROG(I)=Y**IP1
  187. 20 CONTINUE
  188. TEST1=IP1.lt.0
  189. c bp (05/2012) : ajout du cas SQRT
  190. ELSEIF(XP1.eq.0.5D0) THEN
  191. DO 21 I=1,L1
  192. cbp2012 X=MLREE1.PROG(I)
  193. Y=MLREE2.PROG(I)
  194. cbp2012 MLREE3.PROG(I)=X
  195. IF(Y.LT.0.D0) GOTO 1001
  196. MLREE4.PROG(I)=sqrt(Y)
  197. 21 CONTINUE
  198. TEST1 = .false.
  199. ELSE
  200. DO 22 I=1,L1
  201. cbp2012 X=MLREE1.PROG(I)
  202. Y=MLREE2.PROG(I)
  203. cbp2012 MLREE3.PROG(I)=X
  204. IF(Y.LT.0.D0) GOTO 1001
  205. MLREE4.PROG(I)=Y**XP1
  206. 22 CONTINUE
  207. TEST1=XP1.lt.0.D0
  208. ENDIF
  209. c
  210. c on ajoute un petit avertissement en présence d'INF
  211. c (pas une erreur car ce resultat peut etre intermediaire et
  212. c finalement 1/INF=0 donc on peut continuer)
  213. INF1=.false.
  214. if (TEST1) then
  215. do i=1,L1
  216. Y=MLREE4.PROG(i)
  217. if(Y.gt.XGRAND) INF1=.true.
  218. enddo
  219. endif
  220. if(INF1) write(IOIMP,*)
  221. & 'Attention: au moins une valeur est INFinie'
  222. C
  223. C DESACTIVE LES LISTREEL
  224. C
  225. SEGDES MLREE3,MLREE4
  226. SEGDES MLREE1,MLREE2
  227. C
  228. C DESACTIVE LES KEVOL
  229. C
  230. SEGDES KEVOLL
  231. SEGDES KEVOL1
  232. C
  233. 201 CONTINUE
  234. C
  235. C DESACTIVE LES MEVOL
  236. C
  237. SEGDES MEVOLL
  238. SEGDES MEVOL1
  239. C
  240. 100 CONTINUE
  241. RETURN
  242. 1000 CONTINUE
  243. MOTERR(1:8 )='EVOLUTIO'
  244. MOTERR(9:13)=KEVOL1.NUMEVY
  245. CALL ERREUR(131)
  246. RETURN
  247. 1001 CONTINUE
  248. CALL ERREUR(213)
  249. RETURN
  250. 2001 FORMAT(I1)
  251. 2002 FORMAT(I2)
  252. 2003 FORMAT(I3)
  253. 2004 FORMAT(I4)
  254. END
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  

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