Télécharger poirig.eso

Retour à la liste

Numérotation des lignes :

  1. C POIRIG SOURCE KICH 12/10/17 21:15:01 7531
  2. SUBROUTINE POIRIG(IPIRG,IMUL)
  3. C
  4. C EXTRACTION DE MAILLAGE D'UNE RIGIDITE
  5. C
  6. C----------------------------------------------------------------------
  7. C IMUL = 1 ON VEUT TOUS LES NOEUDS SAUF CEUX DES MULTIPLICATEURS
  8. C IMUL = 2 ON NE VEUT QUE LES NOEUDS DES MULTIPLICATEURS
  9. C IMUL = 3 ON NE VEUT QUE LES MULTILICATEURS ASSOCIES AUX JEUX
  10. C OU LES ELEMENTS GEOMETRQIUES DES CONTACTS UNILATERAUX
  11. C----------------------------------------------------------------------
  12. IMPLICIT INTEGER(I-N)
  13. -INC SMRIGID
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17. logical ltelq
  18. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  19. SEGMENT MULTRI
  20. INTEGER ICTC(XCOOR(/1)/(IDIM+1),3)
  21. ENDSEGMENT
  22. SEGMENT INDIC(0)
  23. CHARACTER NOMU(1)*4
  24. DATA NOMU /'TRI3'/
  25.  
  26. MRIGID=IPIRG
  27. if (mrigid.le.0) then
  28. call erreur(26)
  29. return
  30. endif
  31. SEGACT MRIGID
  32. NR=IRIGEL(/2)
  33. IPP1=0
  34. IF(IMUL.NE.3) GO TO 1000
  35. C
  36. C cas de l'extraction des multiplicateurs associes a des conditions
  37. C unilaterales option 'UNIL'
  38. C
  39. CALL LIRMOT(NOMU,1,IRET,0)
  40. C
  41. IF (IRET.EQ.1) THEN
  42. C cas ou l'on sort des tri3
  43. ITRI3 = 0
  44. C itri3 ets le nombre de tri3 generes
  45. SEGINI MULTRI
  46. DO 500 I=1,NR
  47. IF(IRIGEL(6,I).EQ.0) GO TO 500
  48. MELEME = IRIGEL( 1,I)
  49. IF (MELEME .EQ. 0) GO TO 500
  50. SEGACT MELEME
  51. IF ( ITYPEL.NE.22) THEN
  52. CALL ERREUR(5)
  53. SEGDES MELEME
  54. RETURN
  55. ENDIF
  56. IF ( NUM(/1) .EQ. 5 ) THEN
  57. C les élements contiennent 3 points geometriques
  58. DO 510 J=1,NUM(/2)
  59. ITRI3 = ITRI3 + 1
  60. ICTC(ITRI3,1)=NUM(3,J)
  61. ICTC(ITRI3,2)=NUM(4,J)
  62. ICTC(ITRI3,3)=NUM(5,J)
  63. 510 CONTINUE
  64. ENDIF
  65. SEGDES MELEME
  66. 500 CONTINUE
  67. C construction de l'objet meleme
  68. NBSOUS = 0
  69. NBREF = 0
  70. NBNN = 3
  71. NBELEM = ITRI3
  72. SEGINI MELEME
  73. ITYPEL = 4
  74. DO 520 I=1,ITRI3
  75. C ici on peut tester si les elements sont bien orientes
  76. C avec l'inversion 2,1 ca devrait marcher
  77. NUM(1,I)=ICTC(I,2)
  78. NUM(2,I)=ICTC(I,1)
  79. NUM(3,I)=ICTC(I,3)
  80. 520 CONTINUE
  81. SEGDES MELEME
  82. SEGSUP MULTRI
  83. CALL ECROBJ('MAILLAGE',MELEME)
  84. RETURN
  85. ENDIF
  86. C
  87. C cas ou l'on ne sort que les points supports des
  88. C multiplicateurs de conditions unilaterales
  89. C octobre 2010 on met en queue les frottements
  90. C
  91. SEGINI ICPR
  92. DO 1100 I=1,NR
  93. IF(IRIGEL(6,I).EQ.0) GO TO 1100
  94. ityp=irigel(6,i)
  95. MELEME = IRIGEL( 1,I)
  96. IF (MELEME .EQ. 0) GO TO 1100
  97. SEGACT MELEME
  98. IF ( ITYPEL.NE.22) THEN
  99. SEGDES MELEME
  100. GO TO 1100
  101. ENDIF
  102. DO 1101 J=1,NUM(/2)
  103. ICPR(NUM(1,J))=ityp
  104. 1101 CONTINUE
  105. SEGDES MELEME
  106. 1100 CONTINUE
  107. NBELEM=0
  108. DO 1102 I=1,ICPR(/1)
  109. if (icpr(i).ne.0) NBELEM=NBELEM + 1
  110. 1102 CONTINUE
  111. NBNN = 1
  112. NBSOUS=0
  113. NBREF=0
  114. SEGINI MELEME
  115. IA=1
  116. ITYPEL=1
  117. DO 1103 I=1,ICPR(/1)
  118. IF( ICPR(I).ne.-1) GO TO 1103
  119. NUM(1,IA)=I
  120. IA = IA + 1
  121. 1103 CONTINUE
  122. DO 1104 I=1,ICPR(/1)
  123. IF( ICPR(I).ne. 1) GO TO 1104
  124. NUM(1,IA)=I
  125. IA = IA + 1
  126. 1104 CONTINUE
  127. DO 1105 I=1,ICPR(/1)
  128. IF( ICPR(I).ne. 2) GO TO 1105
  129. NUM(1,IA)=I
  130. IA = IA + 1
  131. 1105 CONTINUE
  132. SEGDES MELEME
  133. CALL ECROBJ('MAILLAGE',MELEME)
  134. SEGSUP ICPR
  135. RETURN
  136. C
  137. C CAS IMUL = 1 OU 2
  138. C
  139. C BOUCLE SUR LES RIGIDITES ELEMENTAIRES
  140. C
  141. 1000 CONTINUE
  142. SEGINI INDIC
  143. DO 191 I=1,NR
  144. IGEO=IRIGEL(1,I)
  145. MELEME=IGEO
  146. SEGACT MELEME
  147. C
  148. C TEST SUR LE TYPE D ELEMENT ( EGAL A MULT ? )
  149. C
  150. IF(ITYPEL.NE.22) THEN
  151. SEGDES MELEME
  152. IF(IMUL.EQ.2) GO TO 191
  153. IF(IPP1.EQ.0) THEN
  154. IPP1=IGEO
  155. GO TO 191
  156. ELSE
  157. IPP2=IGEO
  158. ltelq=.false.
  159. CALL FUSE(IPP1,IPP2,IRET,ltelq)
  160. IPP1=IRET
  161. GO TO 191
  162. ENDIF
  163. ELSE
  164. C
  165. C TRAITEMENT D'UN ELEMENT DE TYPE BLOCAGE,RELATION,....
  166. C
  167. IF(IMUL.EQ.1) THEN
  168. NBDEB=2
  169. NBFIN=NUM(/1)
  170. ELSE IF(IMUL.EQ.2) THEN
  171. NBDEB=1
  172. NBFIN=1
  173. ENDIF
  174. ENDIF
  175. C
  176. NBPOIN=NUM(/2)
  177. DO 199 J=1,NBPOIN
  178. DO 198 IJ=NBDEB,NBFIN
  179. C
  180. C BOUCLE SUR LES POINTS EXISTANTS
  181. C
  182. NINDIC=INDIC(/1)
  183. DO 302 IK=1,NINDIC,2
  184. IF(INDIC(IK).EQ.NUM(IJ,J)) GO TO 303
  185. 302 CONTINUE
  186. INDIC(**)=NUM(IJ,J)
  187. INDIC(**)=ICOLOR(J)
  188. 303 CONTINUE
  189. 198 CONTINUE
  190. 199 CONTINUE
  191. SEGDES MELEME
  192. 191 CONTINUE
  193. SEGDES MRIGID
  194. C
  195. C REMPLISSAGE DU RESULTAT
  196. C
  197. NBELEM=INDIC(/1)/2
  198. IF (NBELEM.EQ.0) THEN
  199. IF(IMUL.EQ.1) GO TO 211
  200. CALL ERREUR(18)
  201. RETURN
  202. ENDIF
  203. NBNN=1
  204. NBSOUS=0
  205. NBREF=0
  206. SEGINI IPT1
  207. IPT1.ITYPEL=1
  208. DO 1001 IP=1,NBELEM
  209. IP2=2*IP
  210. IP1=IP2-1
  211. IPT1.NUM(1,IP)=INDIC(IP1)
  212. IPT1.ICOLOR(IP)=INDIC(IP2)
  213. 1001 CONTINUE
  214. SEGDES IPT1
  215. IF(IPP1.EQ.0) THEN
  216. IPP1=IPT1
  217. ELSE
  218. ltelq=.false.
  219. CALL FUSE(IPP1,IPT1,IRET,ltelq)
  220. IPP1=IRET
  221. ENDIF
  222. 211 SEGSUP INDIC
  223. CALL ECROBJ('MAILLAGE',IPP1)
  224. RETURN
  225. END
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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