Télécharger relsur.eso

Retour à la liste

Numérotation des lignes :

  1. C RELSUR SOURCE PV 20/03/24 21:21:54 10554
  2. C RELSUR SOURCE BP208322 17/04/18 21:15:13 9395
  3. SUBROUTINE RELSUR(IMODEL, MRIGID)
  4. C***********************************************************************
  5. C cet operateur créé d'une matrice élémentaire de rigidité
  6. c pour imposer les relation portées par un modele de sure
  7. C
  8. C ENTREES :
  9. C ________
  10. C
  11. C IMODEL pointeur sur le modele élémentaire
  12. C
  13. C ENTREES/SORTIE :
  14. C ________
  15. C
  16. c MRIGID rigidité chapeau dans laquelle on va écrire
  17. c (à la suite des sous matrices déja présentes) les rigidités
  18. c voulues.
  19. C---------------------------------------------------------------------
  20. C***********************************************************************
  21.  
  22. IMPLICIT REAL*8 (A-H,O-Z)
  23. IMPLICIT INTEGER (I-N)
  24. C
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMRIGID
  29. C-INC SMINTE
  30. -INC SMMODEL
  31. -INC SMELEME
  32. -INC SMCHAML
  33. -INC CCHAMP
  34. -INC CCGEOME
  35. -INC SMCOORD
  36. C
  37.  
  38. C
  39. C Petit tableau des "couleurs" des relations de conformite
  40. DIMENSION LCOLOR(6)
  41. DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
  42. C
  43. C nombre de sous matrice de mrigid (va être ammené a changé)
  44. NRIGEL = MRIGID.IRIGEL(/2)
  45.  
  46.  
  47. IPT1=IMODEL.imamod
  48. SEGACT, IPT1
  49. IDEBUT = LCOLOR(IPT1.ICOLOR(1)) - 3
  50.  
  51. c récupérations du nom des composantes obligatoire du modele de sure
  52. nomid=IMODEL.lnomid(1)
  53. SEGACT, nomid
  54. SEGACT,MCOORD*MOD
  55. C**********************************************************************
  56. C Boucle sur les composantes primales obligatoires du sure
  57. C**********************************************************************
  58. ICOMP=0
  59.  
  60. DO 2 ICOMP=1,nomid.lesobl(/2)
  61.  
  62. C====================
  63. c creation d'un maillage avec un premier noeud par lélément
  64. c correspondant à un multiplicateur de lagrange
  65. C====================
  66. NBNN=IPT1.NUM(/1)+1
  67. NBELEM=IPT1.NUM(/2)
  68. NBSOUS=0
  69. NBREF=0
  70. SEGINI, IPT4
  71. IPT4.ITYPEL=22
  72. DO 1 J=1, NBELEM
  73. ipt4.icolor(j)=IPT1.icolor(j)
  74. DO 11 I=1,IPT1.NUM(/1)
  75. IPT4.NUM(I+1,J)=IPT1.NUM(I,J)
  76. 11 CONTINUE
  77. 1 CONTINUE
  78. C creation n'un nouveau noeud pour supporter chaque multiplicateur de lagrange
  79. NBPT1= nbpts
  80. NBPTS=NBPT1+(IPT4.NUM(/2))
  81. SEGADJ MCOORD
  82. DO 12 J=1, NBELEM
  83. NGLOB=(NBPT1+J-1)*(IDIM+1)
  84. C remplissage des coordonees des nouveux points
  85. DO 13 ID= 1,IDIM
  86. XCOOR(NGLOB+ID)=XCOOR((IPT4.NUM(2,J)-1)*(IDIM+1)+ID)
  87. 13 CONTINUE
  88. IPT4.NUM(1,J) = NBPT1 + J
  89. 12 CONTINUE
  90.  
  91. C====================
  92. C *** SEGMENT XMATRI
  93. C====================
  94. NLIGRD=IPT4.NUM(/1)
  95. NLIGRP=NLIGRD
  96. NELRIG=IPT4.NUM(/2)
  97. SEGINI, XMATRI
  98. DO 3 I=1,NELRIG
  99. RE(1,2,i)=-1.
  100. RE(2,1,i)=-1.
  101. DO 4 ICAZ=3,NLIGRD
  102. RE(1,ICAZ,i)=XCOEFF(IDEBUT+ICAZ)
  103. RE(ICAZ,1,i)=RE(1,ICAZ,i)
  104. 4 CONTINUE
  105. 3 CONTINUE
  106. C write(*,*) 'COMPOSANTE OBLIGATOIRE DU SURE :'
  107. C write(*,*) (nomid.lesobl(ICOMP))
  108. C write(*,*) 'MATRICE elementaire :'
  109. C DO 5 I=1,NLIGRD
  110. C write(*,*) (RE(i,iou,1), iou=1,NLIGRD)
  111. C 5 CONTINUE
  112.  
  113. C====================
  114. C *** SEGMENT DESCR
  115. C====================
  116.  
  117. NEXIST=0
  118. DO 6 I=1,LNOMDD
  119. IF (NOMDD(I).EQ.nomid.lesobl(ICOMP)) NEXIST = I
  120. 6 CONTINUE
  121.  
  122. IF (NEXIST.EQ.0) THEN
  123. CALL ERREUR(837)
  124. ENDIF
  125.  
  126. SEGINI, DESCR
  127. LISINC(1)='LX '
  128. LISDUA(1)='FLX '
  129. NOELEP(1)=1
  130. NOELED(1)=1
  131. DO 7 I=2,NLIGRD
  132. LISINC(I)=NOMDD(NEXIST)
  133. LISDUA(I)=NOMDU(NEXIST)
  134. NOELEP(i)=i
  135. NOELED(i)=i
  136. 7 CONTINUE
  137.  
  138. C====================
  139. C *** stockage de la rigidité construite dans MRIGID
  140. C====================
  141.  
  142.  
  143.  
  144. NRIGEL = NRIGEL+1
  145. SEGADJ, MRIGID
  146. SEGACT, MRIGID*mod
  147.  
  148. COERIG(NRIGEL)=1.
  149. IRIGEL(1,NRIGEL)=IPT4
  150. IRIGEL(3,NRIGEL)=DESCR
  151. IRIGEL(4,NRIGEL)=XMATRI
  152.  
  153.  
  154. c SEGDES, MRIGID
  155. SEGDES, DESCR
  156. SEGDES, XMATRI
  157. SEGDES, IPT4
  158. C**********************************************************************
  159. C FIN Boucle sur les composantes primales obligatoires du sure
  160. C**********************************************************************
  161. 2 CONTINUE
  162. c write (*,*) 'nomid.lesfac(/2)', nomid.lesfac(/2)
  163. IF (nomid.lesfac(/2).EQ.0) goto 100
  164. c récupération du champ d'enrichissement
  165. c MCHEX1= IMODEL.IVAMOD(1)
  166. c SEGACT, MCHEX1
  167. c MCHAM1= MCHEX1.ICHAML(1)
  168. MCHAM1= IMODEL.IVAMOD(1)
  169. SEGACT, MCHAM1
  170.  
  171.  
  172. C**********************************************************************
  173. C Boucle sur les composantes primales facultatives du sure
  174. C**********************************************************************
  175. ICOMP=0
  176. DO 101 ICOMP=1,nomid.lesfac(/2)
  177. C++++ choix du type d'enrichisement de la composante ICOMP
  178. IF (nomid.lesfac(ICOMP).EQ.'AX') MELVA1=MCHAM1.IELVAL(1)
  179. IF (nomid.lesfac(ICOMP).EQ.'AY') MELVA1=MCHAM1.IELVAL(1)
  180. IF (nomid.lesfac(ICOMP).EQ.'AZ') MELVA1=MCHAM1.IELVAL(1)
  181.  
  182. IF (nomid.lesfac(ICOMP).EQ.'B1X') MELVA1=MCHAM1.IELVAL(2)
  183. IF (nomid.lesfac(ICOMP).EQ.'B1Y') MELVA1=MCHAM1.IELVAL(2)
  184. IF (nomid.lesfac(ICOMP).EQ.'B1Z') MELVA1=MCHAM1.IELVAL(2)
  185. IF (nomid.lesfac(ICOMP).EQ.'C1X') MELVA1=MCHAM1.IELVAL(2)
  186. IF (nomid.lesfac(ICOMP).EQ.'C1Y') MELVA1=MCHAM1.IELVAL(2)
  187. IF (nomid.lesfac(ICOMP).EQ.'C1Z') MELVA1=MCHAM1.IELVAL(2)
  188. IF (nomid.lesfac(ICOMP).EQ.'D1X') MELVA1=MCHAM1.IELVAL(2)
  189. IF (nomid.lesfac(ICOMP).EQ.'D1Y') MELVA1=MCHAM1.IELVAL(2)
  190. IF (nomid.lesfac(ICOMP).EQ.'D1Z') MELVA1=MCHAM1.IELVAL(2)
  191. IF (nomid.lesfac(ICOMP).EQ.'E1X') MELVA1=MCHAM1.IELVAL(2)
  192. IF (nomid.lesfac(ICOMP).EQ.'E1Y') MELVA1=MCHAM1.IELVAL(2)
  193. IF (nomid.lesfac(ICOMP).EQ.'E1Z') MELVA1=MCHAM1.IELVAL(2)
  194.  
  195. IF (nomid.lesfac(ICOMP).EQ.'B2X') MELVA1=MCHAM1.IELVAL(3)
  196. IF (nomid.lesfac(ICOMP).EQ.'B2Y') MELVA1=MCHAM1.IELVAL(3)
  197. IF (nomid.lesfac(ICOMP).EQ.'B2Z') MELVA1=MCHAM1.IELVAL(3)
  198. IF (nomid.lesfac(ICOMP).EQ.'C2X') MELVA1=MCHAM1.IELVAL(3)
  199. IF (nomid.lesfac(ICOMP).EQ.'C2Y') MELVA1=MCHAM1.IELVAL(3)
  200. IF (nomid.lesfac(ICOMP).EQ.'C2Z') MELVA1=MCHAM1.IELVAL(3)
  201. IF (nomid.lesfac(ICOMP).EQ.'D2X') MELVA1=MCHAM1.IELVAL(3)
  202. IF (nomid.lesfac(ICOMP).EQ.'D2Y') MELVA1=MCHAM1.IELVAL(3)
  203. IF (nomid.lesfac(ICOMP).EQ.'D2Z') MELVA1=MCHAM1.IELVAL(3)
  204. IF (nomid.lesfac(ICOMP).EQ.'E2X') MELVA1=MCHAM1.IELVAL(3)
  205. IF (nomid.lesfac(ICOMP).EQ.'E2Y') MELVA1=MCHAM1.IELVAL(3)
  206. IF (nomid.lesfac(ICOMP).EQ.'E2Z') MELVA1=MCHAM1.IELVAL(3)
  207.  
  208. SEGACT MELVA1
  209.  
  210. C====================
  211. c creation d'un maillage de multiplicateurs de lagranges enrichis
  212. C====================
  213. NBNN=IPT1.NUM(/1)+1
  214. NBELEM=IPT1.NUM(/2)
  215. NBSOUS=0
  216. NBREF=0
  217. SEGINI, IPT4
  218. IPT4.ITYPEL=22
  219. IELENR=0
  220. c++++ BOUCLE sur les éléments de ipt1
  221. DO 102 JELEM=1,IPT1.NUM(/2)
  222. NEXIST=0
  223. ipt4.icolor(jelem)=IPT1.icolor(jelem)
  224. JNUM = IPT1.NUM(1,JELEM)
  225. c+++ Recherche d'une valeur non nulle du champ d'enrichissement
  226. VENR1 = MELVA1.VELCHE(1,JELEM)
  227.  
  228. C On prend les elements dont le hanging node est enrichi
  229. IF (VENR1.GT.0) THEN
  230. NEXIST=NEXIST+1
  231. C On prend les element dont tout les autres noeuds sont enrichis
  232. ELSE
  233. DO 121 JNOEUD= 2 , IPT1.NUM(/1)
  234. VENR1 = MELVA1.VELCHE(JNOEUD,JELEM)
  235. IF (VENR1.eq.0) GOTO 121
  236. NEXIST=NEXIST+1
  237. 121 CONTINUE
  238. ENDIF
  239. IF (nexist.eq.0) GOTO 102
  240. IELENR= IELENR+1
  241. C On recopie dans IPT4 les elements de ipt1 sur lequel on veux
  242. c imposer une relation de compatibilité
  243. DO 122 I=1,IPT1.NUM(/1)
  244. IPT4.NUM(I+1,IELENR)=IPT1.NUM(I,JELEM)
  245. 122 CONTINUE
  246.  
  247. 102 CONTINUE
  248.  
  249. NBELEM=IELENR
  250. SEGADJ IPT4
  251. IF (ielenr.eq.0) then
  252. segsup ipt4
  253. goto 101
  254. endif
  255.  
  256.  
  257.  
  258. C=======================================================================
  259. C creation n'un nouveau noeud pour supporter chaque multiplicateur de lagrange
  260. C=======================================================================
  261. NBPT1=nbpts
  262. NBPTS=NBPT1+IELENR
  263. SEGADJ,MCOORD
  264. DO 103 J=1,IPT4.NUM(/2)
  265. NGLOB=(NBPT1+J-1)*(IDIM+1)
  266. C remplissage des coordonees des nouveux points
  267. DO 131 ID= 1,IDIM
  268. XCOOR(NGLOB+ID)=XCOOR((IPT4.NUM(2,J)-1)*(IDIM+1)+ID)
  269. 131 CONTINUE
  270. IPT4.NUM(1,J) = NBPT1 + J
  271. 103 CONTINUE
  272.  
  273. C====================
  274. C *** SEGMENT XMATRI
  275. C====================
  276. NLIGRD=IPT4.NUM(/1)
  277. NLIGRP=NLIGRD
  278. NELRIG=IPT4.NUM(/2)
  279. SEGINI, XMATRI
  280. c++++ BOUCLE sur les éléments de ipt4
  281. DO 104 IELEM=1,NELRIG
  282. RE(1,2,IELEM)=-1.
  283. RE(2,1,IELEM)=-1.
  284. DO 141 ICAZ=3,NLIGRD
  285. RE(1,ICAZ,IELEM)=XCOEFF(IDEBUT+ICAZ)
  286. RE(ICAZ,1,IELEM)=RE(1,ICAZ,IELEM)
  287. 141 CONTINUE
  288. 104 CONTINUE
  289. C write(*,*) 'COMPOSANTE FACULTATIVE DU SURE :'
  290. C write(*,*) (nomid.lesfac(ICOMP))
  291. C write(*,*) 'MATRICE elementaire :'
  292. C DO 6666 I=1,NLIGRD
  293. C write(*,*) (RE(i,iou,1), iou=1,NLIGRD)
  294. C 6666 CONTINUE
  295.  
  296. C====================
  297. C *** SEGMENT DESCR
  298. C====================
  299.  
  300. NEXIST=0
  301. DO 105 ICO1=1,LNOMDD
  302. IF (NOMDD(ICO1).EQ.nomid.lesfac(ICOMP)) NEXIST = ICO1
  303. 105 CONTINUE
  304.  
  305. IF (NEXIST.EQ.0) THEN
  306. CALL ERREUR(837)
  307. ENDIF
  308.  
  309. SEGINI, DESCR
  310. LISINC(1)='LX '
  311. LISDUA(1)='FLX '
  312. NOELEP(1)=1
  313. NOELED(1)=1
  314. DO 106 ICO2=2,NLIGRD
  315. LISINC(ICO2)=NOMDD(NEXIST)
  316. LISDUA(ICO2)=NOMDU(NEXIST)
  317. NOELEP(ico2)=ico2
  318. NOELED(ico2)=ico2
  319. 106 CONTINUE
  320.  
  321. C====================
  322. C *** stockage de la rigidité construite dans MRIGID
  323. C====================
  324. C Ajustement du segment rigidite
  325. NRIGEL=NRIGEL +1
  326. SEGADJ, MRIGID
  327.  
  328.  
  329. C* ICHOLE=0
  330. C* IMGEO1=0
  331. C* IMGEO2=0
  332. C* IFORIG=0
  333. C* ISUPEQ=0
  334. COERIG(NRIGEL)=1.
  335. IRIGEL(1,NRIGEL)=IPT4
  336. IRIGEL(3,NRIGEL)=DESCR
  337. IRIGEL(4,NRIGEL)=XMATRI
  338.  
  339. SEGDES, DESCR
  340. SEGDES, XMATRI
  341. SEGDES, IPT4
  342. C**********************************************************************
  343. C FIN Boucle sur les composantes primales facultatives du sure
  344. C**********************************************************************
  345. 101 CONTINUE
  346. 100 CONTINUE
  347. SEGDES, nomid
  348.  
  349.  
  350. segdes,IPT1, MCOORD
  351.  
  352. C
  353. RETURN
  354.  
  355. END
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  

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