Télécharger poirig.eso

Retour à la liste

Numérotation des lignes :

  1. C POIRIG SOURCE PV 20/03/30 21:22:15 10567
  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.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19. logical ltelq
  20. SEGMENT ICPR(nbpts)
  21. SEGMENT MULTRI
  22. INTEGER ICTC(nbpts,3)
  23. ENDSEGMENT
  24. SEGMENT INDIC(0)
  25. CHARACTER NOMU(1)*4
  26. DATA NOMU /'TRI3'/
  27.  
  28. MRIGID=IPIRG
  29. if (mrigid.le.0) then
  30. call erreur(26)
  31. return
  32. endif
  33. SEGACT MRIGID
  34. NR=IRIGEL(/2)
  35. IPP1=0
  36. IF(IMUL.NE.3) GO TO 1000
  37. C
  38. C cas de l'extraction des multiplicateurs associes a des conditions
  39. C unilaterales option 'UNIL'
  40. C
  41. CALL LIRMOT(NOMU,1,IRET,0)
  42. C
  43. IF (IRET.EQ.1) THEN
  44. C cas ou l'on sort des tri3
  45. ITRI3 = 0
  46. C itri3 ets le nombre de tri3 generes
  47. SEGINI MULTRI
  48. DO 500 I=1,NR
  49. IF(IRIGEL(6,I).EQ.0) GO TO 500
  50. MELEME = IRIGEL( 1,I)
  51. IF (MELEME .EQ. 0) GO TO 500
  52. SEGACT MELEME
  53. IF ( ITYPEL.NE.22) THEN
  54. CALL ERREUR(5)
  55. RETURN
  56. ENDIF
  57. IF ( NUM(/1) .EQ. 5 ) THEN
  58. C les élements contiennent 3 points geometriques
  59. DO 510 J=1,NUM(/2)
  60. ITRI3 = ITRI3 + 1
  61. ICTC(ITRI3,1)=NUM(3,J)
  62. ICTC(ITRI3,2)=NUM(4,J)
  63. ICTC(ITRI3,3)=NUM(5,J)
  64. 510 CONTINUE
  65. ENDIF
  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. SEGSUP MULTRI
  82. CALL ACTOBJ('MAILLAGE',MELEME,1)
  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. GO TO 1100
  100. ENDIF
  101. DO 1101 J=1,NUM(/2)
  102. ICPR(NUM(1,J))=ityp
  103. 1101 CONTINUE
  104. 1100 CONTINUE
  105. NBELEM=0
  106. DO 1102 I=1,ICPR(/1)
  107. if (icpr(i).ne.0) NBELEM=NBELEM + 1
  108. 1102 CONTINUE
  109. NBNN = 1
  110. NBSOUS=0
  111. NBREF=0
  112. SEGINI MELEME
  113. IA=1
  114. ITYPEL=1
  115. DO 1103 I=1,ICPR(/1)
  116. IF( ICPR(I).ne.-1) GO TO 1103
  117. NUM(1,IA)=I
  118. IA = IA + 1
  119. 1103 CONTINUE
  120. DO 1104 I=1,ICPR(/1)
  121. IF( ICPR(I).ne. 1) GO TO 1104
  122. NUM(1,IA)=I
  123. IA = IA + 1
  124. 1104 CONTINUE
  125. DO 1105 I=1,ICPR(/1)
  126. IF( ICPR(I).ne. 2) GO TO 1105
  127. NUM(1,IA)=I
  128. IA = IA + 1
  129. 1105 CONTINUE
  130. CALL ACTOBJ('MAILLAGE',MELEME,1)
  131. CALL ECROBJ('MAILLAGE',MELEME)
  132. SEGSUP ICPR
  133. RETURN
  134. C
  135. C CAS IMUL = 1 OU 2
  136. C
  137. C BOUCLE SUR LES RIGIDITES ELEMENTAIRES
  138. C
  139. 1000 CONTINUE
  140. SEGINI INDIC
  141. DO 191 I=1,NR
  142. IGEO=IRIGEL(1,I)
  143. MELEME=IGEO
  144. SEGACT MELEME
  145. C
  146. C TEST SUR LE TYPE D ELEMENT ( EGAL A MULT ? )
  147. C
  148. IF(ITYPEL.NE.22) THEN
  149. IF(IMUL.EQ.2) GO TO 191
  150. IF(IPP1.EQ.0) THEN
  151. IPP1=IGEO
  152. GO TO 191
  153. ELSE
  154. IPP2=IGEO
  155. ltelq=.false.
  156. CALL FUSE(IPP1,IPP2,IRET,ltelq)
  157. IPP1=IRET
  158. GO TO 191
  159. ENDIF
  160. ELSE
  161. C
  162. C TRAITEMENT D'UN ELEMENT DE TYPE BLOCAGE,RELATION,....
  163. C
  164. IF(IMUL.EQ.1) THEN
  165. NBDEB=2
  166. NBFIN=NUM(/1)
  167. ELSE IF(IMUL.EQ.2) THEN
  168. NBDEB=1
  169. NBFIN=1
  170. ENDIF
  171. ENDIF
  172. C
  173. NBPOIN=NUM(/2)
  174. DO 199 J=1,NBPOIN
  175. DO 198 IJ=NBDEB,NBFIN
  176. C
  177. C BOUCLE SUR LES POINTS EXISTANTS
  178. C
  179. NINDIC=INDIC(/1)
  180. DO 302 IK=1,NINDIC,2
  181. IF(INDIC(IK).EQ.NUM(IJ,J)) GO TO 303
  182. 302 CONTINUE
  183. INDIC(**)=NUM(IJ,J)
  184. INDIC(**)=ICOLOR(J)
  185. 303 CONTINUE
  186. 198 CONTINUE
  187. 199 CONTINUE
  188. 191 CONTINUE
  189. SEGDES MRIGID
  190. C
  191. C REMPLISSAGE DU RESULTAT
  192. C
  193. NBELEM=INDIC(/1)/2
  194. IF (NBELEM.EQ.0) THEN
  195. IF(IMUL.EQ.1) GO TO 211
  196. ** creation d'un maillage vide
  197. ** CALL ERREUR(18)
  198. ** RETURN
  199. ENDIF
  200. NBNN=1
  201. NBSOUS=0
  202. NBREF=0
  203. SEGINI IPT1
  204. IPT1.ITYPEL=1
  205. DO 1001 IP=1,NBELEM
  206. IP2=2*IP
  207. IP1=IP2-1
  208. IPT1.NUM(1,IP)=INDIC(IP1)
  209. IPT1.ICOLOR(IP)=INDIC(IP2)
  210. 1001 CONTINUE
  211. IF(IPP1.EQ.0) THEN
  212. IPP1=IPT1
  213. ELSE
  214. ltelq=.false.
  215. CALL FUSE(IPP1,IPT1,IRET,ltelq)
  216. IPP1=IRET
  217. ENDIF
  218. 211 SEGSUP INDIC
  219. CALL ACTOBJ('MAILLAGE',IPP1,1)
  220. CALL ECROBJ('MAILLAGE',IPP1)
  221. END
  222.  
  223.  
  224.  
  225.  

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