Télécharger puchel.eso

Retour à la liste

Numérotation des lignes :

  1. C PUCHEL SOURCE CB215821 16/06/15 21:15:11 8967
  2. SUBROUTINE PUCHEL(IPCHE1,IPU,IPCHPU,IRET)
  3. *_______________________________________________________________________
  4. *
  5. * ELEVATION A UNE PUISSANCE ENTIERE D'UN CHAMELEM
  6. *
  7. * ENTREES :
  8. * ---------
  9. *
  10. * IPCHE1 POINTEUR SUR LE CHAMPS PAR ELEMENT A ELEVER A LA PUISSANC
  11. * IPU
  12. * IPU PUISSANCE ( C EST UN ENTIER POSITIF OU NEGATIF )
  13. *
  14. *
  15. * SORTIES :
  16. * ---------
  17. *
  18. * IPCHPU POINTEUR SUR LE CHAMELEM RESULTANT
  19. * IRET=1
  20. * =0 SI OPERATION IMPOSSSIBLE
  21. *
  22. * CODE EBERSOLT AVRIL 85
  23. *
  24. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90
  25. *
  26. *_______________________________________________________________________
  27. *
  28. IMPLICIT REAL*8 (A-H,O-Z)
  29. IMPLICIT INTEGER(I-N)
  30. -INC SMCHAML
  31. -INC CCOPTIO
  32. -INC CCREEL
  33. -INC SMLREEL
  34. -INC SMEVOLL
  35. *
  36. IRET=1
  37. MCHEL1=IPCHE1
  38. *
  39. * INITIALISATION DU CHAPEAU DU SEGMENT
  40. *
  41. SEGINI,MCHELM=MCHEL1
  42. IPCHPU=MCHELM
  43. *
  44. * BOUCLE SUR LES SOUS ZONES
  45. *
  46. DO 30 ISOUS=1,ICHAML(/1)
  47. MCHAM1=ICHAML(ISOUS)
  48. SEGINI,MCHAML=MCHAM1
  49. ICHAML(ISOUS)=MCHAML
  50. DO 40 ICOMP=1,IELVAL(/1)
  51. MELVA1=IELVAL(ICOMP)
  52. SEGINI,MELVAL=MELVA1
  53. IELVAL(ICOMP)=MELVAL
  54. IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN
  55. N1PTEL=VELCHE(/1)
  56. N1EL =VELCHE(/2)
  57. DO 20 IGAU=1,N1PTEL
  58. DO 20 IB=1,N1EL
  59. XTRA=VELCHE(IGAU,IB)
  60. if (abs(xtra).lt.xpetit.and.ipu.lt.0) then
  61. IRET = 0
  62. RETURN
  63. else
  64. VELCHE(IGAU,IB)=XTRA ** IPU
  65. endif
  66. 20 CONTINUE
  67. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  68. N2PTEL=IELCHE(/1)
  69. N2EL =IELCHE(/2)
  70. DO 10 IGAU=1,N2PTEL
  71. DO 10 IB=1,N2EL
  72. MLREE1=IELCHE(IGAU,IB)
  73. SEGACT MLREE1
  74. JG=MLREE1.PROG(/1)
  75. SEGINI MLREEL
  76. DO 11 IPROG=1,JG
  77. XTRA=MLREE1.PROG(IPROG)
  78. IF(abs(xtra).lt.xpetit.and.ipu.lt.0)THEN
  79. IRET = 0
  80. RETURN
  81. ELSE
  82. PROG(IPROG)=XTRA ** IPU
  83. ENDIF
  84. 11 CONTINUE
  85. IELCHE(IGAU,IB)=MLREEL
  86. SEGDES MLREE1,MLREEL
  87. 10 CONTINUE
  88. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  89. N2PTEL=IELCHE(/1)
  90. N2EL =IELCHE(/2)
  91. DO 12 IGAU=1,N2PTEL
  92. DO 12 IB=1,N2EL
  93. MEVOL1=IELCHE(IGAU,IB)
  94. c XFLO=REAL(IPU)
  95. IRET=1
  96. CALL PUEVOL(MEVOL1,0.D0,IPU,MEVOL2,IRET)
  97. IELCHE(IGAU,IB)=MEVOL2
  98. 12 CONTINUE
  99. ELSE
  100. *
  101. * NOM DE COMPOSANTE NON RECONNU
  102. *
  103. MOTERR(1:4)='** '
  104. MOTERR(5:8)=NOMCHE(ICOMP)
  105. CALL ERREUR(335)
  106. SEGSUP MELVAL,MCHAML,MCHELM
  107. IPCHPU=0
  108. RETURN
  109. ENDIF
  110. SEGDES MELVAL
  111. 40 CONTINUE
  112. SEGDES MCHAML
  113. 30 CONTINUE
  114. SEGDES MCHELM
  115. RETURN
  116. END
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  

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