Télécharger la plaquette Cast3M


fr en

Télécharger relsur.eso

Retour à la liste

Numérotation des lignes : 

relsur

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

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