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

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