Télécharger la plaquette Cast3M


fr en

Télécharger epsi3.eso

Retour à la liste

Numérotation des lignes : 

epsi3

  1. C EPSI3     SOURCE    OF166741  25/02/21    21:16:13     12166          
  2.       SUBROUTINE EPSI3(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT,
  3.      &     IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NSTRS,MFR,IPMINT,
  4.      &     NCARR,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,IVAEPS,
  5.      &     IPMIN1,UZDPG,RYDPG,RXDPG,NPINT,IIPDPG)
  6. C---------------------------------------------------------------------*
  7. C                                                                     *
  8. C           CALCUL DES DEFORMATIONS                                   *
  9. C                                                                     *
  10. C  poutres,tuyaux,coq3,dkt,coq4,coq8,coq2 ,dst,joint 3D,joints 2D     *
  11. C                                                                     *
  12. C---------------------------------------------------------------------*
  13. C                                                                     *
  14. C   ENTREES :                                                         *
  15. C   ________                                                          *
  16. C                                                                     *
  17. C        IPMAIL   Pointeur sur un segment  MELEME                     *
  18. C        IVADEP   Pointeur sur le chamelem de deplacements            *
  19. C        IVACAR   Pointeur sur les chamelems de caracteristiques      *
  20. C        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  21. C        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  22. C        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  23. C        LHOOK    Dimension de la matrice de Hooke                    *
  24. C        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  25. C        MATE     Numero du materiau                                  *
  26. C        CMATE    Nom du materiau                                     *
  27. C        NMATT    Nombre de composante de materiau (IMAT=1)           *
  28. C        NSTRS    Nombre de composante de contraintes/deformations    *
  29. C                 pour une matrice de hooke                           *
  30. C        MFR      Numero de formulation de l'element fini             *
  31. C        IPMINT   Pointeur sur un segment MINTE                       *
  32. C        IPMIN1   Pointeur sur un segment MINTE                       *
  33. C        NDEP     Nombre de composantes de deplacements               *
  34. C        NBPGAU   Nombre de point d'integration pour la rigidite      *
  35. C        NBPTEL   Nombre de points par element                        *
  36. C        MELE     Numero de l'element fini                            *
  37. C        LRE      Nombre de ddl dans la matrice de rigidite           *
  38. C        LW       Dimension du tableau de travail de l'element        *
  39. C        IRESP2   Flag pour indiquer si on veut les contraintes       *
  40. C                  de Piola-Kirchhoff                                 *
  41. C                 dans le cas des elements de coque integres          *
  42. C                                                                     *
  43. C   SORTIES :                                                         *
  44. C   ________                                                          *
  45. C                                                                     *
  46. C        IVAEPS   pointeur sur un segment MPTVAL contenant les        *
  47. C                 les melvals de déformations
  48. C                                                                     *
  49. C---------------------------------------------------------------------*
  50.       IMPLICIT INTEGER(I-N)
  51.       IMPLICIT REAL*8(A-H,O-Z)
  52.  
  53. -INC PPARAM
  54. -INC CCOPTIO
  55. -INC CCHAMP
  56.  
  57. -INC SMCHAML
  58. -INC SMCHPOI
  59. -INC SMELEME
  60. -INC SMCOORD
  61. -INC SMMODEL
  62. -INC SMINTE
  63. -INC SMLREEL
  64.  
  65. -INC TMPTVAL
  66.  
  67.       SEGMENT WRK1
  68.        REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS)
  69.        REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS)
  70.       ENDSEGMENT
  71.  
  72.       SEGMENT WRK2
  73.        REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  74.       ENDSEGMENT
  75.  
  76.       SEGMENT WRK3
  77.        REAL*8 WORK(LW)
  78.       ENDSEGMENT
  79.  
  80.       SEGMENT WRK4
  81.        REAL*8 BPSS(3,3) ,XEL(3,NBBB) ,XDDLOC(LRE)
  82.       ENDSEGMENT
  83.  
  84.       SEGMENT WRK5
  85.        REAL*8   XSTRS1(NSTRS1)
  86.       ENDSEGMENT
  87.       segment wrk7
  88.        real*8 out(30),propel(45),wk7d(1),wk7rel(1)
  89.       endsegment
  90.  
  91.       SEGMENT,MVELCH
  92.          REAL*8 VALMAT(NV1)
  93.       ENDSEGMENT
  94.  
  95.       CHARACTER*8 CMATE
  96.       CHARACTER*(NCONCH) CONM
  97.       PARAMETER (NINF=3)
  98.       INTEGER INFOS(NINF)
  99.       dimension rel(18,18)
  100.  
  101. C  initialisation pour l'optimiseur
  102.       MELVAL=0
  103.  
  104. C   INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  105. C   DE LA SECTION EN DEFO PLANE GENERALISEE
  106.       IF (IIPDPG.GT.0) THEN
  107. C <- test equivalent ici a IFOUR.EQ.-3
  108.         IREF=(IIPDPG-1)*(IDIM+1)
  109.         XDPGE=XCOOR(IREF+1)
  110.         YDPGE=XCOOR(IREF+2)
  111.       ELSE
  112.         XDPGE=0.D0
  113.         YDPGE=0.D0
  114.       ENDIF
  115. C
  116.       MELEME = IPMAIL
  117.       NBNN   = NUM(/1)
  118.       NBELEM = NUM(/2)
  119. C
  120.       NHRM=NIFOUR
  121. C
  122.       MINTE=IPMINT
  123.       NBBB=NBNN
  124.  
  125. C Petite verification prealable (normalement inutile)
  126.       mptval = IVAEPS
  127.       if (NSTRS.ne.ival(/1)) then
  128.         write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  129.         call erreur(5)
  130.         return
  131.       endif
  132.       do icomp = 1, NSTRS
  133.         melval = IVAL(ICOMP)
  134.         if (melval.le.0) then
  135.           write(ioimp,*) 'EPSI3 : incoherence IVAEPS ival(',icomp,')=0'
  136.           call erreur(5)
  137.           return
  138.         endif
  139.         if (NBPTEL.NE.melval.velche(/1)) then
  140.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  141.           call erreur(5)
  142.           return
  143.         endif
  144.         if (NBELEM .NE. melval.velche(/2)) then
  145.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  146.           call erreur(5)
  147.           return
  148.         endif
  149.       enddo
  150. C_______________________________________________________________________
  151. C
  152. C     NUMERO DES ETIQUETTES      :
  153. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  154. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  155. C     5  CONTINUE
  156. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  157. C     44 CONTINUE
  158. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  159. C_______________________________________________________________________
  160. C
  161.       GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  162.      1      99,99,99,99,99,99,27,28,27,99,99,99,99,99,99,99,99,99,99,99,
  163.      2      41,27,99,44,99,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99,
  164.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  165.      4      99,99,99,27,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE
  166. C
  167.       GOTO(168,169,170,171,172),MELE-167
  168.       if(mele.eq.260) go to 260
  169. C
  170.       GOTO 99
  171. C_______________________________________________________________________
  172. C ELEMENT SHB8
  173. C_______________________________________________________________________
  174.   260 continue
  175.       SEGINI WRK1,WRK7
  176.        DO  3260 IB=1,NBELEM
  177. C
  178. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  179. C
  180.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  181. C
  182. C     ON CHERCHE LES DEPLACEMENTS
  183. C
  184.          IE=1
  185.          MPTVAL=IVADEP
  186.          DO      IGAU=1,NBNN
  187.             DO      ICOMP=1,NDEP
  188.                MELVAL=IVAL(ICOMP)
  189.                IGMN=MIN(IGAU,VELCHE(/1))
  190.                IBMN=MIN(IB  ,VELCHE(/2))
  191.                XDDL(IE)=VELCHE(IGMN,IBMN)
  192.                IE=IE+1
  193.             enddo
  194.          enddo
  195.  
  196.         propel(1)=1
  197.         propel(2)=0.3
  198.         propel(3)=ireps2
  199.         call shb8(11,xe,wk7d,propel,xddl,wk7rel,out)
  200.  
  201. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  202. C
  203.          MPTVAL=IVAEPS
  204.          IE=1
  205.          DO IGAU=1,NBPTEL
  206.            DO ICOMP=1,NSTRS
  207.             MELVAL=IVAL(ICOMP)
  208.             VELCHE(IGAU,IB)=out(IE)
  209.             IE=IE+1
  210.            enddo
  211.          enddo
  212. C
  213.  3260 CONTINUE
  214.       SEGSUP WRK1,WRK7
  215.       GOTO 510
  216. C
  217. C_______________________________________________________________________
  218. C
  219. C     ELEMENTS  COQ3   POUTRE ET TUYAU ET POUTRE TIMOSCHENKO
  220. C_______________________________________________________________________
  221. C
  222.   27  CONTINUE
  223.       SEGINI WRK1,WRK3
  224. C
  225. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  226. C
  227.       DO  3027 IB=1,NBELEM
  228. C
  229. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  230. C
  231.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  232. C
  233. C     ON CHERCHE LES DEPLACEMENTS
  234. C
  235.          MPTVAL=IVADEP
  236.          IE=1
  237.          DO      IGAU=1,NBNN
  238.             DO      ICOMP=1,NDEP
  239.                MELVAL=IVAL(ICOMP)
  240.                IGMN=MIN(IGAU,VELCHE(/1))
  241.                IBMN=MIN(IB  ,VELCHE(/2))
  242.                XDDL(IE)=VELCHE(IGMN,IBMN)
  243.                IE=IE+1
  244.             enddo
  245.          enddo
  246.          IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.84) GO TO 5029
  247. C     CAS DES COQ3
  248. C
  249. C     ON MET LA MATRICE DE HOOKE A L IDENTITE
  250. C
  251.          CALL HOOKID(DDHOOK,NSTRS)
  252.          CALL COQ3ST(XE,XDDL,XSTRS,DDHOOK)
  253. C
  254.          IF(IREPS2.EQ.1)
  255.      1     CALL DBCO32(XE,DDHOOK,XDDL,WORK,XSTRS)
  256. C
  257.          MPTVAL=IVAEPS
  258.          DO 6027 ICOMP=1,NSTRS
  259.             MELVAL=IVAL(ICOMP)
  260.             VELCHE(1,IB)=XSTRS(ICOMP)
  261.  6027    CONTINUE
  262. C
  263.          GOTO 3027
  264. C
  265. C        CAS DES POUTRES ET DES TUYAUX
  266. C  ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES DANS WORK
  267. C
  268.  5029    CONTINUE
  269. C
  270. C  pour les poutres et tuyaux on cherche le module d'young et nu si
  271. C  section reduite
  272.        If( mele.eq.29.or.mele.eq.42) then
  273.          mptval = ivamat
  274.          melval=ival(1)
  275.          IGMN=MIN(IGAU,VELCHE(/1))
  276.          ibmn= MIN(IB,VELCHE(/2))
  277.          youtc=VELCHE(IGMN,IBMN)
  278.          melval=ival(2)
  279.          IGMN=MIN(IGAU,VELCHE(/1))
  280.          ibmn= MIN(IB,VELCHE(/2))
  281.          xnutc=VELCHE(IGMN,IBMN)
  282.        endif
  283.  
  284. C
  285. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  286. C
  287.          MPTVAL=IVACAR
  288.          DO 6029 IC=1,NCARR
  289.            MELVAL = IVAL(IC)
  290.            IF (MELVAL.NE.0) THEN
  291.              I2MN = VELCHE(/2)
  292.              I1MN = VELCHE(/1)
  293.              IF (I1MN.GT.0.AND.I2MN.GT.0) THEN
  294.                IBMN = MIN(IB,I2MN)
  295.                r_z = 0.D0
  296.                DO 4029 IGAU=1,NBNN
  297.                  IGMN = MIN(IGAU,I1MN)
  298.                  r_z = r_z + VELCHE(IGMN,IBMN)
  299.  4029          CONTINUE
  300.                WORK(IC) = r_z / NBNN
  301.              ELSE
  302.                WORK(IC) = 0.D0
  303.              ENDIF
  304.            ELSE
  305.              WORK(IC) = 0.D0
  306.            ENDIF
  307.  6029    CONTINUE
  308. C
  309. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  310. C                   EQUIVALENTE
  311.          IF(MELE.EQ.42) THEN
  312.            CISA=WORK(4)
  313.            VX=WORK(5)
  314.            VY=WORK(6)
  315.            VZ=WORK(7)
  316.            CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  317.          ENDIF
  318. C
  319. C  ON CALCULE LES DEFORMATIONS
  320. C
  321.          IF(MELE.EQ.84) THEN
  322. C
  323.           IF(CMATE.EQ.'SECTION') THEN
  324.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  325.               CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2)
  326.             ELSE
  327.               CALL TIMEPS(XE,XDDL,WORK(1),WORK(12),WORK(25),IREPS2)
  328.             ENDIF
  329.           ELSE
  330. C
  331.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  332.               CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2)
  333. C
  334.             ELSE
  335.               CALL TIMEPS(XE,XDDL,WORK(7),WORK(12),WORK(25),IREPS2)
  336.             ENDIF
  337.           ENDIF
  338.          ELSE
  339. C
  340.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  341.               CALL POUEP2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2
  342.      $         ,youtc,xnutc)
  343.             ELSE
  344. C
  345.               CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2
  346.      $        , youtc,xnutc)
  347.             ENDIF
  348.          ENDIF
  349. C
  350. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  351. C
  352.            IE=12
  353. C
  354.          MPTVAL=IVAEPS
  355.          DO IGAU=1,NBPTEL
  356.            DO ICOMP=1,NSTRS
  357.              MELVAL=IVAL(ICOMP)
  358.              VELCHE(IGAU,IB)=WORK(IE)
  359.              IE=IE+1
  360.            enddo
  361.          enddo
  362. C
  363.  3027 CONTINUE
  364.       SEGSUP WRK1,WRK3
  365.       GOTO 510
  366. C_______________________________________________________________________
  367. C
  368. C     ELEMENT DKT
  369. C_______________________________________________________________________
  370. C
  371.   28  CONTINUE
  372.       NBNO=NBNN
  373.       SEGINI WRK1,WRK2,WRK4
  374.       IF(NPINT.NE.0)THEN
  375.         NSTRS1=6
  376.         SEGINI WRK5
  377.       ENDIF
  378.       DO 3028  IB=1,NBELEM
  379. C
  380. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  381. C
  382.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  383. C
  384. C     ON CHERCHE LES DEPLACEMENTS
  385. C
  386.          MPTVAL=IVADEP
  387.          IE=1
  388.          DO      IGAU=1,NBNN
  389.             DO      ICOMP=1,NDEP
  390.                MELVAL=IVAL(ICOMP)
  391.                IGMN=MIN(IGAU,VELCHE(/1))
  392.                IBMN=MIN(IB  ,VELCHE(/2))
  393.                XDDL(IE)=VELCHE(IGMN,IBMN)
  394.                IE=IE+1
  395.             enddo
  396.          enddo
  397. C
  398. C     ON CHERCHE L EPAISSEUR ET L EXCENTREMENT
  399. C
  400.             MPTVAL=IVACAR
  401.             MELVAL=IVAL(1)
  402.             IF (MELVAL.NE.0) THEN
  403.                IBMN=MIN(IB,VELCHE(/2))
  404.                EPAIST=VELCHE(1,IBMN)
  405.             ELSE
  406.                EPAIST=0.D0
  407.             ENDIF
  408.             MELVAL=IVAL(2)
  409.             IF (MELVAL.NE.0) THEN
  410.                IBMN=MIN(IB,VELCHE(/2))
  411.                EXCEN=VELCHE(1,IBMN)
  412.             ELSE
  413.                EXCEN=0.D0
  414.             ENDIF
  415. C
  416.          CALL VPAST(XE,BPSS)
  417. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  418.          CALL VCORLC (XE,XEL,BPSS)
  419.          CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  420. C
  421.       IF(NPINT.EQ.0)THEN
  422. C
  423. C     COQUE GLOBAL
  424. C
  425. C     BOUCLE SUR LES POINTS DE GAUSS
  426. C
  427.          DO 5028  IGAU=1,NBPTEL
  428.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  429.      &           MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL,
  430.      &          SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  431. C
  432. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  433. C
  434.           IF (EXCEN.NE.0.) THEN
  435.             DO      IJL=1,3
  436.                DO      IJC=1,LRE
  437.                   BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  438.                enddo
  439.             enddo
  440.           ENDIF
  441. C
  442.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  443. C
  444. C     CALCUL DES EPS 2
  445. C
  446.             IF(IREPS2.EQ.1)
  447.      1       CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS)
  448. C
  449. C     RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  450. C
  451.             MPTVAL=IVAEPS
  452.             DO 9028 ICOMP=1,NSTRS
  453.                MELVAL=IVAL(ICOMP)
  454.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  455.  9028       CONTINUE
  456.  5028    CONTINUE
  457. C
  458.       ELSE
  459. C
  460. C    COQUE INTEGREE
  461. C
  462.       NBPGA1=NBPGAU/NPINT
  463. C
  464. C     BOUCLE SUR LES POINTS DE GAUSS DE LA SURFACE
  465. C
  466.       DO 5001 IGAU=1, NBPGA1
  467.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  468.      &          MELE,MFR,NBNO,LRE,IFOUR,NSTRS1,0,1.D0,XEL,
  469.      &          SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  470. C
  471. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  472. C
  473.           IF (EXCEN.NE.0.) THEN
  474.       DO      IJL=1,3
  475.       DO      IJC=1,LRE
  476.         BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  477.       enddo
  478.       enddo
  479.           ENDIF
  480. C
  481. C   BOUCLE SUR LES NAPPES
  482. C
  483.       DO 5002 INAP=1,NPINT
  484.       IGAU1=(INAP-1)*NBPGA1+IGAU
  485. C
  486.       CALL BST(BGENE,XDDLOC,LRE,NSTRS1,XSTRS1)
  487. C
  488. C     CALCUL DES EPS 2
  489. C
  490.       IF(IREPS2.EQ.1)
  491.      1  CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS1)
  492. C
  493.       ZZZ=DZEGAU(IGAU1)*(0.5D0*EPAIST)
  494.       XSTRS(1)=XSTRS1(1)+ZZZ*XSTRS1(4)
  495.       XSTRS(2)=XSTRS1(2)+ZZZ*XSTRS1(5)
  496.       XSTRS(3)=0.D0
  497.       XSTRS(4)=XSTRS1(3)+ZZZ*XSTRS1(6)
  498. C
  499. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  500. C
  501.       MPTVAL=IVAEPS
  502.       DO 9001 ICOMP=1,NSTRS
  503.         MELVAL=IVAL(ICOMP)
  504.         VELCHE(IGAU1,IB)=XSTRS(ICOMP)
  505.  9001 CONTINUE
  506. C
  507. C FIN DE BOUCLE SUR LES NAPPES DE POINTS
  508.  5002 CONTINUE
  509. C FIN DE BOUCLE SUR  LES POINTS DANS CHAQUE NAPPE
  510.  5001 CONTINUE
  511. C FIN DE BOUCLE SUR LES POINTS D'INTEGRATION
  512.       ENDIF
  513. C FIN DE BOUCLE SUR LES ELEMENTS
  514.  3028 CONTINUE
  515.       SEGSUP WRK1,WRK2,WRK4
  516.       IF(NPINT.NE.0) SEGSUP WRK5
  517. C
  518.       GOTO 510
  519. C_______________________________________________________________________
  520. C
  521. C     ELEMENTS COQ8  ET COQ6
  522. C_______________________________________________________________________
  523. C
  524.   41  CONTINUE
  525.       SEGINI WRK1,WRK3
  526.       MINTE1=IPMIN1
  527.       SEGACT MINTE1
  528.       NBPGA1=MINTE1.SHPTOT(/3)
  529. C      NBN1  =MINTE1.SHPTOT(/2)
  530. C
  531. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  532. C
  533.       DO  3041 IB=1,NBELEM
  534. C
  535. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  536. C
  537.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  538. C
  539. C     ON CHERCHE LES DEPLACEMENTS
  540. C
  541.          MPTVAL=IVADEP
  542.          IE=1
  543.          DO      IGAU=1,NBNN
  544.             DO      ICOMP=1,NDEP
  545.                MELVAL=IVAL(ICOMP)
  546.                IGMN=MIN(IGAU,VELCHE(/1))
  547.                IBMN=MIN(IB  ,VELCHE(/2))
  548.                XDDL(IE)=VELCHE(IGMN,IBMN)
  549.                IE=IE+1
  550.             enddo
  551.          enddo
  552. C
  553. C     ON CHERCHE LES EPAISSEURS ET LES EXCENTREMENTS,
  554. C     ON LES MOYENNE SUR L'ELEMENT.
  555. C
  556.          MPTVAL=IVACAR
  557.          MELVAL=IVAL(1)
  558.          EPAIST=0.D0
  559.          IF (MELVAL.NE.0) THEN
  560.            IBMN=MIN(IB  ,VELCHE(/2))
  561.            DO  IGAU=1,NBPGAU
  562.                IGMN=MIN(IGAU,VELCHE(/1))
  563.                EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  564.            ENDDO
  565.            EPAIST=EPAIST/NBPGAU
  566.          ENDIF
  567. C
  568.          MELVAL=IVAL(2)
  569.          EXCEN=0.D0
  570.          IF (MELVAL.NE.0) THEN
  571.            IBMN=MIN(IB  ,VELCHE(/2))
  572.            DO  IGAU=1,NBPGAU
  573.                IGMN=MIN(IGAU,VELCHE(/1))
  574.                EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  575.            ENDDO
  576.            EXCEN=EXCEN/NBPGAU
  577.          ENDIF
  578. C
  579. C     ON CALCULE LES DEFORMATIONS
  580. C
  581.          CALL COQ8EP(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,EXCEN,
  582.      1      DZEGAU,SHPTOT,MINTE1.SHPTOT,XDDL,WORK,IRR)
  583. C
  584. C     ON REMPLIT LES DEFORMATIONS
  585. C
  586.          MPTVAL=IVAEPS
  587.          IE=1
  588.          DO      IGAU=1,NBPGAU
  589.             DO      ICOMP=1,NSTRS
  590.                MELVAL=IVAL(ICOMP)
  591.                VELCHE(IGAU,IB)=WORK(IE)
  592.                IE=IE+1
  593.             enddo
  594.          enddo
  595. C
  596.  3041 CONTINUE
  597.       SEGSUP WRK1,WRK3
  598.       GOTO 510
  599. C_______________________________________________________________________
  600. C
  601. C     ELEMENT COQ2
  602. C_______________________________________________________________________
  603. C
  604.    44 CONTINUE
  605.       NBNO=NBNN
  606.       SEGINI WRK1,WRK2
  607. C
  608.       NDDD=NDEP
  609.       IF (IFOUR.EQ.-3) NDDD=NDEP-3
  610.       DO 3044 IB=1,NBELEM
  611. C
  612. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  613. C
  614.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  615. C
  616. C     ON CHERCHE LES DEPLACEMENTS
  617. C
  618.          MPTVAL=IVADEP
  619.          IE=1
  620.          DO      IGAU=1,NBNN
  621.             DO      ICOMP=1,NDDD
  622.                MELVAL=IVAL(ICOMP)
  623.                IGMN=MIN(IGAU,VELCHE(/1))
  624.                IBMN=MIN(IB  ,VELCHE(/2))
  625.                XDDL(IE)=VELCHE(IGMN,IBMN)
  626.                IE=IE+1
  627.             enddo
  628.          enddo
  629.          IF (IFOUR.EQ.-3) THEN
  630.                XDDL(IE)=UZDPG
  631.                XDDL(IE+1)=RYDPG
  632.                XDDL(IE+2)=RXDPG
  633.          ENDIF
  634. C
  635. C     BOUCLE SUR LES POINTS DE GAUSS
  636. C
  637.             DO 4044 IGAU=1,NBPGAU
  638.                MPTVAL=IVACAR
  639.                MELVAL=IVAL(2)
  640.                IF (MELVAL.NE.0) THEN
  641.                   IBMN=MIN(IB,VELCHE(/2))
  642.                   EXCEN=VELCHE(1,IBMN)
  643.                 ELSE
  644.                   EXCEN=0.D0
  645.                 ENDIF
  646. C     APPEL A BCOQ2
  647. C
  648.       CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  649.      .           EXCEN,1.D0,IRR,XDPGE,YDPGE)
  650. C
  651. C     GESTION D'ERREUR
  652. C
  653.             IF (IRR.EQ.1) THEN
  654.               INTERR(1)=IB
  655.               CALL ERREUR(255)
  656.               GOTO 9944
  657.             ELSE IF(IRR.EQ.2) THEN
  658.               INTERR(1)=IB
  659.               CALL ERREUR(256)
  660.               GOTO 9944
  661.             ENDIF
  662. C
  663.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  664.  
  665.             IF(IREPS2.EQ.1)
  666.      +call b2coq2(xstrs,nstrs,xddl,nbnn*ndep,xe,nbnn,QSIGAU,POIGAU,igau)
  667. C
  668. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  669. C
  670.             MPTVAL=IVAEPS
  671.             DO 9044 ICOMP=1,NSTRS
  672.                MELVAL=IVAL(ICOMP)
  673.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  674.  9044       CONTINUE
  675.  4044    CONTINUE
  676.  3044 CONTINUE
  677. C
  678.  9944 CONTINUE
  679.       SEGSUP WRK1,WRK2
  680.       GOTO 510
  681. C_______________________________________________________________________
  682. C
  683. C     ELEMENT COQ4
  684. C_______________________________________________________________________
  685. C
  686.    49 CONTINUE
  687.       NBNO=NBNN
  688.       SEGINI WRK1,WRK2,WRK4
  689. C
  690.       DO 3049 IB=1,NBELEM
  691. C
  692. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  693. C
  694.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  695. C
  696.          CALL CQ4LOC(XE,XEL,BPSS,IERT,1)
  697. C        IERT=1 NODI  TROPPO VICINI
  698.          IF (IERT.EQ.1) THEN
  699.            INTERR(1)=IB
  700.            CALL ERREUR(323)
  701.            GOTO 9949
  702.          ELSE IF(IERT.EQ.3) THEN
  703.             IERT = 0
  704.             NOPLAN = 1
  705.          ELSE
  706.             NOPLAN = 0
  707.          END IF
  708. C
  709. C     ON CHERCHE LES DEPLACEMENTS
  710. C
  711.          IE=1
  712.          DO      IGAU=1,NBNN
  713.             MPTVAL=IVADEP
  714.             DO      ICOMP=1,NDEP
  715.                MELVAL=IVAL(ICOMP)
  716.                IGMN=MIN(IGAU,VELCHE(/1))
  717.                IBMN=MIN(IB  ,VELCHE(/2))
  718.                XDDL(IE)=VELCHE(IGMN,IBMN)
  719.                IE=IE+1
  720.             enddo
  721.          enddo
  722.          CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  723. C
  724. C     BOUCLE SUR LES POINTS DE GAUSS
  725. C
  726.          MPTVAL=IVACAR
  727.          MELVAL=IVAL(1)
  728.          IF (MELVAL.NE.0) THEN
  729.             IBMN=MIN(IB,VELCHE(/2))
  730.             EPAIST=VELCHE(1,IBMN)
  731.          ELSE
  732.             EPAIST=0.D0
  733.          ENDIF
  734. C
  735.          MELVAL=IVAL(2)
  736.          IF (MELVAL.NE.0) THEN
  737.             IBMN=MIN(IB,VELCHE(/2))
  738.             EXCEN=VELCHE(1,IBMN)
  739.          ELSE
  740.             EXCEN=0.D0
  741.          ENDIF
  742. C
  743.          DO 4049 IGAU=1,NBPGAU
  744. C
  745.             if(cmate.eq.'ISOTROPE') then
  746.             CALL BCOQ4
  747.      &      (IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1)
  748.             else
  749.             CALL BCOQ4O
  750.      &      (IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1)
  751.             endif
  752. C           IERT=1 JACOBIANO <= 0
  753.             IF(IERT.EQ.1) THEN
  754.               INTERR(1)=IB
  755.               CALL ERREUR(321)
  756.               GOTO 9949
  757.             ENDIF
  758. C
  759.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  760. C
  761. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  762. C
  763.             MPTVAL=IVAEPS
  764.             DO 9049 ICOMP=1,NSTRS
  765.                MELVAL=IVAL(ICOMP)
  766.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  767.  9049       CONTINUE
  768.  4049    CONTINUE
  769.  3049 CONTINUE
  770. C
  771.  9949 CONTINUE
  772.       SEGSUP WRK1,WRK2,WRK4
  773.       GOTO 510
  774. C_______________________________________________________________________
  775. C
  776. C     ELEMENT JOINT (JOI2)
  777. C_______________________________________________________________________
  778. C
  779.    85 CONTINUE
  780.       NBNO=NBNN
  781.       SEGINI WRK1,WRK2,WRK4
  782. C
  783.       DO 3085 IB=1,NBELEM
  784. C
  785. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  786. C
  787.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  788. C
  789.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  790. C
  791. C     ON CHERCHE LES DEPLACEMENTS
  792. C
  793.          MPTVAL=IVADEP
  794.          IE=1
  795.          DO      IGAU=1,NBNN
  796.             DO      ICOMP=1,NDEP
  797.                MELVAL=IVAL(ICOMP)
  798.                IGMN=MIN(IGAU,VELCHE(/1))
  799.                IBMN=MIN(IB  ,VELCHE(/2))
  800.                XDDL(IE)=VELCHE(IGMN,IBMN)
  801.                IE=IE+1
  802.             enddo
  803.          enddo
  804. C
  805. C     BOUCLE SUR LES POINTS DE GAUSS
  806. C
  807.          DO 4085 IGAU=1,NBPGAU
  808. C
  809.             CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  810.      .                                       BGENE,DJAC,IRRT)
  811. C           IRRT.NE.0 JACOBIEN <= 0
  812.             IF(IRRT.NE.0) THEN
  813.               INTERR(1)=IB
  814.               CALL ERREUR(612)
  815.               GOTO 9985
  816.             ENDIF
  817. C
  818.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  819. C
  820. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  821. C
  822.             MPTVAL=IVAEPS
  823.             DO 9085 ICOMP=1,NSTRS
  824.                MELVAL=IVAL(ICOMP)
  825.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  826.  9085       CONTINUE
  827.  4085    CONTINUE
  828.  3085 CONTINUE
  829. C
  830.  9985 CONTINUE
  831.       SEGSUP WRK1,WRK2,WRK4
  832.       GOTO 510
  833. C_______________________________________________________________________
  834. C
  835. C     ELEMENT JOINT (JGI2)
  836. C_______________________________________________________________________
  837. C
  838.   170 CONTINUE
  839.       NBNO=NBNN
  840.       SEGINI WRK1,WRK2,WRK4
  841. C
  842.       NDDD=NDEP
  843.       IF (IFOUR.EQ.-3) NDDD=NDEP-3
  844. C
  845.       DO IB=1,NBELEM
  846. C
  847. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  848. C
  849.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  850. C
  851.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  852. C
  853. C     ON CHERCHE LES DEPLACEMENTS
  854. C
  855.          MPTVAL=IVADEP
  856.          IE=1
  857.          DO IGAU=1,NBNN
  858.             DO ICOMP=1,NDDD
  859.                MELVAL=IVAL(ICOMP)
  860.                IGMN=MIN(IGAU,VELCHE(/1))
  861.                IBMN=MIN(IB  ,VELCHE(/2))
  862.                XDDL(IE)=VELCHE(IGMN,IBMN)
  863.                IE=IE+1
  864.             ENDDO
  865.          ENDDO
  866.          IF (IFOUR.EQ.-3) THEN
  867.                XDDL(IE)=UZDPG
  868.                XDDL(IE+1)=RYDPG
  869.                XDDL(IE+2)=RXDPG
  870.          ENDIF
  871. C
  872. C     BOUCLE SUR LES POINTS DE GAUSS
  873. C
  874.          DO IGAU=1,NBPGAU
  875. C
  876. C        ON CHERCHE L EPAISSEUR DU JOINT
  877. C
  878.             MPTVAL=IVACAR
  879.             MELVAL=IVAL(1)
  880.             IF (MELVAL.NE.0) THEN
  881.               IGMN=MIN(IGAU,VELCHE(/1))
  882.               IBMN=MIN(IB,VELCHE(/2))
  883.               EPAIST=VELCHE(IGMN,IBMN)
  884.             ELSE
  885.               EPAIST=0.D0
  886.             ENDIF
  887. C
  888. CcPPj       CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  889. CcPPj.                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  890.             CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  891.      .                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  892. C           IRRT.NE.0 JACOBIEN <= 0
  893.             IF (IRRT.NE.0) THEN
  894.               INTERR(1)=IB
  895.               CALL ERREUR(612)
  896.               GOTO 9970
  897.             ENDIF
  898. C
  899.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  900. C
  901. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  902. C
  903.             MPTVAL=IVAEPS
  904.             DO ICOMP=1,NSTRS
  905.                MELVAL=IVAL(ICOMP)
  906.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  907.             ENDDO
  908.          ENDDO
  909.       ENDDO
  910. C
  911.  9970 CONTINUE
  912.       SEGSUP WRK1,WRK2,WRK4
  913.       GOTO 510
  914. C_______________________________________________________________________
  915. C
  916. C     ELEMENT JOINT (JCT3) en 2D cisaillement
  917. C_______________________________________________________________________
  918. C
  919.   168 CONTINUE
  920.       NBNO=NBNN
  921.       SEGINI WRK1,WRK2,WRK4
  922. C
  923.       DO IB=1,NBELEM
  924. C
  925. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  926. C
  927.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  928. C
  929.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  930. C
  931. C     ON CHERCHE LES DEPLACEMENTS
  932. C
  933.          IE=1
  934.          MPTVAL=IVADEP
  935.          DO IGAU=1,NBNN
  936.             DO ICOMP=1,NDEP
  937.                MELVAL=IVAL(ICOMP)
  938.                IGMN=MIN(IGAU,VELCHE(/1))
  939.                IBMN=MIN(IB  ,VELCHE(/2))
  940.                XDDL(IE)=VELCHE(IGMN,IBMN)
  941.                IE=IE+1
  942.             END DO
  943.          END DO
  944. C
  945. C     BOUCLE SUR LES POINTS DE GAUSS
  946. C
  947.          DO IGAU=1,NBPGAU
  948. C
  949.             CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  950.      .                                       BGENE,DJAC,IRRT)
  951. C           IRRT.NE.0 JACOBIEN <= 0
  952.             IF(IRRT.NE.0) THEN
  953.               INTERR(1)=IB
  954.               GOTO 9968
  955.             ENDIF
  956. C
  957.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  958. C
  959. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  960. C
  961.             MPTVAL=IVAEPS
  962.             DO ICOMP=1,NSTRS
  963.                MELVAL=IVAL(ICOMP)
  964.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  965.             END DO
  966.          END DO
  967.       END DO
  968. C
  969.  9968 CONTINUE
  970.       SEGSUP WRK1,WRK2,WRK4
  971.       GOTO 510
  972. C_______________________________________________________________________
  973. C
  974. C     ELEMENT JOINT (JGT3) GENERALISE
  975. C_______________________________________________________________________
  976. C
  977.   171 CONTINUE
  978.       NBNO=NBNN
  979.       SEGINI WRK1,WRK2,WRK4
  980. C
  981.       DO IB=1,NBELEM
  982. C
  983. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  984. C
  985.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  986. C
  987.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  988. C
  989. C     ON CHERCHE LES DEPLACEMENTS
  990. C
  991.          MPTVAL=IVADEP
  992.          IE=1
  993.          DO IGAU=1,NBNN
  994.             DO ICOMP=1,NDEP
  995.                MELVAL=IVAL(ICOMP)
  996.                IGMN=MIN(IGAU,VELCHE(/1))
  997.                IBMN=MIN(IB  ,VELCHE(/2))
  998.                XDDL(IE)=VELCHE(IGMN,IBMN)
  999.                IE=IE+1
  1000.             END DO
  1001.          END DO
  1002. C
  1003. C     BOUCLE SUR LES POINTS DE GAUSS
  1004. C
  1005.          DO IGAU=1,NBPGAU
  1006. C
  1007. C        ON CHERCHE L'EPAISSEUR DU JOINT
  1008. C
  1009.             MPTVAL=IVACAR
  1010.             MELVAL=IVAL(1)
  1011.             IF (MELVAL.NE.0) THEN
  1012.               IGMN=MIN(IGAU,VELCHE(/1))
  1013.               IBMN=MIN(IB,VELCHE(/2))
  1014.               EPAIST=VELCHE(IGMN,IBMN)
  1015.             ELSE
  1016.               EPAIST=0.D0
  1017.             ENDIF
  1018. C
  1019. C     ON CALCULE B
  1020. C
  1021. CcPPj       CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1022.             CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1023.      .                                EPAIST,BGENE,DJAC,IRRT)
  1024. C           IRRT.NE.0 JACOBIEN <= 0
  1025.             IF (IRRT.NE.0) THEN
  1026.               INTERR(1)=IB
  1027.               CALL ERREUR(611)
  1028.               GOTO 9971
  1029.             ENDIF
  1030. C
  1031.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1032. C
  1033. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1034. C
  1035.             MPTVAL=IVAEPS
  1036.             DO ICOMP=1,NSTRS
  1037.                MELVAL=IVAL(ICOMP)
  1038.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1039.             END DO
  1040.          END DO
  1041.       END DO
  1042. C
  1043.  9971 CONTINUE
  1044.       SEGSUP WRK1,WRK2,WRK4
  1045.       GOTO 510
  1046. C_______________________________________________________________________
  1047. C
  1048. C     ELEMENT JOINT (JCI4) en 2D cisaillement
  1049. C_______________________________________________________________________
  1050. C
  1051.   169 CONTINUE
  1052.       NBNO=NBNN
  1053.       SEGINI WRK1,WRK2,WRK4
  1054. C
  1055.       DO IB=1,NBELEM
  1056. C
  1057. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1058. C
  1059.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1060. C
  1061.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1062. C
  1063. C     ON CHERCHE LES DEPLACEMENTS
  1064. C
  1065.          MPTVAL=IVADEP
  1066.          IE=1
  1067.          DO IGAU=1,NBNN
  1068.             DO ICOMP=1,NDEP
  1069.                MELVAL=IVAL(ICOMP)
  1070.                IGMN=MIN(IGAU,VELCHE(/1))
  1071.                IBMN=MIN(IB  ,VELCHE(/2))
  1072.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1073.                IE=IE+1
  1074.             ENDDO
  1075.          ENDDO
  1076. C
  1077. C     BOUCLE SUR LES POINTS DE GAUSS
  1078. C
  1079.          DO IGAU=1,NBPGAU
  1080. C
  1081.             CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1082. C           IRRT.NE.0 JACOBIEN <= 0
  1083.             IF(IRRT.NE.0) THEN
  1084.               INTERR(1)=IB
  1085.               CALL ERREUR(611)
  1086.               GOTO 9969
  1087.             ENDIF
  1088. C
  1089.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1090. C
  1091. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1092. C
  1093.             MPTVAL=IVAEPS
  1094.             DO ICOMP=1,NSTRS
  1095.                MELVAL=IVAL(ICOMP)
  1096.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1097.             ENDDO
  1098.          ENDDO
  1099.       ENDDO
  1100. C
  1101.  9969 CONTINUE
  1102.       SEGSUP WRK1,WRK2,WRK4
  1103.       GOTO 510
  1104. C_______________________________________________________________________
  1105. C
  1106. C     ELEMENT JOINT (JGI4) GENERALISE
  1107. C_______________________________________________________________________
  1108. C
  1109.   172 CONTINUE
  1110.       NBNO=NBNN
  1111.       SEGINI WRK1,WRK2,WRK4
  1112. C
  1113.       DO IB=1,NBELEM
  1114. C
  1115. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1116. C
  1117.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1118. C
  1119.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1120. C
  1121. C     ON CHERCHE LES DEPLACEMENTS
  1122. C
  1123.          MPTVAL=IVADEP
  1124.          IE=1
  1125.          DO IGAU=1,NBNN
  1126.             DO ICOMP=1,NDEP
  1127.                MELVAL=IVAL(ICOMP)
  1128.                IGMN=MIN(IGAU,VELCHE(/1))
  1129.                IBMN=MIN(IB  ,VELCHE(/2))
  1130.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1131.                IE=IE+1
  1132.             ENDDO
  1133.          ENDDO
  1134. C
  1135. C     BOUCLE SUR LES POINTS DE GAUSS
  1136. C
  1137.          DO IGAU=1,NBPGAU
  1138. C
  1139. C        ON CHERCHE L'EPAISSEUR DU JOINT
  1140. C
  1141.             MPTVAL=IVACAR
  1142.             MELVAL=IVAL(1)
  1143.             IF (MELVAL.NE.0) THEN
  1144.               IGMN=MIN(IGAU,VELCHE(/1))
  1145.               IBMN=MIN(IB,VELCHE(/2))
  1146.               EPAIST=VELCHE(IGMN,IBMN)
  1147.             ELSE
  1148.               EPAIST=0.D0
  1149.             ENDIF
  1150. C
  1151. CcPPj       CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1152.             CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1153.      >                 BGENE,DJAC,IRRT)
  1154. C           IRRT.NE.0 JACOBIEN <= 0
  1155.             IF (IRRT.NE.0) THEN
  1156.               INTERR(1)=IB
  1157.               CALL ERREUR(611)
  1158.               GOTO 9972
  1159.             ENDIF
  1160. C
  1161.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1162. C
  1163. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1164. C
  1165.             MPTVAL=IVAEPS
  1166.             DO ICOMP=1,NSTRS
  1167.                MELVAL=IVAL(ICOMP)
  1168.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1169.             ENDDO
  1170.          ENDDO
  1171.       ENDDO
  1172. C
  1173.  9972 CONTINUE
  1174.       SEGSUP WRK1,WRK2,WRK4
  1175.       GOTO 510
  1176.  
  1177. C_______________________________________________________________________
  1178. C
  1179. C     ELEMENT JOINT (JOI3) IMPLEMENTATION SANS TEST DE PLANEITE
  1180. C                                         ET SANS REPERE LOCAL
  1181. C_______________________________________________________________________
  1182. C
  1183.    86 CONTINUE
  1184.       NBNO=NBNN
  1185.       SEGINI WRK1,WRK2,WRK4
  1186. C
  1187.       DO 3086 IB=1,NBELEM
  1188. C
  1189. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1190. C
  1191.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1192. C
  1193. C     ON CHERCHE LES DEPLACEMENTS
  1194. C
  1195.          MPTVAL=IVADEP
  1196.          IE=1
  1197.          DO      IGAU=1,NBNN
  1198.             DO      ICOMP=1,NDEP
  1199.                MELVAL=IVAL(ICOMP)
  1200.                IGMN=MIN(IGAU,VELCHE(/1))
  1201.                IBMN=MIN(IB  ,VELCHE(/2))
  1202.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1203.                IE=IE+1
  1204.             enddo
  1205.          enddo
  1206. C
  1207. C     BOUCLE SUR LES POINTS DE GAUSS
  1208. C
  1209.          DO 4086 IGAU=1,NBPGAU
  1210. C
  1211.             CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS)
  1212. C
  1213.             CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  1214.      .                                     BGENE,DJAC,IRRT)
  1215. C           IRRT.NE.0 JACOBIEN <= 0
  1216.             IF (IRRT.NE.0) THEN
  1217.               INTERR(1)=IB
  1218.               CALL ERREUR(612)
  1219.               GOTO 9986
  1220.             ENDIF
  1221. C
  1222.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1223. C
  1224. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1225. C
  1226.             MPTVAL=IVAEPS
  1227.             DO 9086 ICOMP=1,NSTRS
  1228.                MELVAL=IVAL(ICOMP)
  1229.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1230.  9086       CONTINUE
  1231.  4086    CONTINUE
  1232.  3086 CONTINUE
  1233. C
  1234. C     IMPRESSION D'UN MESSAGE D'ERREUR
  1235. C
  1236.  9986 CONTINUE
  1237.       SEGSUP WRK1,WRK2,WRK4
  1238.       GOTO 510
  1239. C_______________________________________________________________________
  1240. C
  1241. C     ELEMENT JOINT (JOT3)
  1242. C_______________________________________________________________________
  1243. C
  1244.    87 CONTINUE
  1245.       NBNO=NBNN
  1246.       SEGINI WRK1,WRK2,WRK4
  1247. C
  1248.       DO 3087 IB=1,NBELEM
  1249. C
  1250. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1251. C
  1252.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1253. C
  1254.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1255. C
  1256. C     ON CHERCHE LES DEPLACEMENTS
  1257. C
  1258.          MPTVAL=IVADEP
  1259.          IE=1
  1260.          DO      IGAU=1,NBNN
  1261.             DO      ICOMP=1,NDEP
  1262.                MELVAL=IVAL(ICOMP)
  1263.                IGMN=MIN(IGAU,VELCHE(/1))
  1264.                IBMN=MIN(IB  ,VELCHE(/2))
  1265.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1266.                IE=IE+1
  1267.             enddo
  1268.          enddo
  1269. C
  1270. C     BOUCLE SUR LES POINTS DE GAUSS
  1271. C
  1272.          DO 4087 IGAU=1,NBPGAU
  1273. C
  1274.             CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1275.      .                                       BGENE,DJAC,IRRT)
  1276. C           IRRT.NE.0 JACOBIEN <= 0
  1277.             IF (IRRT.NE.0) THEN
  1278.               INTERR(1)=IB
  1279.               CALL ERREUR(611)
  1280.               GOTO 9987
  1281.             ENDIF
  1282. C
  1283.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1284. C
  1285. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1286. C
  1287.             MPTVAL=IVAEPS
  1288.             DO 9087 ICOMP=1,NSTRS
  1289.                MELVAL=IVAL(ICOMP)
  1290.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1291.  9087       CONTINUE
  1292.  4087    CONTINUE
  1293.  3087 CONTINUE
  1294. C
  1295.  9987 CONTINUE
  1296.       SEGSUP WRK1,WRK2,WRK4
  1297.       GOTO 510
  1298. C_______________________________________________________________________
  1299. C
  1300. C     ELEMENT JOINT (JOI4)
  1301. C_______________________________________________________________________
  1302. C
  1303.    88 CONTINUE
  1304.       NBNO=NBNN
  1305.       SEGINI WRK1,WRK2,WRK4
  1306. C
  1307.       DO 3088 IB=1,NBELEM
  1308. C
  1309. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1310. C
  1311.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1312. C
  1313.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1314. C
  1315. C     ON CHERCHE LES DEPLACEMENTS
  1316. C
  1317.          MPTVAL=IVADEP
  1318.          IE=1
  1319.          DO      IGAU=1,NBNN
  1320.             DO      ICOMP=1,NDEP
  1321.                MELVAL=IVAL(ICOMP)
  1322.                IGMN=MIN(IGAU,VELCHE(/1))
  1323.                IBMN=MIN(IB  ,VELCHE(/2))
  1324.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1325.                IE=IE+1
  1326.             enddo
  1327.          enddo
  1328. C
  1329. C     BOUCLE SUR LES POINTS DE GAUSS
  1330. C
  1331.          DO 4088 IGAU=1,NBPGAU
  1332. C
  1333.             CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1334. C           IRRT.NE.0 JACOBIEN <= 0
  1335.             IF (IRRT.NE.0) THEN
  1336.               INTERR(1)=IB
  1337.               CALL ERREUR(611)
  1338.               GOTO 9988
  1339.             ENDIF
  1340. C
  1341.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1342. C
  1343. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1344. C
  1345.             MPTVAL=IVAEPS
  1346.             DO 9088 ICOMP=1,NSTRS
  1347.                MELVAL=IVAL(ICOMP)
  1348.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  1349.  9088       CONTINUE
  1350.  4088    CONTINUE
  1351.  3088 CONTINUE
  1352. C
  1353.  9988 CONTINUE
  1354.       SEGSUP WRK1,WRK2,WRK4
  1355.       GOTO 510
  1356. C_______________________________________________________________________
  1357. C
  1358. C     ELEMENT DST
  1359. C_______________________________________________________________________
  1360. C
  1361.   93  CONTINUE
  1362.       NBNO=NBNN
  1363.       NV1=NMATT
  1364.       SEGINI WRK1,WRK2,WRK3,WRK4,MVELCH
  1365.       IF(CMATE.NE.'ISOTROPE')THEN
  1366.          MPTVAL=IVAMAT
  1367.          IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN
  1368.             MELVAL=IVAL(7)
  1369.          ELSE
  1370.             MELVAL=IVAL(2)
  1371.          ENDIF
  1372.          NBGCOS=VELCHE(/1)
  1373.       ENDIF
  1374.       IRTD = 1
  1375.       DO 3093  IB=1,NBELEM
  1376. C
  1377. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1378. C
  1379.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1380. C
  1381. C     ON CHERCHE LES DEPLACEMENTS
  1382. C
  1383.          MPTVAL=IVADEP
  1384.          IE=1
  1385.          DO      IGAU=1,NBNN
  1386.             DO      ICOMP=1,NDEP
  1387.                MELVAL=IVAL(ICOMP)
  1388.                IGMN=MIN(IGAU,VELCHE(/1))
  1389.                IBMN=MIN(IB  ,VELCHE(/2))
  1390.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1391.                IE=IE+1
  1392.             enddo
  1393.          enddo
  1394.          CALL VPAST(XE,BPSS)
  1395. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  1396.          CALL VCORLC (XE,XEL,BPSS)
  1397.          CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  1398. C
  1399. C     ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  1400. C                LES EXCENTREMENTS ET ON LES MOYENNE.
  1401. C
  1402.         MPTVAL=IVACAR
  1403.         EPAIST=0.D0
  1404.         MELVAL=IVAL(1)
  1405.         IF (MELVAL.NE.0) THEN
  1406.            IBMN=MIN(IB,VELCHE(/2))
  1407.         DO IGAU=1,NBPGAU
  1408.            IGMN=MIN(IGAU,VELCHE(/1))
  1409.            EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  1410.         ENDDO
  1411.         EPAIST=EPAIST/NBPGAU
  1412.         ENDIF
  1413. C
  1414.         EXCEN=0.D0
  1415.         MELVAL=IVAL(2)
  1416.         IF (MELVAL.NE.0) THEN
  1417.            IBMN=MIN(IB,VELCHE(/2))
  1418.         DO IGAU=1,NBPGAU
  1419.            IGMN=MIN(IGAU,VELCHE(/1))
  1420.            EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  1421.         ENDDO
  1422.         EXCEN=EXCEN/NBPGAU
  1423.         ENDIF
  1424. C
  1425. C     BOUCLE SUR LES POINTS DE GAUSS
  1426. C
  1427.          DO 5093  IGAU=1,NBPTEL
  1428. C
  1429. C Dans le cas des matériaux orthotropes, les déformations sont d'abord
  1430. C calculées dans le repère d'orthotropie (les formules utilisées par les
  1431. C routines RCDST et BMFDST ne sont valables que dans ce repère); elles
  1432. C sont ensuite exprimées dans le repère local de l'élément.
  1433. C
  1434. C     ON CHERCHE LA MATRICE DE HOOKE
  1435. C
  1436.       MPTVAL=IVAMAT
  1437.       IF(IMAT.EQ.2) THEN
  1438.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  1439.           MELVAL=IVAL(1)
  1440.           IBMN=MIN(IB  ,IELCHE(/2))
  1441.           IGMN=MIN(IGAU,IELCHE(/1))
  1442.           MLREEL=IELCHE(IGMN,IBMN)
  1443.           SEGACT MLREEL
  1444.           CALL DOHOOO(PROG,LHOOK,DDHOMU)
  1445.           SEGDES MLREEL
  1446.         ENDIF
  1447.       ELSE IF (IMAT.EQ.1) THEN
  1448.           DO 9193 IM=1,NMATT
  1449.             MELVAL=IVAL(IM)
  1450.             IF (MELVAL.NE.0) THEN
  1451.               IBMN=MIN(IB  ,VELCHE(/2))
  1452.               IGMN=MIN(IGAU,VELCHE(/1))
  1453.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  1454.             ELSE
  1455.               VALMAT(IM)=0.D0
  1456.             ENDIF
  1457.  9193     CONTINUE
  1458.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1459.      1     CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD)
  1460.         CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  1461.       ENDIF
  1462.       CALL ZERO(BGENE,NSTRS,LRE)
  1463.       IF(CMATE.NE.'ISOTROPE')THEN
  1464.         IF(IGAU.LE.NBGCOS)THEN
  1465.           IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN
  1466.             COSA=VALMAT(7)
  1467.             SINA=VALMAT(8)
  1468.           ELSE
  1469.             MPTVAL=IVAMAT
  1470.             MELVAL=IVAL(2)
  1471.             IBMN=MIN(IB  ,VELCHE(/2))
  1472.             IGMN=MIN(IGAU,VELCHE(/1))
  1473.             COSA=VELCHE(IGMN,IBMN)
  1474.             MELVAL=IVAL(3)
  1475.             IBMN=MIN(IB  ,VELCHE(/2))
  1476.             IGMN=MIN(IGAU,VELCHE(/1))
  1477.             SINA=VELCHE(IGMN,IBMN)
  1478.           ENDIF
  1479.           DO 1393 INO=1,NBNN
  1480.            XX=COSA*XEL(1,INO)+SINA*XEL(2,INO)
  1481.            YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO)
  1482.            XE(1,INO)=XX
  1483.            XE(2,INO)=YY
  1484.  1393     CONTINUE
  1485.         ENDIF
  1486. C
  1487. C     TERMES DE LA MATRICE DE RIGIDITE RELATIFS
  1488. C      AUX CISAILLEMENTS TRANSVERSES
  1489. C
  1490.         CALL RCDST(XE,NSTRS,LRE,DDHOMU,
  1491.      1                WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1492. C
  1493. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1494. C        DE MEMBRANE ET DE FLEXION
  1495. C
  1496.          CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1497.      1            WORK(1),WORK(10),WORK(19),BGENE,DUM)
  1498. C
  1499.          CALL ROTB(BGENE,NSTRS,COSA,SINA)
  1500.       ELSE
  1501. C
  1502. C     TERMES DE LA MATRICE B RELATIFS AUX CISAILLEMENTS TRANSVERSES
  1503. C
  1504.         CALL RCDST(XEL,NSTRS,LRE,DDHOMU,
  1505.      1          WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1506. C
  1507. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1508. C        DE MEMBRANE ET DE FLEXION
  1509. C
  1510.         CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1511.      1            WORK(1),WORK(10),WORK(19),BGENE,DJAC)
  1512.       ENDIF
  1513. C
  1514. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  1515. C
  1516.           IF (EXCEN.NE.0.) THEN
  1517.             DO      IJL=1,3
  1518.                DO      IJC=1,LRE
  1519.                   BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  1520.                enddo
  1521.             enddo
  1522.           ENDIF
  1523. C
  1524.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  1525. C
  1526. C     CALCUL DES EPS 2
  1527. C
  1528.          IF(IREPS2.EQ.1)THEN
  1529.            IF(CMATE.EQ.'ORTHOTRO')THEN
  1530.              CALL BDST2(XE,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS)
  1531.             ELSE
  1532.              CALL BDST2(XEL,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS)
  1533.             ENDIF
  1534.          ENDIF
  1535. C
  1536. C    CHANGEMENT DE REPERE: ORTHO -> LOCAL
  1537. C
  1538.          IF(CMATE.EQ.'ORTHOTRO')
  1539.      1          CALL CHGREP2(COSA,SINA,XSTRS,0,0)
  1540. C
  1541. C     RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1542. C
  1543.             MPTVAL=IVAEPS
  1544.             DO 9093 ICOMP=1,NSTRS
  1545.                MELVAL=IVAL(ICOMP)
  1546.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  1547.  9093       CONTINUE
  1548.  5093    CONTINUE
  1549.  3093 CONTINUE
  1550.  
  1551. C     ERREUR LE MATERIAU PAS ENCORE IMPLEMENTER POUR
  1552. C     LA FORMULATION MFR ET L OPTION IFOUR
  1553.       IF (IRTD.EQ.0) THEN
  1554.          MOTERR(1:8)=CMATE
  1555.          MOTERR(9:12)=NOMFR(MFR/2+1)
  1556.          INTERR(1)=IFOUR
  1557.          CALL ERREUR(81)
  1558.       ENDIF
  1559.  
  1560.       SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH
  1561.       GOTO 510
  1562. C____________________________________________________________________
  1563.    99 CONTINUE
  1564.       MOTERR(1:4)=NOMTP(MELE)
  1565.       MOTERR(9:12)='EPSI'
  1566.       CALL ERREUR(86)
  1567.  
  1568.   510 CONTINUE
  1569.       RETURN
  1570.       END
  1571.  
  1572.  
  1573.  

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