Télécharger la plaquette Cast3M


fr en

Télécharger epsix.eso

Retour à la liste

Numérotation des lignes : 

epsix

  1. C EPSIX     SOURCE    CB215821  24/04/12    21:15:47     11897          
  2.       subroutine EPSIX (IMODEL,IREPS2,IVADEP,IVAEPS,
  3.      &                  UZDPG,RYDPG,RXDPG,IIPDPG,IRETER)
  4. c
  5. C     PROCEDURE UTILISEE DANS LE CAS D'ELEMENTS XFEM
  6. c     POUR LE CALCUL DE la deformation
  7. C
  8. C*********************************************************
  9. C       PARTIE DECLARATIVE
  10. C*********************************************************
  11. C
  12.       IMPLICIT REAL*8(A-H,O-Z)
  13. C
  14.       PARAMETER  (NDDLMAX=30,NBNIMAX=10)
  15. C
  16.       PARAMETER  (NBENRMAX=5)
  17.       DIMENSION  MLRE(NBENRMAX+1)
  18. C
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMCOORD
  23. -INC SMMODEL
  24. -INC SMCHAML
  25. -INC SMINTE
  26. -INC SMELEME
  27. -INC SMLREEL
  28. C
  29.       POINTEUR    MCHEX1.MCHELM,MINT1.MINTE,MINT2.MINTE
  30. C
  31. C  Segment (type LISTENTI) contenant les informations sur un element
  32.       SEGMENT INFO
  33.         INTEGER INFELL(JG)
  34.       ENDSEGMENT
  35. c
  36.       SEGMENT WRK1
  37.        REAL*8 XE(3,NBBB)
  38.        REAL*8 XDDL(LRE),XSTRS(LHOOK)
  39.       ENDSEGMENT
  40. c
  41.       SEGMENT WRK2
  42.        REAL*8 SHPWRK(6,NBNO),BGENE(LHOOK,LRE)
  43. c       REAL*8 LV7WRK(NBENRMA2,2,6,NBNO)
  44.        REAL*8 LV7WRK(NBENRMA2,2,6,NBBB)
  45.       ENDSEGMENT
  46. C
  47.       SEGMENT MPTVAL
  48.         INTEGER      IPOS(NS),NSOF(NS)
  49.         INTEGER      IVAL(NCOSOU)
  50.         CHARACTER*16 TYVAL(NCOSOU)
  51.       ENDSEGMENT
  52. C
  53.       SEGMENT MRACC
  54.          INTEGER TLREEL(NBENRMA2,NBI)
  55.       ENDSEGMENT
  56. C
  57.       SEGMENT MTRACE
  58.         REAL*8 TRACE(NBPTEL)
  59.       ENDSEGMENT
  60.       DIMENSION UDPGE(3)
  61. C
  62. C      write (*,*) '############################'
  63. C      write (*,*) '#####  DEBUT DE EPSIX  #####'
  64. C      write (*,*) '############################'
  65. C
  66. C*********************************************************
  67. c  Introduction du point autour duquel se fait le mouvement
  68. c  de la section en defo plane generalisee
  69. C*********************************************************
  70. C IIPDPG > 0 (argument) si noeud/point support defini dans le modele
  71. C NDPGE > 0 si besoin de calcul avec point support
  72.       IF (IIPDPG.GT.0) THEN
  73.         IF (IFOUR.EQ.-3) THEN
  74.           NDPGE=3
  75.           UDPGE(1)=UZDPG
  76.           UDPGE(2)=RYDPG
  77.           UDPGE(3)=RXDPG
  78. C          SEGACT,MCOORD
  79.           IREF=(IIPDPG-1)*(IDIM+1)
  80.           XDPGE=XCOOR(IREF+1)
  81.           YDPGE=XCOOR(IREF+2)
  82. C*        ELSE IF (IFOUR.EQ.11) THEN
  83. C*          NDPGE=2
  84. C*          UDPGE(1)=UZDPG
  85. C*          UDPGE(2)=RXDPG
  86. C*          UDPGE(3)=0.D0
  87. C*          XDPGE=0.D0
  88. C*          YDPGE=0.D0
  89. C*        ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  90. C*     &           IFOUR.EQ.10 .OR. IFOUR.EQ.14) THEN
  91. C*          NDPGE=1
  92. C*          UDPGE(1)=UZDPG
  93. C*          UDPGE(2)=0.D0
  94. C*          UDPGE(3)=0.D0
  95. C*          XDPGE=0.D0
  96. C*          YDPGE=0.D0
  97.         else
  98.           write(ioimp,*) 'EPSI4 : erreur NDPGE'
  99.           call erreur(5)
  100.           return
  101.         ENDIF
  102.       ELSE
  103.         NDPGE=0
  104.         UDPGE(1)=0.D0
  105.         UDPGE(2)=0.D0
  106.         UDPGE(3)=0.D0
  107.         XDPGE=0.D0
  108.         YDPGE=0.D0
  109.       ENDIF
  110. C
  111. C
  112. C*********************************************************
  113. c
  114. C       RECUPERATION + ACTIVATIONS + VALEURS UTILES
  115. c
  116. C*********************************************************
  117. C     SEGACT MMODEL,IMODEL    deja activé dans epsi1
  118. c
  119. C++++ Activation au cas ou ++++++++++++++++++++++++++++++
  120.       SEGACT MCOORD
  121.  
  122. C++++ Recup + Activation de la geometrie ++++++++++++++++
  123.       MELEME= IMAMOD
  124. c      SEGACT MELEME    deja activé dans epsi1
  125.  
  126.  
  127. C++++ RECUP DES INFOS EF ++++++++++++++++++++++++++++++++
  128. c   + OBTENUES PAR ELQUOI DANS RIGI1 PENDANT PHASE 1
  129. C     segment INFO deja actif dans RIGI1
  130. c   + rigi1 n appelle pas elquoi, c'est modeli qui l'a fait
  131. c     mais du coup, on na pas de segment minte
  132. c     (car depend de si pt de g pour rigi, pour sigma....)
  133. c     c'est + simple de rappeler elquoi ici
  134.       MELE = NEFMOD
  135.       call elquoi(MELE,0,3,IPINF,IMODEL)
  136.       INFO  = IPINF
  137. c      MELE  = INFELL(1)
  138. c      NBPGA2= INFELL(2)
  139. c      NBPGAU= INFELL(3)
  140. c      NBPGAU= INFELL(4)
  141. c      ICARA = INFELL(5)
  142.       NGAU1 = INFELL(6)
  143. c      LW    = INFELL(7)
  144.       LRE   = INFELL(9)
  145.       LHOOK = INFELL(10)
  146.       MINT1 = INFELL(11)
  147.       segact,MINT1
  148.       MINT2 = INFELL(12)
  149.       if(MINT2.ne.0)   segact,MINT2
  150.       MFR   = INFELL(13)
  151.       IELE  = INFELL(14)
  152.       NDDL  = INFELL(15)
  153.       NSTRS = INFELL(16)
  154. c      write(6,*)'-> EPSIX infell',(infell(iou),iou=1,16)
  155.  
  156. c   + AUTRES INFOS
  157. C     nbre de noeuds par element
  158.       NBNN1 = NUM(/1)
  159. C     nbre d elements
  160.       NBEL1 = NUM(/2)
  161.  
  162. c REM: pour se passer du dimensionnement du nbre d'enrichissement dans
  163. c      elquoi et le realiser localement , on pourrait ecrire:
  164. c      LRE = NDDLMAX*NBNN1
  165. c      NDDL= NDDLMAX
  166.  
  167. C     sous decoupage et points de Gauss de l element geometrique de base
  168.       if(MELE.eq.263.or.mele.eq.264)  then
  169.          NGAU2 = MINT2.POIGAU(/1)
  170.       endif
  171. C      write(*,*) 'dim de MINT2=6,',(MINT2.SHPTOT(/2)),(MINT2.SHPTOT(/3))
  172. C      write(*,*) 'MINT2',(MINT2.QSIGAU(iou),iou=1,NGAU)
  173.  
  174.  
  175. c     nbre maxi de fonction de forme par noeud (fonction std comprise)
  176. c      NBNI = NDDL/IDIM    inutile!
  177.  
  178.  
  179. C++++ Recup des infos d enrichissement +++++++++++++++++++
  180. c     recup du MCHEX1 d'enrichissement
  181.       NOBMO1 = IVAMOD(/1)
  182.       if(NOBMO1.ne.0) then
  183.        do iobmo1=1,NOBMO1
  184.         if((TYMODE(iobmo1)).eq.'MCHAML') then
  185.          MCHEX1 = IVAMOD(iobmo1)
  186.          segact,MCHEX1
  187.           if((MCHEX1.TITCHE).eq.'ENRICHIS') then
  188.             MCHAM1 = MCHEX1.ICHAML(1)
  189.             segact,MCHAM1
  190.             goto 1000
  191.           endif
  192.         endif
  193.        enddo
  194.        write(*,*) 'Le modele est vide (absence d enrichissement)'
  195. *       return
  196.       else
  197.       write(*,*) 'Il n y a pas de MCHEML enrichissement dans le Modele'
  198. *       return
  199.       endif
  200.  
  201.  1000 continue
  202. c     niveau d enrichissement(s) du modele (ddls std u exclus)
  203. c     NBENR1= 0 si std, 1 si H seul,  2 si H+F1,  3 si H+F1+F2, etc...
  204.       if(NOBMO1.ne.0) then
  205.         NBENR1= MCHAM1.IELVAL(/1)
  206.       else
  207.         NBENR1 = 0
  208.       endif
  209. c      write(*,*) 'niveau d enrichissement(s) du modele',NBENR1
  210. c
  211. C
  212. C
  213. C*********************************************************
  214. C       INITIALISATIONS...
  215. C*********************************************************
  216.       IRETER = 0
  217. c
  218. c     preparation des tables avec:
  219.  
  220.       if(NBENR1.ne.0) then
  221.       do ienr=1,NBENR1
  222. c        -le nombre d'inconnues de chaque sous-zone
  223. c         determinee depuis le nombre de fonction de forme
  224. c ienr=  1: U+H(1+1=2), 2: U+H+F1(2+4=6), 3: U+H+F1+F2(6+4=10)
  225.          nbniJ = 2 + ((ienr-1)*4)
  226.          MLRE(1+ienr) = IDIM*NBNN1*nbniJ
  227.       enddo
  228.       endif
  229. C     Tables + longues car 1er indice correspond au fontion de forme std
  230.       MLRE(1)    = IDIM*NBNN1*1
  231.  
  232.       if(NBENR1.lt.(NBENRMAX+1)) then
  233.         do ienr=(NBENR1+1),(NBENRMAX)
  234.            MLRE(1+ienr) = 0
  235.         enddo
  236.       endif
  237. c
  238. c      ...DU SEGMENT WRK1
  239.       NBENRMA2 = NBENRMAX
  240.       NBBB = NBNN1
  241.       SEGINI,WRK1
  242.  
  243. c      ...DU SEGMENT WRK2
  244. c      NBNO = NBNI
  245.       NBNO = LRE/IDIM
  246.       SEGINI,WRK2
  247. C
  248. c      ...DU SEGMENT MRACC
  249.       NBENRMA2 = NBENRMAX
  250.       NBI = NBNN1
  251.       segini,MRACC
  252. C
  253. C     du nombre d erreur sur le noms de composantes
  254.       NBERR1=0
  255.  
  256.  
  257.  
  258. C*********************************************************
  259. C
  260. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  BOUCLE SUR LES ELEMENTS
  261. C
  262.       DO 2000 J=1,NBEL1
  263. c      write(*,*) '==================================='
  264. c      write(*,*) '========= EF',J,' /NBEL1 ========='
  265. C
  266. C
  267. C*********************************************************
  268. C     POUR CHAQUE ELEMENT, ...
  269. C*********************************************************
  270. C
  271. C++++ ON RECUPERE LES COORDONNEES DES NOEUDS DE L ELEMENT
  272.       CALL DOXE(XCOOR,IDIM,NBNN1,NUM,J,XE)
  273. C
  274. c
  275. C++++ NBENRJ = niveau d enrichissement de l element ++++
  276. C     =0 si EF std   =1 si U+H   =2 si U+H+F1   =3 si U+H+F1+F2
  277.       NBENRJ=0
  278.       if(NBENR1.ne.0) then
  279.       do IENR=1,NBENR1
  280.         MELVA1 = MCHAM1.IELVAL(IENR)
  281.         segact,MELVA1
  282.         do I=1,NBNN1
  283.          mlree1 = MELVA1.IELCHE(I,J)
  284. C        on en profite pour remplir MRACC table de raccourcis pour cet element
  285.          TLREEL(IENR,I) = mlree1
  286.          if(mlree1.ne.0)  then
  287.             NBENRJ = max(NBENRJ,IENR)
  288. C           et on active la listreel
  289.             segact,mlree1
  290.          endif
  291.         enddo
  292.       enddo
  293.       endif
  294.       if(NBENRMA2.gt.NBENR1) then
  295.         do IENR2=(NBENR1+1),NBENRMA2
  296.         do I=1,NBNN1
  297.            TLREEL(IENR2,I) = 0
  298.         enddo
  299.         enddo
  300.       endif
  301. C
  302. c
  303. c++++ quelques indices pour dimensionner au plus juste
  304. c     nbre total de ddl de l'élément considéré
  305.       NLIGRD = MLRE(1+NBENRJ)
  306.       NLIGRP = MLRE(1+NBENRJ)
  307. c     nbre fonction de forme=((Ni_std+Ni_enrichi)*nbnoeud)=Ninconnues/idim
  308.       NBNI = (MLRE(1+NBENRJ)) / IDIM
  309.  
  310. C      write(*,*) 'EF',J,' NBENRJ=',NBENRJ,
  311. C    &'donc',NLIGRD,' ddls et ',NBNI,' fonctions de forme'
  312. c
  313. C
  314. C++++ ON CALCULE XDDL ++++
  315.       MPTVAL = IVADEP
  316.       NCOSOU = IVAL(/1)
  317. C
  318.       INITOT = 0
  319. C-->> BOUCLE SUR LES niveaux d'ENRICHISSEMENTS (0:U 1:A 2:BCDE1 3:BCDE2)
  320.       DO IENR=0,NBENRJ
  321. *nbre de fonction(s) de ce niveau d'enrichissement (=1 si std ou H, =4 pour F1,2,...)
  322.         if(IENR .le. 1) then
  323.          NBNIENR = 1
  324.         else
  325.          NBNIENR = 4
  326.         endif
  327. C---->> BOUCLE SUR LES fonctions de forme de ce type d'enrichissement
  328.         DO INI=1,NBNIENR
  329.           INITOT = INITOT + 1
  330. C------>> BOUCLE SUR LA DIMENSION
  331.           DO 2220 KDIM=1,IDIM
  332.             ICOMP = (INITOT-1)*IDIM + KDIM
  333.  
  334. c         --cas ou on n'a pas trouvé assez de composantes--
  335.             if(ICOMP.GT.NCOSOU) GOTO 2221
  336.  
  337.             MELVAL = IVAL(ICOMP)
  338. c         --cas ou on a pas trouvé cette composante dans cette zone du
  339. c           chpoint solution devenu mchaml  --
  340.             if(MELVAL.eq.0)then
  341. c             Avait on besoin de cette composante?
  342. c             oui, si c'est une composante obligatoire
  343.               if(IENR.eq.0) goto 2991
  344. c             oui, si l'un des noeuds est enrichi
  345.               do I=1,NBNN1
  346.                 if(TLREEL(IENR,I).ne.0) goto 2991
  347.               enddo
  348. c             non, si c'est facultatif et qu'on n'est pas enrichi -> on saute
  349.               goto 2220
  350. c           ->AVERTISSEMENT puis on saute
  351.  2991         NBERR1=NBERR1+1
  352.               if(IIMPI.lt.1) goto 2220
  353. c               write(IOIMP,*) 'PB OPERATEUR EPSI :'
  354.               write(IOIMP,991) ICOMP,IENR,INI,KDIM
  355.   991         format(2X,'ABSENCE DANS LE CHPOINT DEPLACEMENT DE LA ',I3,
  356.      $                  'ieme COMPOSANTE (enrichissement',I3,
  357.      $                   ', fonction',I3,', direction ',I3,
  358.      $                   ') NECESSAIRE POUR L UN DES NOEUDS SUIVANTS :')
  359.               write(IOIMP,*)'  noeuds :',(NUM(iou,J),iou=1,NBNN1)
  360.               goto 2220
  361.             endif
  362.  
  363. C---------->> BOUCLE SUR LES NOEUDS
  364.             DO I=1,NBNN1
  365.               IQ = ((INITOT-1)*NBNN1*IDIM) + ((I-1)*IDIM) + KDIM
  366.               XDDL(IQ) = VELCHE(I,J)
  367.             ENDDO
  368.  
  369.  2220     CONTINUE
  370.         ENDDO
  371.       ENDDO
  372.  
  373. c   --cas normal (toutes les composantes souhaitees etaient presentes)--
  374.       GOTO 2223
  375.  
  376. c   --cas ou on n'a pas trouvé assez de composantes--
  377.  2221 CONTINUE
  378.       if (IIMPI.ge.1) then
  379.         WRITE(IOIMP,2222) J,NCOSOU,ICOMP
  380.  2222   FORMAT(2X,'ATTENTION : ELEMENT ',I6,
  381.      &  ' LE CHAMP DE DEPLACEMENT CONTIENT ',I3,' COMPOSANTES',
  382.      &  ' PAR NOEUD AU LIEU DE ',I3,' ATTENDUES')
  383.       endif
  384.       NDDL=NCOSOU*NBNN1
  385.       NBENRJ=IENR
  386.  
  387.  2223 CONTINUE
  388. c   --cas ou on a une ou des erreurs--
  389.       IF (NBERR1.gt.0.and.J.eq.NBEL1) THEN
  390.         write(IOIMP,*) 'OPERATEUR GRAD : ABSENCE DANS LE CHPOINT ',
  391.      &   'DEPLACEMENT DE CERTAINES INCONNUES ATTENDUES PAR LE MODELE'
  392.       ENDIF
  393. c
  394. c rem: il serait probablement interessant au niveau du tems cpu
  395. c  d'utiliser moins de pts de Gauss lorsque l element est élastique
  396. c  On pourrait par ex. utiliser MINT2 = infell(12) qui contient
  397. c  le segment d'integration de l'EF std (QUA4 par ex.)
  398. *      if((NBENRJ.eq.0).and.(MINT2.ne.0)) then
  399. *         MINTE = MINT2
  400. *         NBPGAU= NGAU2
  401. *      else
  402.          MINTE = MINT1
  403.          NBPGAU= NGAU1
  404. *      endif
  405. c
  406. c       pour les def quadratiques
  407.         ISDJC=0
  408.         NBPTEL=NBPGAU
  409.         IF (IREPS2.EQ.1) SEGINI MTRACE
  410. c
  411. C
  412. C*********************************************************
  413. C
  414. C>>>>>>>>>>  BOUCLE SUR LES POINTS DE GAUSS
  415. C
  416.       DO 2500 KGAU=1,NBPGAU
  417. C
  418. C*********************************************************
  419. C     Initialisation à 0
  420. C*********************************************************
  421.  
  422. c ZERO ne serait-il pas facultatif?
  423.       CALL ZERO(SHPWRK,6,NBNO)
  424. C
  425.       i6zz = 3
  426.       IF (IDIM.EQ.3) i6zz = 4
  427. C
  428. c      do ienr7=1,NBENRMAX
  429.       do ienr7=1,NBENRJ
  430.        do inod7=1,NBNN1
  431. c        do i6=1,6
  432.         do i6=1,i6zz
  433.            LV7WRK(ienr7,1,i6,inod7) = 0.D0
  434.            LV7WRK(ienr7,2,i6,inod7) = 0.D0
  435.         enddo
  436.        enddo
  437.       enddo
  438.  
  439.  
  440. c*********************************************************
  441. c     Calcul des fonction de forme std dans repere local
  442. c*********************************************************
  443.  
  444. ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccccc
  445. c     (et donc sur les Ni std)
  446.       DO 2510 I=1,NBNN1
  447.  
  448. C++++ Calcul des Ni std
  449. c     (rappel: 1:Ni  2:Ni,qsi  3:Ni,eta  avec i=1,4)
  450.       SHPWRK(1,I) = SHPTOT(1,I,KGAU)
  451.       SHPWRK(2,I) = SHPTOT(2,I,KGAU)
  452.       SHPWRK(3,I) = SHPTOT(3,I,KGAU)
  453.       IF (IDIM.EQ.3) SHPWRK(4,I) = SHPTOT(4,I,KGAU)
  454.  
  455.  2510 CONTINUE
  456. ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  457.  
  458.  
  459.  
  460. c*********************************************************
  461. c     Passage des fonctions de forme std dans repere global
  462. c*********************************************************
  463.  
  464. C++++ CALCUL DES  Ni,x Ni,y (i=1,4) + CALCUL DE det(J)
  465.       CALL JACOBI(XE,SHPWRK,IDIM,NBNN1,DJAC)
  466. c      if(J.eq.1.and.KGAU.eq.1)
  467. c     &write(*,*) 'Ni(i=1,4)=',(SHPWRK(1,iou),iou=1,NBNN1)
  468.  
  469. c*********************************************************
  470. c     Si on est pas du tout enrichi on peut sauter une grosse partie
  471. c*********************************************************
  472.       if(NBENRJ.eq.0) goto 2999
  473.  
  474. c*********************************************************
  475. c     Calcul des level set + leurs derivees dans repere global
  476. c*********************************************************
  477.  
  478. ccccc BOUCLE SUR LES enrichissements ccccccccccccccccccc
  479.       do 2520 ienr=1,NBENRJ
  480.  
  481. c       MELVA1=MCHAM1.IELVAL(IENR)
  482. c       segact,MELVA1
  483.  
  484. ccccc  BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccc
  485.        DO 2521 I=1,NBNN1
  486.  
  487. C++++ Le I eme noeud est-il ienr-enrichi?
  488.         mlree1= TLREEL(IENR,I)
  489.         if(mlree1.eq.0)  goto 2521
  490.  
  491.  
  492. c       Calcul du repere local de fissure(=PSI,PHI)
  493. c       (rappel: 1,1:psi  1,2:phi  2,1 psi,x  ...etc...)
  494.         do 2522 inode=1,NBNN1
  495. c         pour le H-enrichissement, on n a pas gardé PSI (inutile)
  496.           if(ienr.ne.1) then
  497. c          valeur de PSI au inode^ieme noeud
  498.            xpsi1 = mlree1.PROG(inode)
  499. c          qu on multiplie par la valeur de Ni^std au pt de G considéré
  500.            LV7WRK(ienr,1,1,I)= LV7WRK(ienr,1,1,I)
  501.      &      + (SHPWRK(1,inode)*xpsi1)
  502.            LV7WRK(ienr,1,2,I)= LV7WRK(ienr,1,2,I)
  503.      &      + (SHPWRK(2,inode)*xpsi1)
  504.            LV7WRK(ienr,1,3,I)= LV7WRK(ienr,1,3,I)
  505.      &      + (SHPWRK(3,inode)*xpsi1)
  506.       IF (IDIM.EQ.3) LV7WRK(ienr,1,4,I)= LV7WRK(ienr,1,4,I)
  507.      &      + (SHPWRK(4,inode)*xpsi1)
  508. c          valeur de PHI au inode^ieme noeud
  509.            xphi1 = mlree1.PROG(NBNN1+inode)
  510.           else
  511.            xphi1 = mlree1.PROG(inode)
  512.           endif
  513.           LV7WRK(ienr,2,1,I)= LV7WRK(ienr,2,1,I)
  514.      &      + (SHPWRK(1,inode)*xphi1)
  515.           LV7WRK(ienr,2,2,I)= LV7WRK(ienr,2,2,I)
  516.      &      + (SHPWRK(2,inode)*xphi1)
  517.           LV7WRK(ienr,2,3,I)= LV7WRK(ienr,2,3,I)
  518.      &      + (SHPWRK(3,inode)*xphi1)
  519.       IF (IDIM.EQ.3) LV7WRK(ienr,2,4,I)= LV7WRK(ienr,2,4,I)
  520.      &      + (SHPWRK(4,inode)*xphi1)
  521.  2522   continue
  522.  
  523.  2521  continue
  524. ccccc  fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  525.  
  526.  
  527.  2520 CONTINUE
  528. ccccc fin de BOUCLE SUR LES enrichissements cccccccccccccccc
  529.  
  530. c     on a construit
  531. C     LV7WRK(ienr, PSI/PHI, valeur/deriveeparqsi/pareta, iNOEUD)
  532.  
  533.  
  534. c*********************************************************
  535. c     Ajout des fonctions de forme d enrichissement
  536. c     + leurs derivees dans repere global
  537. c*********************************************************
  538.       CALL SHAPX(MELE,LV7WRK,NBENRMAX,NBENRJ,TLREEL,SHPWRK,IRET)
  539.  
  540.  
  541. c     retour a la partie commune aux EF enrichi et non enrichi
  542.  2999 continue
  543.  
  544. C*********************************************************
  545. C       CALCUL DE B'
  546. C*********************************************************
  547. c ZERO ne serait-il pas facultatif?
  548. c        call ZERO(BGENE,LHOOK,NLIGRP)
  549.         KB=1
  550. C       boucle sur tous les Ni
  551.         DO 3001 II=1,NBNI
  552.  
  553.           BGENE(1,KB)   = SHPWRK(2,II)
  554.           BGENE(2,KB+1) = SHPWRK(3,II)
  555.           BGENE(4,KB)   = SHPWRK(3,II)
  556.           BGENE(4,KB+1) = SHPWRK(2,II)
  557.  
  558.         IF(IDIM.EQ.3) THEN
  559.         BGENE(3,KB+2)=SHPWRK(4,II)
  560.         BGENE(5,KB)=SHPWRK(4,II)
  561.         BGENE(5,KB+2)=SHPWRK(2,II)
  562.         BGENE(6,KB+1)=SHPWRK(4,II)
  563.         BGENE(6,KB+2)=SHPWRK(3,II)
  564.         ENDIF
  565.  
  566.           KB = KB + IDIM
  567.  
  568.  3001   CONTINUE
  569. C
  570. c      if(J.eq.5.and.KGAU.eq.1) then
  571. c      if(KGAU.eq.1) then
  572. c      write(*,*) 'BGENE(1,..)=',(BGENE(1,iou),iou=1,2*NBNI)
  573. c      write(*,*) 'BGENE(2,..)=',(BGENE(2,iou),iou=1,2*NBNI)
  574. c      write(*,*) 'BGENE(6,..)=',(BGENE(6,iou),iou=1,2*NBNI)
  575. c      endif
  576. c      endif
  577.  
  578.  
  579. c
  580.  
  581. C*********************************************************
  582. C       CALCUL DE  B.q'
  583. C*********************************************************
  584.  
  585. C  APPEL A LA PROCEDURE DE CALCUL
  586.         CALL BST(BGENE,XDDL,(NBNI*IDIM),LHOOK,XSTRS)
  587. c
  588. c       cas de la priâe en compte des termes quadratiques
  589.         IF (IREPS2.EQ.1)
  590.      &  CALL BST2(SHPWRK,XDDL,XE,NBNI,IFOUR,XSTRS,TRACE,KGAU,
  591.      &            XDPGE,YDPGE,UDPGE,NIFOUR)
  592.  
  593. C*********************************************************
  594. C       ECRITURE DES DIFFERENTES COMPOSANTES DES DEFORMATIONS
  595. C*********************************************************
  596.         MPTVAL = IVAEPS
  597.         DO 7000 ICOMP=1,LHOOK
  598.           MELVAL = IVAL(ICOMP)
  599.           VELCHE(KGAU,J) = XSTRS(ICOMP)
  600.  7000   CONTINUE
  601. C     if(KGAU.eq.1) then
  602. C      write(*,*) J,KGAU,'EPSI(..)=',(XSTRS(iou),iou=1,LHOOK)
  603. C     endif
  604. c
  605. c
  606.  2500 CONTINUE
  607. C FIN DE BOUCLE SUR LES POINTS DE GAUSS <<<<<<<<<<<<<<
  608. C
  609.  
  610. *
  611. c     quelques suppressions
  612. c     (ici element non-incompressible=> pas besoin de MTRACE (cf epsi2)
  613.       IF (IREPS2.EQ.1) THEN
  614.         SEGSUP MTRACE
  615.       ENDIF
  616.  
  617. c
  618. c
  619.  2000 CONTINUE
  620. C FIN DE BOUCLE SUR LES ELEMENTS <<<<<<<<<<<<<<<<<<<<<
  621. c
  622. c
  623.  
  624. C*********************************************************
  625. C       SUPPRESSION ET DESACTIVATION DE SEGMENTS
  626. C*********************************************************
  627. C
  628.       SEGSUP,WRK1,WRK2
  629.       SEGSUP,MRACC
  630.  
  631.       END
  632.  
  633.  
  634.  
  635.  

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