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

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