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.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCREEL
  35. -INC SMLREEL
  36. -INC SMEVOLL
  37. *
  38. IRET=1
  39. MCHEL1=IPCHE1
  40. *
  41. * INITIALISATION DU CHAPEAU DU SEGMENT
  42. *
  43. SEGINI,MCHELM=MCHEL1
  44. IPCHPU=MCHELM
  45. *
  46. * BOUCLE SUR LES SOUS ZONES
  47. *
  48. DO 30 ISOUS=1,ICHAML(/1)
  49. MCHAM1=ICHAML(ISOUS)
  50. SEGINI,MCHAML=MCHAM1
  51. ICHAML(ISOUS)=MCHAML
  52. DO 40 ICOMP=1,IELVAL(/1)
  53. MELVA1=IELVAL(ICOMP)
  54. SEGINI,MELVAL=MELVA1
  55. IELVAL(ICOMP)=MELVAL
  56. IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN
  57. N1PTEL=VELCHE(/1)
  58. N1EL =VELCHE(/2)
  59. DO 20 IGAU=1,N1PTEL
  60. DO 20 IB=1,N1EL
  61. XTRA=VELCHE(IGAU,IB)
  62. if (abs(xtra).lt.xpetit.and.ipu.lt.0) then
  63. IRET = 0
  64. RETURN
  65. else
  66. VELCHE(IGAU,IB)=XTRA ** IPU
  67. endif
  68. 20 CONTINUE
  69. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  70. N2PTEL=IELCHE(/1)
  71. N2EL =IELCHE(/2)
  72. DO 10 IGAU=1,N2PTEL
  73. DO 10 IB=1,N2EL
  74. MLREE1=IELCHE(IGAU,IB)
  75. SEGACT MLREE1
  76. JG=MLREE1.PROG(/1)
  77. SEGINI MLREEL
  78. DO 11 IPROG=1,JG
  79. XTRA=MLREE1.PROG(IPROG)
  80. IF(abs(xtra).lt.xpetit.and.ipu.lt.0)THEN
  81. IRET = 0
  82. RETURN
  83. ELSE
  84. PROG(IPROG)=XTRA ** IPU
  85. ENDIF
  86. 11 CONTINUE
  87. IELCHE(IGAU,IB)=MLREEL
  88. SEGDES MLREE1,MLREEL
  89. 10 CONTINUE
  90. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  91. N2PTEL=IELCHE(/1)
  92. N2EL =IELCHE(/2)
  93. DO 12 IGAU=1,N2PTEL
  94. DO 12 IB=1,N2EL
  95. MEVOL1=IELCHE(IGAU,IB)
  96. c XFLO=REAL(IPU)
  97. IRET=1
  98. CALL PUEVOL(MEVOL1,0.D0,IPU,MEVOL2,IRET)
  99. IELCHE(IGAU,IB)=MEVOL2
  100. 12 CONTINUE
  101. ELSE
  102. *
  103. * NOM DE COMPOSANTE NON RECONNU
  104. *
  105. MOTERR(1:4)='** '
  106. MOTERR(5:8)=NOMCHE(ICOMP)
  107. CALL ERREUR(335)
  108. SEGSUP MELVAL,MCHAML,MCHELM
  109. IPCHPU=0
  110. RETURN
  111. ENDIF
  112. SEGDES MELVAL
  113. 40 CONTINUE
  114. SEGDES MCHAML
  115. 30 CONTINUE
  116. SEGDES MCHELM
  117. RETURN
  118. END
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  

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