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

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