Télécharger extr14.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR14 SOURCE BP208322 16/11/18 21:16:52 9177
  2. SUBROUTINE EXTR14(IPCHE1,IENT1,IENT2,IENT3,MOT)
  3. C_____________________________________________________________________
  4. C
  5. C Extrait une composante d'un MCHAML
  6. C
  7. C Entrees :
  8. C ---------
  9. C
  10. C IPCHE1 Pointeur sur un MCHAML
  11. C IENT1 Numero de la sous zone
  12. C IENT2 Numero de l'element
  13. C IENT3 Numero du point de gauss
  14. C MOT Nom de la composante a extraire ou mot cle indiquant
  15. C l'action a effectuer (TITR = TYPE ou MAIL)
  16. C
  17. C JM CAMPENON le 07/91
  18. C C La Borderie le 21/07/92 :possibilite d'extraire une composante entiere
  19. C PP 21/12/92 :extension a l'extraction d'un objet de type quelconque
  20. C_____________________________________________________________________
  21. C
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8(A-H,O-Z)
  24. C
  25. -INC CCOPTIO
  26. -INC CCGEOME
  27. -INC SMCHAML
  28. -INC SMINTE
  29. -INC SMLMOTS
  30. -INC SMELEME
  31. C
  32. logical ltelq
  33. REAL*8 FLOX
  34. CHARACTER*4 MOT
  35. CHARACTER*8 TYPOBJ
  36. CHARACTER*72 CTEXT
  37. C
  38. MCHELM=IPCHE1
  39. SEGACT MCHELM
  40. NSOUS=ICHAML(/1)
  41. C
  42. IF ((MOT.EQ.'TITR').OR.(MOT.EQ.'TYPE')) THEN
  43. JGM=1
  44. JGN=TITCHE(/1)
  45. CTEXT=TITCHE
  46. SEGDES MCHELM
  47. SEGINI MLMOTS
  48. IPMOTS=MLMOTS
  49. MOTS(1)=CTEXT
  50. SEGDES MLMOTS
  51. CALL ECROBJ('LISTMOTS',IPMOTS)
  52. RETURN
  53. ELSE IF (MOT.EQ.'MAIL') THEN
  54. N1 = IMACHE(/1)
  55. IF ( N1 .EQ. 0) THEN
  56. C Cas du MCHAML VIDE ==> MAILLAGE VIDE
  57. NBELEM=0
  58. NBNN =NBNNE(ILCOUR)
  59. NBREF =0
  60. NBSOUS=0
  61. SEGINI MELEME
  62. ITYPEL = ILCOUR
  63. IPP1 = MELEME
  64. SEGDES,MELEME
  65. ELSE
  66. IPP1=IMACHE(1)
  67. IF(NSOUS.GT.1) THEN
  68. DO 30 I=2,NSOUS
  69. IPP2=IMACHE(I)
  70. ltelq=.false.
  71. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  72. IPP1=IRET
  73. 30 CONTINUE
  74. ENDIF
  75. ENDIF
  76. CALL ECROBJ('MAILLAGE',IPP1)
  77. GOTO 555
  78. ENDIF
  79. C
  80. IF (IENT1.GT.NSOUS) THEN
  81. C
  82. C Sous zone inexistante
  83. C
  84. CALL ERREUR(279)
  85. GOTO 555
  86. ENDIF
  87. C
  88. MELEME=IMACHE(IENT1)
  89. SEGACT MELEME
  90. NBELEM=NUM(/2)
  91. NBPGAU=NUM(/1)
  92. SEGDES MELEME
  93. C
  94. N3=INFCHE(/2)
  95. IF (N3.GE.4) THEN
  96. MINTE=INFCHE(IENT1,4)
  97. IF(MINTE.NE.0)THEN
  98. SEGACT MINTE
  99. NBPGAU=POIGAU(/1)
  100. SEGDES MINTE
  101. ENDIF
  102. ENDIF
  103. C
  104. IF (IENT3.GT.NBPGAU.OR.IENT2.GT.NBELEM) THEN
  105. C
  106. C Numero du point de gauss ou de l'element trop grand
  107. C
  108. CALL ERREUR(281)
  109. GOTO 555
  110. ENDIF
  111. C
  112. MCHAML=ICHAML(IENT1)
  113. SEGACT MCHAML
  114. NCOMP=IELVAL(/1)
  115. DO 100 ICOMP=1,NCOMP
  116. IF (MOT.EQ.NOMCHE(ICOMP)) GOTO 200
  117. 100 CONTINUE
  118. C
  119. C Composante inexistante
  120. C
  121. CALL ERREUR (280)
  122. GOTO 444
  123. C
  124. 200 CONTINUE
  125. MELVAL=IELVAL(ICOMP)
  126. SEGACT MELVAL
  127. C+PP
  128. IF(TYPCHE(ICOMP)(1:6).EQ.'REAL*8')THEN
  129. IGMN=MIN(IENT3,VELCHE(/1))
  130. IBMN=MIN(IENT2,VELCHE(/2))
  131. FLOX=VELCHE(IGMN,IBMN)
  132. CALL ECRREE(FLOX)
  133. ELSE
  134. TYPOBJ=TYPCHE(ICOMP)(9:16)
  135. IGMN=MIN(IENT3,IELCHE(/1))
  136. IBMN=MIN(IENT2,IELCHE(/2))
  137. IPOOBJ=IELCHE(IGMN,IBMN)
  138. CALL ECROBJ(TYPOBJ,IPOOBJ)
  139. ENDIF
  140. C+PP
  141. SEGDES MELVAL
  142. C
  143. 444 CONTINUE
  144. SEGDES MCHAML
  145. C
  146. 555 CONTINUE
  147. SEGDES MCHELM
  148. RETURN
  149. END
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  

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