Télécharger extr14.eso

Retour à la liste

Numérotation des lignes :

  1. C EXTR14 SOURCE CB215821 19/08/20 21:17:30 10287
  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. SEGINI MLMOTS
  47. IPMOTS=MLMOTS
  48. MOTS(1)=CTEXT
  49. SEGDES MLMOTS
  50. CALL ECROBJ('LISTMOTS',IPMOTS)
  51. RETURN
  52. ELSE IF (MOT.EQ.'MAIL') THEN
  53. N1 = IMACHE(/1)
  54. IF ( N1 .EQ. 0) THEN
  55. C Cas du MCHAML VIDE ==> MAILLAGE VIDE
  56. NBELEM=0
  57. NBNN =NBNNE(ILCOUR)
  58. NBREF =0
  59. NBSOUS=0
  60. SEGINI MELEME
  61. ITYPEL = ILCOUR
  62. IPP1 = MELEME
  63. ELSE
  64. IPP1=IMACHE(1)
  65. IF(NSOUS.GT.1) THEN
  66. DO 30 I=2,NSOUS
  67. IPP2=IMACHE(I)
  68. ltelq=.false.
  69. CALL FUSE (IPP1,IPP2,IRET,ltelq)
  70. IPP1=IRET
  71. 30 CONTINUE
  72. ENDIF
  73. ENDIF
  74. CALL ACTOBJ('MAILLAGE',IPP1,1)
  75. CALL ECROBJ('MAILLAGE',IPP1)
  76. GOTO 555
  77. ENDIF
  78. C
  79. IF (IENT1.GT.NSOUS) THEN
  80. C
  81. C Sous zone inexistante
  82. C
  83. CALL ERREUR(279)
  84. GOTO 555
  85. ENDIF
  86. C
  87. MELEME=IMACHE(IENT1)
  88. SEGACT MELEME
  89. NBELEM=NUM(/2)
  90. NBPGAU=NUM(/1)
  91. C
  92. N3=INFCHE(/2)
  93. IF (N3.GE.4) THEN
  94. MINTE=INFCHE(IENT1,4)
  95. IF(MINTE.NE.0)THEN
  96. SEGACT MINTE
  97. NBPGAU=POIGAU(/1)
  98. ENDIF
  99. ENDIF
  100. C
  101. IF (IENT3.GT.NBPGAU.OR.IENT2.GT.NBELEM) THEN
  102. C
  103. C Numero du point de gauss ou de l'element trop grand
  104. C
  105. CALL ERREUR(281)
  106. GOTO 555
  107. ENDIF
  108. C
  109. MCHAML=ICHAML(IENT1)
  110. SEGACT MCHAML
  111. NCOMP=IELVAL(/1)
  112. DO 100 ICOMP=1,NCOMP
  113. IF (MOT.EQ.NOMCHE(ICOMP)) GOTO 200
  114. 100 CONTINUE
  115. C
  116. C Composante inexistante
  117. C
  118. CALL ERREUR (280)
  119. GOTO 444
  120. C
  121. 200 CONTINUE
  122. MELVAL=IELVAL(ICOMP)
  123. SEGACT MELVAL
  124. C+PP
  125. IF(TYPCHE(ICOMP)(1:6).EQ.'REAL*8')THEN
  126. IGMN=MIN(IENT3,VELCHE(/1))
  127. IBMN=MIN(IENT2,VELCHE(/2))
  128. FLOX=VELCHE(IGMN,IBMN)
  129. CALL ECRREE(FLOX)
  130. ELSE
  131. TYPOBJ=TYPCHE(ICOMP)(9:16)
  132. IGMN=MIN(IENT3,IELCHE(/1))
  133. IBMN=MIN(IENT2,IELCHE(/2))
  134. IPOOBJ=IELCHE(IGMN,IBMN)
  135. C Gestion des pointeurs nuls (et oui, ca arrive)
  136. IF (IPOOBJ.EQ.0) THEN
  137. MOTERR(1:8)=TYPOBJ
  138. CALL ERREUR(356)
  139. ENDIF
  140. CALL ACTOBJ(TYPOBJ,IPOOBJ,1)
  141. CALL ECROBJ(TYPOBJ,IPOOBJ)
  142. ENDIF
  143. C+PP
  144. C
  145. 444 CONTINUE
  146. C
  147. 555 CONTINUE
  148. END
  149.  
  150.  
  151.  

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