Télécharger impos4.eso

Retour à la liste

Numérotation des lignes :

  1. C IMPOS4 SOURCE CHAT 09/10/09 21:19:01 6519
  2. SUBROUTINE IMPOS4
  3. c
  4. c sous routine pour l'opérateur IMPO option CONT
  5. c qui donne le contour des contacts à partir de la rigidite
  6. c active calculée par impos4.eso
  7. c
  8. c
  9. c
  10. c entree:
  11. c IPRIG pointeur sur l
  12. c sortie:
  13. c MAIL2 = contour des surfaces en contact formé d'elements SEG2
  14. c
  15. c
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8 (A-H,O-Z)
  18. LOGICAL FLAG1
  19. -INC CCOPTIO
  20. -INC SMCOORD
  21. -INC SMELEME
  22. -INC SMRIGID
  23. -INC SMCHPOI
  24. SEGMENT MCTC
  25. c mctc contient les surface en vis a vis
  26. INTEGER IPOT1(NNO1)
  27. INTEGER IPOT2(NNO2)
  28. ENDSEGMENT
  29. POINTEUR MCTC1.MCTC,MCTC2.MCTC
  30. c
  31. SEGMENT LCTC
  32. c imctc pointe vers les mctc
  33. INTEGER IMCTC(NBELEM,2)
  34. ENDSEGMENT
  35. c
  36. SEGMENT MPLX
  37. c contient les numero de points qui supportent un composante
  38. c 'lx'
  39. INTEGER IPLX(NPLX)
  40. ENDSEGMENT
  41. c
  42. c executable:
  43. IF ( IDIM .NE. 2 ) THEN
  44. INTERR(1) = IDIM
  45. RETURN
  46. ENDIF
  47. c
  48. CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)
  49. IF (IERR.NE.0) RETURN
  50. CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU)
  51. IF (IERR.NE.0) RETURN
  52. c
  53. SEGACT MCHPOI
  54. NPLX = 0
  55. SEGINI MPLX
  56. c boucle sur les msoupo pour remplir mplx de tous les points
  57. c supportant une composante nommée 'lx'
  58. DO 300 I=1,IPCHP(/1)
  59. MSOUPO = IPCHP(I)
  60. SEGACT MSOUPO
  61. c boucle sur les noms de composantes
  62. DO 200 J=1,NOCOMP(/1)
  63. IF ( NOCOMP(J) .EQ. 'LX' ) THEN
  64. IPT1 = IGEOC
  65. SEGACT IPT1
  66. NNPLX = NPLX
  67. * print *, 'nplx=',nplx
  68. NPLX = NPLX + IPT1.NUM(/2)
  69. SEGADJ MPLX
  70. c on remplit mplx
  71. DO 100 K = 1,IPT1.NUM(/2)
  72. * print *,'noeud actif',IPT1.NUM(1,K)
  73. IPLX(NNPLX+K)=IPT1.NUM(1,K)
  74. 100 CONTINUE
  75. SEGDES IPT1
  76. ENDIF
  77. 200 CONTINUE
  78. SEGDES MSOUPO
  79. 300 CONTINUE
  80. SEGDES MCHPOI
  81. *
  82. * PRINT *,'nplx=',nplx
  83. *
  84. c
  85. SEGACT MELEME
  86. c on attend un maillage d'elements type 22 a 4 noeuds
  87. IF (ITYPEL .NE. 22 .OR. NUM(/1) .NE. 4) THEN
  88. CALL ERREUR(26)
  89. ENDIF
  90. c
  91. NBELEM = NUM(/2)
  92. NB = NBELEM
  93. *
  94. * PRINT *,'NBELEM=',nbelem
  95. *
  96. * remplissage du segment lctc
  97. *
  98. SEGINI LCTC
  99. DO 600 I=1,NBELEM
  100. c l'element est il actif
  101. I1 = NUM(1,I)
  102. * print *,'noeud lx ',i1
  103. FLAG1 = .FALSE.
  104. DO 400 J=1,NPLX
  105. IF (IPLX(J) .EQ. I1 ) FLAG1 = .TRUE.
  106. 400 CONTINUE
  107. c
  108. IF (FLAG1) THEN
  109. *
  110. * PRINT *,'element actif'
  111. *
  112. c l'element est actif on cree un mctc elementaire de trois points
  113. NNO1 = 2
  114. NNO2 = 1
  115. SEGINI MCTC
  116. IM2 = MCTC
  117. IPOT1(1) = NUM(2,I)
  118. IPOT1(2) = NUM(3,I)
  119. IPOT2(1) = NUM(4,I)
  120. c
  121. DO 500 J=1,I-1
  122. c on test si le mctc a un point commun avec
  123. c ceux deja mis
  124. IM1 = IMCTC(J,1)
  125. IF ( IMCTC(J,2) .NE. 0) THEN
  126. * points communs ?
  127. CALL IMPOS5(IM1,IM2,IRET)
  128. IF (IRET .NE. 0) THEN
  129. * assemblage des deux mctc
  130. c im2 est remplace par le mctc resulatant de
  131. c l'assemblage
  132. CALL IMPOS6(IM1,IM2,IRET)
  133. c invalidation du mctc im1
  134. IMCTC(J,2)=0
  135. ENDIF
  136. ENDIF
  137. 500 CONTINUE
  138. IMCTC(I,1)=IM2
  139. IMCTC(I,2)=1
  140. c
  141. ENDIF
  142. 600 CONTINUE
  143. SEGDES MELEME
  144. c
  145. c creation du maillage correspondant formé de seg2
  146. c
  147. c
  148. NBELEM = 0
  149. DO 700 I=1,NB
  150. IF (IMCTC(I,2) .EQ. 1) THEN
  151. MCTC = IMCTC(I,1)
  152. NBELEM = NBELEM + IPOT1(/1) + IPOT2(/1)
  153. ENDIF
  154. 700 CONTINUE
  155. NBREF = 0
  156. NBNN = 2
  157. NBSOUS = 0
  158. SEGINI MELEME
  159. MAIL1 = MELEME
  160. ITYPEL = 2
  161. c
  162. INDI1 = 0
  163. DO 1000 I=1,NB
  164. MCTC = IMCTC(I,1)
  165. IF (IMCTC(I,2) .EQ. 1) THEN
  166. c ligne inferieure
  167. DO 800 J = 1,(IPOT1(/1)-1)
  168. INDI1 = INDI1 + 1
  169. NUM(1,INDI1)=IPOT1(J+1)
  170. NUM(2,INDI1)=IPOT1(J)
  171. 800 CONTINUE
  172. c premiere interconnection
  173. INDI1 = INDI1 + 1
  174. NNN = IPOT1(/1)
  175. NUM(1,INDI1 )=IPOT2(1)
  176. NUM(2,INDI1 )=IPOT1(NNN)
  177.  
  178. c ligne superieure
  179. DO 900 J = 1,(IPOT2(/1)-1)
  180. INDI1 = INDI1 + 1
  181. NUM(1,INDI1)=IPOT2(J+1)
  182. NUM(2,INDI1)=IPOT2(J)
  183. 900 CONTINUE
  184. c deuxieme interconnection
  185. INDI1 = INDI1 + 1
  186. NNN = IPOT2(/1)
  187. NUM(1,INDI1)=IPOT1(1)
  188. NUM(2,INDI1)=IPOT2(NNN)
  189. ENDIF
  190. SEGSUP MCTC
  191. 1000 CONTINUE
  192. c desactivation des meleme
  193. SEGSUP LCTC,MPLX
  194. MELEME = MAIL1
  195. SEGDES MELEME
  196. CALL ECROBJ('MAILLAGE',MELEME)
  197. RETURN
  198. END
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  

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