Télécharger pucher.eso

Retour à la liste

Numérotation des lignes :

  1. C PUCHER SOURCE CB215821 16/06/15 21:15:12 8967
  2. SUBROUTINE PUCHER(IPCHE1,XPU,IPCHPU,IRET)
  3. *_______________________________________________________________________
  4. *
  5. * ELEVATION A UNE PUISSANCE REEL D'UN CHAMELEM
  6. *
  7. * ENTREES :
  8. * ---------
  9. *
  10. * IPCHE1 POINTEUR SUR LE CHAMPS PAR ELEMENT A ELEVER A LA PUISSANCE
  11. * XPU
  12. * XPU PUISSANCE ( C EST UN REEL POSITIF OU NEGATIF )
  13. *
  14. *
  15. * SORTIES :
  16. * ---------
  17. *
  18. * IPCHPU POINTEUR SUR LE CHAMELEM RESULTANT
  19. * IPCHPU =0 SI PB
  20. * IRET=1
  21. * =0 SI UNE COMPOSANTE EST NEGATIVE
  22. *
  23. * CODE EBERSOLT AVRIL 85
  24. *
  25. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90
  26. *
  27. *_______________________________________________________________________
  28. *
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31. *
  32. -INC SMCHAML
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC SMLREEL
  37. -INC CCREEL
  38. *
  39. IRET=1
  40. MCHEL1=IPCHE1
  41. *
  42. * INITIALISATION DU CHAPEAU DU SEGMENT
  43. *
  44. SEGINI,MCHELM=MCHEL1
  45. IPCHPU=MCHELM
  46. NSOUS=ICHAML(/1)
  47.  
  48. C ON ORIENTE SELON LA VALEUR DE XPU (PERFORMANCES)
  49. IF (ABS(XPU-REAL(0.5D0)).LE.(XZPREC*ABS(XPU)*REAL(2.D0))) goto 100
  50.  
  51.  
  52. c----------------------------------------------------------------------
  53. c Cas général Y**XPU
  54. *
  55. * BOUCLE SUR LES SOUS ZONES
  56. *
  57. DO 30 ISOUS=1,NSOUS
  58. MCHAM1=ICHAML(ISOUS)
  59. SEGINI,MCHAML=MCHAM1
  60. ICHAML(ISOUS)=MCHAML
  61. DO 40 ICOMP=1,IELVAL(/1)
  62. MELVA1=IELVAL(ICOMP)
  63. SEGINI,MELVAL=MELVA1
  64. IELVAL(ICOMP)=MELVAL
  65. IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN
  66. N1PTEL=VELCHE(/1)
  67. N1EL =VELCHE(/2)
  68. DO 20 IB=1,N1EL
  69. DO 20 IGAU=1,N1PTEL
  70. XTRA=VELCHE(IGAU,IB)
  71. IF(ABS(XTRA).LT.XPETIT .AND. XPU.LT.REAL(0.D0))THEN
  72. IRET = 0
  73. RETURN
  74. ELSE
  75. C Verification si puissance ENTIERE possible
  76. I2 = NINT(XPU)
  77. XFLOT = ABS(XPU - REAL(I2))
  78. IF ( XFLOT .LE. (XZPREC*ABS(XPU)*REAL(2.D0))) THEN
  79. VELCHE(IGAU,IB) = XTRA**I2
  80. ELSEIF(XTRA .LT. REAL(0.D0))THEN
  81. IRET = 0
  82. RETURN
  83. ELSE
  84. VELCHE(IGAU,IB)= XTRA ** XPU
  85. ENDIF
  86. ENDIF
  87. 20 CONTINUE
  88. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  89. N2PTEL=IELCHE(/1)
  90. N2EL =IELCHE(/2)
  91. DO 10 IB=1,N2EL
  92. DO 10 IGAU=1,N2PTEL
  93. MLREE1=IELCHE(IGAU,IB)
  94. SEGACT MLREE1
  95. JG=MLREE1.PROG(/1)
  96. SEGINI MLREEL
  97. DO 11 IPROG=1,JG
  98. XTRA=MLREE1.PROG(IPROG)
  99. IF(ABS(XTRA).LT.XPETIT .AND.
  100. & XPU.LT.REAL(0.D0))THEN
  101. IRET = 0
  102. RETURN
  103. ELSE
  104. C Verification si puissance ENTIERE possible
  105. I2 = NINT(XPU)
  106. XFLOT = ABS(XPU - REAL(I2))
  107. IF ( XFLOT .LE.
  108. & (XZPREC*ABS(XPU)*REAL(2.D0))) THEN
  109. PROG(IPROG) = XTRA**I2
  110. ELSEIF(XTRA .LT. REAL(0.D0))THEN
  111. IRET = 0
  112. RETURN
  113. ELSE
  114. PROG(IPROG)= XTRA ** XPU
  115. ENDIF
  116. ENDIF
  117. 11 CONTINUE
  118. IELCHE(IGAU,IB)=MLREEL
  119. SEGDES MLREE1,MLREEL
  120. 10 CONTINUE
  121. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  122. N2PTEL=IELCHE(/1)
  123. N2EL =IELCHE(/2)
  124. DO 12 IB=1,N2EL
  125. DO 12 IGAU=1,N2PTEL
  126. MEVOL1=IELCHE(IGAU,IB)
  127. IRET=2
  128. CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET)
  129. IELCHE(IGAU,IB)=MEVOL2
  130. 12 CONTINUE
  131. ELSE
  132. *
  133. * NOM DE COMPOSANTE NON RECONNU
  134. *
  135. MOTERR(1:4)='** '
  136. MOTERR(5:8)=NOMCHE(ICOMP)
  137. CALL ERREUR(335)
  138. SEGSUP MELVAL,MCHAML,MCHELM
  139. IPCHPU=0
  140. RETURN
  141. ENDIF
  142. SEGDES MELVAL
  143. 40 CONTINUE
  144. SEGDES MCHAML
  145. 30 CONTINUE
  146. GOTO 999
  147.  
  148.  
  149. c----------------------------------------------------------------------
  150. c Cas : Y**0.5
  151. 100 CONTINUE
  152. *
  153. * BOUCLE SUR LES SOUS ZONES
  154. *
  155. DO 130 ISOUS=1,NSOUS
  156. MCHAM1=ICHAML(ISOUS)
  157. SEGINI,MCHAML=MCHAM1
  158. ICHAML(ISOUS)=MCHAML
  159. DO 140 ICOMP=1,IELVAL(/1)
  160. MELVA1=IELVAL(ICOMP)
  161. SEGINI,MELVAL=MELVA1
  162. IELVAL(ICOMP)=MELVAL
  163. IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN
  164. N1PTEL=VELCHE(/1)
  165. N1EL =VELCHE(/2)
  166. DO 120 IB=1,N1EL
  167. DO 120 IGAU=1,N1PTEL
  168. XTRA=VELCHE(IGAU,IB)
  169. IF(XTRA .LT. REAL(0.D0))THEN
  170. IRET = 0
  171. RETURN
  172. ELSE
  173. VELCHE(IGAU,IB)= SQRT(XTRA)
  174. ENDIF
  175. 120 CONTINUE
  176. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  177. N2PTEL=IELCHE(/1)
  178. N2EL =IELCHE(/2)
  179. DO 110 IB=1,N2EL
  180. DO 110 IGAU=1,N2PTEL
  181. MLREE1=IELCHE(IGAU,IB)
  182. SEGACT MLREE1
  183. JG=MLREE1.PROG(/1)
  184. SEGINI MLREEL
  185. DO 111 IPROG=1,JG
  186. XTRA=MLREE1.PROG(IPROG)
  187. IF(XTRA .LT. REAL(0.D0))THEN
  188. IRET = 0
  189. RETURN
  190. ELSE
  191. PROG(IPROG)= SQRT(XTRA)
  192. ENDIF
  193. 111 CONTINUE
  194. IELCHE(IGAU,IB)=MLREEL
  195. SEGDES MLREE1,MLREEL
  196. 110 CONTINUE
  197. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  198. N2PTEL=IELCHE(/1)
  199. N2EL =IELCHE(/2)
  200. DO 112 IB=1,N2EL
  201. DO 112 IGAU=1,N2PTEL
  202. MEVOL1=IELCHE(IGAU,IB)
  203. IRET=2
  204. CALL PUEVOL(MEVOL1,XPU,0,MEVOL2,IRET)
  205. IELCHE(IGAU,IB)=MEVOL2
  206. 112 CONTINUE
  207. ELSE
  208. *
  209. * NOM DE COMPOSANTE NON RECONNU
  210. *
  211. MOTERR(1:4)='** '
  212. MOTERR(5:8)=NOMCHE(ICOMP)
  213. CALL ERREUR(335)
  214. SEGSUP MELVAL,MCHAML,MCHELM
  215. IPCHPU=0
  216. RETURN
  217. ENDIF
  218. SEGDES MELVAL
  219. 140 CONTINUE
  220. SEGDES MCHAML
  221. 130 CONTINUE
  222. GOTO 999
  223.  
  224.  
  225.  
  226. c----------------------------------------------------------------------
  227. c FIN DU PROGRAMME
  228. 999 CONTINUE
  229. SEGDES MCHELM
  230. RETURN
  231. END
  232.  
  233.  
  234.  

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