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

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