Télécharger la plaquette Cast3M


fr en

Télécharger rigi4.eso

Retour à la liste

Numérotation des lignes : 

rigi4

  1. C RIGI4     SOURCE    CB215821  24/04/12    21:17:10     11897          
  2.       SUBROUTINE RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3.      &     IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,
  4.      &       NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG)
  5. *---------------------------------------------------------------------*
  6. *         ________________________                                    *
  7. *        |                        |                                   *
  8. *        |  CALCUL DE LA RIGIDITE |                                   *
  9. *        |________________________|                                   *
  10. *                                                                     *
  11. * poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joint 3D,   *
  12. * cerce, tuyo,joints 2D, litu,zone cohesives                          *
  13. *                                                                     *
  14. *---------------------------------------------------------------------*
  15. *                                                                     *
  16. *                                                                     *
  17. *   ENTREES :                                                         *
  18. *   ________                                                          *
  19. *                                                                     *
  20. *        MATE     Numero du materiau                                  *
  21. *        MELE     Numero de l'element fini                            *
  22. *        IPMAIL   Pointeur sur un segment  MELEME                     *
  23. *        IPMINT   Pointeur sur un segment MINTE                       *
  24. *        NBPGAU   Nombre de point d'integration pour la rigidite      *
  25. *        LRE      Nombre de ddl dans la matrice de rigidite           *
  26. *        NSTRS    Nombre de composante de contraintes/deformations    *
  27. *        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  28. *                 pour une matrice de hooke                           *
  29. *        IVACAR   Pointeur sur un segment MPTVAL pour les caracteri-  *
  30. *                 stiques                                             *
  31. *        IVECT    FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL       *
  32. *        CMATE    Nom du materiau                                     *
  33. *        MFR      Numero de la formulation element fini               *
  34. *        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  35. *        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  36. *        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  37. *        NMATT    Nombre de composantes de materiau (IMAT=1)          *
  38. *        NCARR    Nombre de caracteristiques geometriques             *
  39. *        ISOUS    NUMERO DE LA SOUS-ZONE                              *
  40. *        LW       Dimension du tableau de travail                     *
  41. *        IPORE    nombre de fonctions de forme
  42. *                                                                     *
  43. *                                                                     *
  44. *   SORTIES :                                                         *
  45. *   ________                                                          *
  46. *                                                                     *
  47. *        IPMATR   pointeur sur la rigidite de la sous-zone            *
  48. *                                                                     *
  49. *                                                                     *
  50. *---------------------------------------------------------------------*
  51.       IMPLICIT INTEGER(I-N)
  52.       IMPLICIT REAL*8(A-H,O-Z)
  53. *
  54.  
  55. -INC PPARAM
  56. -INC CCOPTIO
  57. -INC CCHAMP
  58. -INC CCREEL
  59. *-
  60. -INC SMCHAML
  61. -INC SMINTE
  62. -INC SMELEME
  63. -INC SMRIGID
  64. -INC SMMODEL
  65. -INC SMCOORD
  66. -INC SMLREEL
  67. -INC SMLMOTS
  68. *
  69.       SEGMENT WRK1
  70.        REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS)
  71.        REAL*8 REL(LRE,LRE) , XE(3,NBBB)
  72.       ENDSEGMENT
  73. *
  74.       SEGMENT WRK2
  75.        REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
  76.       ENDSEGMENT
  77. *
  78.       SEGMENT WRK3
  79.        REAL*8 WORK(LW)
  80.       ENDSEGMENT
  81. *
  82.       SEGMENT WRK4
  83. c cccccc
  84.        REAL*8 BPSS(3,3),XEL(3,NBBB),rell(lre,lre),XPA(IDIM,IDIM)
  85.        REAL*8 XPB(IDIM,IDIM)
  86. c cccccc
  87.       ENDSEGMENT
  88. *
  89.       SEGMENT WRK5
  90.        REAL*8 XGENE(NSTN,LRN)
  91.       ENDSEGMENT
  92. *
  93.       SEGMENT WRK6
  94.        REAL*8 PSS(3,3)
  95.       ENDSEGMENT
  96. *
  97.        SEGMENT WRK7
  98.         REAL*8 PROPEL(14)
  99.         REAL*8 OUT(5)
  100.         REAL*8 WORK1(24*24)
  101.        ENDSEGMENT
  102. *
  103.       SEGMENT,MVELCH
  104.          REAL*8 VALMAT(NV1)
  105.       ENDSEGMENT
  106. *
  107.       SEGMENT MPTVAL
  108.         INTEGER IPOS(NS)    ,NSOF(NS)
  109.         INTEGER      IVAL(NCOSOU)
  110.         CHARACTER*16 TYVAL(NCOSOU)
  111.       ENDSEGMENT
  112. *
  113.       CHARACTER*4 lesinc(7),lesdua(7)
  114.       DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  115.       DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  116.       DATA X577/.577350269189626D0/
  117.       DIMENSION CRIGI(12),CMASS(12)
  118.       CHARACTER*8 CMATE
  119. *
  120.       MELEME=IPMAIL
  121.       NBNN=NUM(/1)
  122.       NBELEM=NUM(/2)
  123. *
  124.       NV1=NMATT
  125.       SEGINI,MVELCH
  126. *
  127.       XMATRI=IPMATR
  128. *      NLIGRP=LRE
  129. *      NLIGRD=LRE
  130.  
  131. C  Introduction du point autour duquel se fait le mouvement
  132. C  de la section en defo plane generalisee
  133. C  IIPDPG = numero du noeud/point support si defini pour le modele
  134. C  IIPDPG > 0 si prise en compte du point support
  135.       IF (IIPDPG.GT.0) THEN
  136. C <- Ici test equivalent a IF (IFOUR.EQ.-3)THEN
  137. c        segact,mcoord
  138.         IREF=(IIPDPG-1)*(IDIM+1)
  139.         XDPGE=XCOOR(IREF+1)
  140.         YDPGE=XCOOR(IREF+2)
  141.       ELSE
  142.         XDPGE=0.D0
  143.         YDPGE=0.D0
  144.       ENDIF
  145. *
  146.       NHRM=NIFOUR
  147. *
  148.       MINTE=IPMINT
  149.       IRTD=1
  150. *
  151. *
  152. * cas cmate 'STATIQUE'
  153.       IF (mfr.eq.28) THEN
  154.       jgn = 4
  155.        if (ifour.eq.2) then
  156.       jgm = 6
  157.       segini mlmots
  158.       iinc = mlmots
  159.       do igm = 1,jgm
  160.        mots(igm) = lesinc(igm)
  161.       enddo
  162.       segini mlmots
  163.       idua = mlmots
  164.       do igm= 1,jgm
  165.        mots(igm) = lesdua(igm)
  166.       enddo
  167.        else if (ifour.lt.0) then
  168.       jgm = 4
  169.       segini mlmots
  170.       iinc = mlmots
  171.        mots(1) = lesinc(1)
  172.        mots(2) = lesinc(2)
  173.        mots(3) = lesinc(4)
  174.        mots(4) = lesinc(5)
  175.       segini mlmots
  176.       idua = mlmots
  177.        mots(1) = lesdua(1)
  178.        mots(2) = lesdua(2)
  179.        mots(3) = lesdua(4)
  180.        mots(4) = lesdua(5)
  181.        else if (ifour.eq.0) then
  182.       jgm = 3
  183.       segini mlmots
  184.       iinc = mlmots
  185.        mots(1) = lesinc(7)
  186.        mots(2) = lesinc(3)
  187.        mots(3) = lesinc(6)
  188.       segini mlmots
  189.       idua = mlmots
  190.        mots(1) = lesdua(7)
  191.        mots(2) = lesdua(3)
  192.        mots(3) = lesdua(6)
  193.        else if (ifour.eq.1) then
  194. * a faire
  195.        endif
  196.       ENDIF
  197.  
  198.  
  199. C
  200. C_______________________________________________________________________
  201. C
  202. C     NUMERO DES ETIQUETTES      :
  203. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  204. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  205. C     5  CONTINUE
  206. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  207. C     44 CONTINUE
  208. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  209. C_______________________________________________________________________
  210. C
  211.             IF (MELE.LE.100)
  212. *                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  213.      &      GOTO (  99,  2,  99,  99,  99,  99,  99,  99,  99,  99,  99
  214. *                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  215.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  216. *                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
  217.      &           ,  99,  99,  99,  99,  99,  99,  29,  30,  99,  99,  99
  218. *                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  219.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  29,  43,  99
  220. *                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  221.      &           ,  45,  46,  99,  99,  99,  30,  99,  99,  99,  99,  99
  222. *                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  223.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  224. *                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  225.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  226. *                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  227.      &           ,  99,  99,  99,  99,  99,  99,  29,  85,  86,  87,  88
  228. *                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
  229.      &           ,  99,  99,  99,  92,  99,  99,  46,  96,  29,  29,  99
  230. *                 HYQ4
  231.      &           ,  99),MELE
  232.             IF (MELE.LE.200)
  233. *                 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  234.      &      GOTO (  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  235. *                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  236.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  237. *                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  238.      &           ,  99,  46, 124, 125, 126, 127,  99,  99,  99,  99,  99
  239. *                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  240.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  241. *                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  242.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  243. *                 TE56 PY91 TRH6 ???? ???? ???? ???? ???? ???? ???? ????
  244.      &           ,  99,  99,  92,  51,  51,  51,  51,  51,  51,  51,  51
  245. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  246.      &           ,  51, 168, 169, 170, 171, 172,  51,  51,  51,  51,  51
  247. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  248.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  249. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  250.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  251. *                 ???? ????
  252.      &           ,  51,  51),MELE-100
  253.             IF (MELE.LE.300)
  254. *                 ???? ???? ???? ???? ???? ???? ???? ???? ????
  255.      &      GOTO (  51,  51,  51,  51,  51,  51,  51,  51,  51
  256. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  257.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  258. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  259.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  260. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  261.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  262. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  263.      &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
  264. *                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  265.      &           ,  51,  51,  51,  51, 258,  51, 260,  51,  51,  51,  51
  266. *                 JOI1 ZCO2 ZCO3 ZCO4
  267. c cccccc
  268.      &           , 129, 266, 266, 266,  51,51,271,272),MELE-200
  269. c cccccc
  270.  51   CONTINUE
  271.            GOTO 99
  272.  
  273.   2   CONTINUE
  274.       if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
  275.      &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL')  then
  276.         MPTVAL=IVAMAT
  277.         MELVAL=IVAL(1)
  278.         if (ival(/1).gt.1) then
  279.           melva1 = ival(2)
  280.         else
  281.           melva1 = 0
  282.         endif
  283.         jddl = LRE/NBPGAU
  284.         DO IB = 1,NBELEM
  285. * kich 1 pgau inutile
  286.           IGAU = 1
  287.           JDIAG = 0
  288.           IBMN=MIN(IB,VELCHE(/2))
  289.               IGMN=MIN(IGAU,VELCHE(/1))
  290.             if (cmate.eq.'IMPCOMPL') then
  291.              MLREEL=IELCHE(IGMN,IBMN)
  292.              SEGACT MLREEL
  293.              XRAID = prog(1)
  294.             else
  295.               XRAID = VELCHE(IGMN,IBMN)
  296.               XTORS = XRAID
  297.               if (melva1.gt.0) then
  298.                 XTORS = melva1.VELCHE(IGMN,IBMN)
  299.               endif
  300.             endif
  301.            do j=1,jddl
  302.             JDIAG = JDIAG + 1
  303.             if (j.le.3) then
  304.              RE(JDIAG,JDIAG,IB) = XRAID
  305.              RE(JDIAG,JDIAG+jddl,IB) = XRAID*(-1.D0)
  306.             else
  307.              RE(JDIAG,JDIAG,IB) = XTORS
  308.              RE(JDIAG,JDIAG+jddl,IB) = XTORS*(-1.D0)
  309.             endif
  310.            enddo
  311.            do j=jddl+1,LRE
  312.             JDIAG = JDIAG + 1
  313.             if (j.le.jddl+3) then
  314.              RE(JDIAG,JDIAG,IB) = XRAID
  315.              RE(JDIAG,JDIAG-jddl,IB) = XRAID*(-1.D0)
  316.             else
  317.              RE(JDIAG,JDIAG,IB) = XTORS
  318.              RE(JDIAG,JDIAG-jddl,IB) = XTORS*(-1.D0)
  319.             endif
  320.            enddo
  321.         ENDDO
  322.         SEGDES XMATRI
  323.        goto 510
  324.       endif
  325.       if (mele.eq.2) goto 99
  326.  
  327. C_______________________________________________________________________
  328. C
  329. C     ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO
  330. C_______________________________________________________________________
  331. C
  332.  
  333.   29  CONTINUE
  334.  
  335.       NBBB=NBNN
  336.       SEGINI WRK1,WRK3
  337. C
  338. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  339. C
  340.       KERRE=0
  341.       DO  3029 IB=1,NBELEM
  342. C
  343. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  344. C
  345.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  346. C
  347. C     CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
  348. C
  349.       IF (MELE.EQ.98) THEN
  350.          CALL ZERO(REL,LRE,LRE)
  351.          GOTO 8029
  352.       ENDIF
  353. C
  354. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  355. C     SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  356. C
  357.       NCARR1=NCARR
  358. **    IF(IVECT.EQ.1) NCARR1=NCARR-3
  359.       CALL ZERO(WORK,NCARR1,1)
  360.       DO 4030 IGAU=1,NBNN
  361.       MPTVAL=IVACAR
  362.       DO 6029 IC=1,NCARR1
  363.         IF (IVAL(IC).NE.0) THEN
  364.           MELVAL=IVAL(IC)
  365.           IBMN=MIN(IB,VELCHE(/2))
  366.           IGMN=MIN(IGAU,VELCHE(/1))
  367.           WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  368.         ELSE
  369.           WORK(IC)=0.D0
  370.         ENDIF
  371.         IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  372.  6029 CONTINUE
  373.  4030    CONTINUE
  374. C
  375.       MPTVAL=IVAMAT
  376. C
  377. C CAS DE L'ACOUSTIQUE PURE
  378. C
  379.       IF (MELE.EQ.97) THEN
  380.          DO 7029 IM=1,NMATT
  381.            IF (IVAL(IM).NE.0) THEN
  382.              MELVAL=IVAL(IM)
  383.              IBMN=MIN(IB,VELCHE(/2))
  384.              WORK(IM+9)=VELCHE(1,IBMN)
  385.            ELSE
  386.              WORK(IM+9)=0.D0
  387.            ENDIF
  388.  7029    CONTINUE
  389.       ELSE
  390. C
  391. C AUTRES CAS ......
  392. C
  393.         MELVAL=IVAL(1)
  394. *
  395.         IF(CMATE.NE.'SECTION') THEN
  396.  
  397. *   ON RECUPERE LE MODULE D'YOUNG SI IMAT = 1
  398.  
  399.           IF(IMAT.EQ.1) THEN
  400.              IBMN=MIN(IB,VELCHE(/2))
  401.              VALMAT(1)=VELCHE(1,IBMN)
  402.              YOUNG=VALMAT(1)
  403. C
  404. C     ON CHERCHE LES COEFF DES MAT DE HOOKE  SI IMAT = 2
  405. C
  406.           ELSE IF(IMAT.EQ.2) THEN
  407.             MELVAL=IVAL(1)
  408.             IBMN=MIN(IB,IELCHE(/2))
  409.             MLREEL=IELCHE(1,IBMN)
  410.             SEGACT MLREEL
  411.             IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  412.      $       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  413.             SEGDES MLREEL
  414. *
  415.             IF(MELE.EQ.42) THEN
  416.               EPAIS=WORK(1)
  417.               REXT=WORK(2)
  418.               RINT=REXT-EPAIS
  419.               SD =XPI*(REXT**2-RINT**2)
  420.               YOUNG = DDHOOK(1,1)/SD
  421.             ENDIF
  422.           ENDIF
  423. C
  424. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  425. C                   EQUIVALENTE
  426.           IF(MELE.EQ.42) THEN
  427.             PRES=WORK(4)
  428.             CISA=WORK(5)
  429. **          write(6,*) 'tuykar ncarr',ncarr,
  430. **   >            work(6),work(7),work(8),work(9),work(10)
  431.             WORK(4)=WORK(6)
  432.             WORK(5)=WORK(7)
  433.             WORK(6)=WORK(8)
  434.             WORK(7)=PRES
  435.             WORK(8)=CISA
  436.             CALL TUYKAR(WORK,KERRE,2,YOUNG)
  437.           ENDIF
  438.           IF (KERRE.EQ.77) THEN
  439.             CALL ERREUR(77)
  440.             GOTO 510
  441.           ENDIF
  442.  
  443. C-------------
  444. C  PROVISOIRE
  445. C-------------
  446.           IF(IMAT.EQ.2) THEN
  447.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  448.              WORK(4)=DDHOOK(1,1)/WORK(1)
  449.              WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1)))
  450.            ELSE
  451. *
  452. *ZZZZ  ATTENTION A LA DIVISION PAR 0.
  453. *
  454.             WORK(10)=DDHOOK(1,1)/WORK(4)
  455. *
  456.             IF(ABS(WORK(5)).LT.XPETIT/XZPREC) THEN
  457.              IF(ABS(DDHOOK(2,2)).GE.XPETIT/XZPREC) then
  458.                MOTERR(1:4)='SECY'
  459.                CALL ERREUR(46)
  460.                RETURN
  461.              ELSE
  462.                work(11)=0.d0
  463.              ENDIF
  464.             Else
  465.              WORK(11)=DDHOOK(2,2)/WORK(5)
  466.             ENDIF
  467.            ENDIF
  468.           ELSE IF (IMAT.EQ.1) THEN
  469. *
  470.             DO 9029 IM=1,NMATT
  471.               IF (IVAL(IM).NE.0) THEN
  472.                 MELVAL=IVAL(IM)
  473.                 IBMN=MIN(IB,VELCHE(/2))
  474.                 VALMAT(IM)=VELCHE(1,IBMN)
  475.               ELSE
  476.                 VALMAT(IM)=0.D0
  477.               ENDIF
  478.  9029       CONTINUE
  479.             IF(MELE.EQ.84) THEN
  480.              IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  481.               CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  482.              ELSE
  483. C
  484.               CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  485.              ENDIF
  486.             ELSE
  487.               IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  488.                CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  489.               ELSE
  490.                CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  491.               ENDIF
  492.             ENDIF
  493. C-------------
  494. C  PROVISOIRE
  495. C-------------
  496.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  497.               WORK(4)=VALMAT(1)
  498.               AUX=VALMAT(2)
  499.               WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  500.             ELSE
  501. C
  502.               WORK(10)=VALMAT(1)
  503.               AUX=VALMAT(2)
  504.               WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  505.             ENDIF
  506. C-------------
  507.           ENDIF
  508. *
  509. *  CAS DE LA FORMULATION SECTION
  510. *
  511.         ELSE
  512.           IF(IMAT.EQ.2) THEN
  513.             MELVAL=IVAL(1)
  514.             IBMN=MIN(IB,IELCHE(/2))
  515.             MLREEL=IELCHE(1,IBMN)
  516.             SEGACT MLREEL
  517.             IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  518.      $        CALL DOHOOO(PROG,LHOOK,DDHOOK)
  519.             SEGDES MLREEL
  520. C
  521.           ELSE IF (IMAT.EQ.1) THEN
  522. *
  523. *         ON REGARDE SI ON A LA COMPOSANTE MAHO
  524. *         SI OUI, ON LA PREND
  525. *
  526.             IF(IVAL(3).NE.0) THEN
  527.               MELVAL=IVAL(3)
  528.               IBMN=MIN(IB,IELCHE(/2))
  529.               MLREEL=IELCHE(1,IBMN)
  530.               SEGACT MLREEL
  531.               IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  532.      $          CALL DOHOOO(PROG,LHOOK,DDHOOK)
  533.               SEGDES MLREEL
  534. *
  535.             ELSE
  536.               IBMN=MIN(IB,IELCHE(/2))
  537.               IPMODL=IELCHE(1,IBMN)
  538.               MELVAL=IVAL(2)
  539.               IBMN=MIN(IB,IELCHE(/2))
  540.               IPMAT=IELCHE(1,IBMN)
  541.               CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  542.               IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  543.      $         CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  544.             ENDIF
  545.           ENDIF
  546.         ENDIF
  547.       ENDIF
  548. C
  549. C FIN TRAITEMENT DES DONNEES MATERIAUX
  550. C
  551.       IF(MELE.EQ.97) THEN
  552.          CALL ACORIG(REL,LRE,WORK,XE,KERRE)
  553.       ELSE IF(MELE.EQ.84) THEN
  554.          IF(CMATE.NE.'SECTION') THEN
  555.  
  556.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  557.              CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  558.            ELSE
  559.              CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  560.            ENDIF
  561. *
  562.          ELSE
  563.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  564.              CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
  565.      $                                      DDHOOK,KERRE)
  566.            ELSE
  567.              CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
  568.      $                                      DDHOOK,KERRE)
  569.            ENDIF
  570.          ENDIF
  571.       ELSE
  572.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  573.              CALL POURH2(REL,LRE,WORK,XE,WORK(12),IMAT,
  574.      &       LHOOK, DDHOOK, KERRE)
  575.            ELSE
  576.              CALL POURHG(REL,LRE,WORK,XE,WORK(12),IMAT,
  577.      &       LHOOK, DDHOOK, KERRE)
  578.            ENDIF
  579.       ENDIF
  580. C
  581.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  582.       IF(KERRE.NE.0) INTERR(2)=IB
  583. C
  584.  4029 CONTINUE
  585.  8029 CONTINUE
  586. *      SEGINI XMATRI
  587. *      IMATTT(IB)=XMATRI
  588. C
  589. C     REMPLISSAGE DE XMATRI
  590. C
  591.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  592. *      SEGDES XMATRI
  593.  3029 CONTINUE
  594.       IF(KERRE.EQ.1) CALL ERREUR(128)
  595.       IF(KERRE.EQ.2) CALL ERREUR(138)
  596.       IF(IRTD.EQ.0) THEN
  597.         MOTERR(1:8)=CMATE
  598.         MOTERR(9:16)=NOMFR(MFR/2+1)
  599.        INTERR(1)=IFOUR
  600.        CALL ERREUR(81)
  601.        return
  602.       ENDIF
  603.       SEGDES XMATRI
  604.       SEGSUP WRK1,WRK3,MVELCH
  605.       GOTO 510
  606. C_______________________________________________________________________
  607. C
  608. C     ELEMENTS LINESPRING LISP ET LISM
  609. C_______________________________________________________________________
  610. C
  611.   30  CONTINUE
  612.       NBBB=NBNN
  613.       NSTRS=2
  614.       SEGINI WRK1,WRK3
  615. C
  616. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  617. C
  618.       DO 3030 IB=1,NBELEM
  619. C
  620. C     ON CHRCHE LES COORDONNEES DES NOEUDS
  621. C
  622.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  623. C
  624. C     ON CHERCHE LES COEFFS DE LA MATRICE DE HOOKE
  625. C
  626.       MPTVAL=IVAMAT
  627.       IF(IMAT.EQ.2) THEN
  628.         MELVAL=IVAL(1)
  629.         IBMN=MIN(IB  ,IELCHE(/2))
  630.         MLREEL=IELCHE(1,IBMN)
  631.         SEGACT MLREEL
  632.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  633.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  634.         SEGDES MLREEL
  635.       ELSE IF (IMAT.EQ.1) THEN
  636. *
  637.         DO 9030 IM=1,NMATT
  638.           IF (IVAL(IM).NE.0) THEN
  639.             MELVAL=IVAL(IM)
  640.             IBMN=MIN(IB  ,VELCHE(/2))
  641.             VALMAT(IM)=VELCHE(1,IBMN)
  642.           ELSE
  643.             VALMAT(IM)=0.D0
  644.           ENDIF
  645.  9030   CONTINUE
  646.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  647.      1  CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  648.       ENDIF
  649. C
  650. C     ON CHERCHE LES CARACTERISTIQUES   ON OUBLIE LE 2 IEME POINT DEGAUS
  651. C
  652.       IE=0
  653.       MPTVAL=IVACAR
  654.       DO  IC=1,3,2
  655.         DO  ID=1,NCARR
  656.           IE=IE+1
  657.           MELVAL=IVAL(ID)
  658.           IGMN=MIN(IC,VELCHE(/1))
  659.           IBMN=MIN(IB,VELCHE(/2))
  660.           WORK(IE)=VELCHE(IGMN,IBMN)
  661.         enddo
  662.       enddo
  663. C
  664. C     CALCUL DE LA RIGIDITE
  665. C
  666.       CALL LISPRI(XE,WORK,DDHOOK,WORK(11),MELE,REL,I70,I343,I157,I158)
  667. C     IF(I70.EQ.1)  INTERR(1)=IB
  668.       IF(I158.EQ.1) INTERR(1)=IB
  669.       IF(I343.EQ.1) INTERR(1)=IB
  670. *      SEGINI XMATRI
  671. *      IMATTT(IB)=XMATRI
  672. C
  673. C     REMPLISSAGE DE XMATRI
  674. C
  675.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  676. *      SEGDES XMATRI
  677.  3030 CONTINUE
  678. C     IF(I70.EQ.1)  CALL ERREUR(70)
  679.       IF(I158.EQ.1) CALL ERREUR(158)
  680.       IF(I343.EQ.1) CALL ERREUR(343)
  681.       IF(IRTD.EQ.0) THEN
  682.         MOTERR(1:8)=CMATE
  683.         MOTERR(9:16)=NOMFR(MFR/2+1)
  684.        INTERR(1)=IFOUR
  685.        CALL ERREUR(81)
  686.       ENDIF
  687.       SEGDES XMATRI
  688.       SEGSUP WRK1,WRK3,MVELCH
  689.       GOTO 510
  690. C_______________________________________________________________________
  691. C
  692. C     ELEMENT TUYAU FISSURE
  693. C_______________________________________________________________________
  694. C
  695.   43  CONTINUE
  696.       NBBB=NBNN
  697.       NSTRS=2
  698.       SEGINI WRK1,WRK3
  699. C
  700. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  701. C
  702.       DO  3043 IB=1,NBELEM
  703. C
  704. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  705. C
  706.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  707. C
  708. C
  709. C     ON CHERCHE LES COEFF DES MAT DE HOOKE
  710. C
  711.       MPTVAL=IVAMAT
  712.       IF(IMAT.EQ.2) THEN
  713.         MELVAL=IVAL(1)
  714.         IBMN=MIN(IB  ,IELCHE(/2))
  715.         MLREEL=IELCHE(1,IBMN)
  716.         SEGACT MLREEL
  717.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  718.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  719.         SEGDES MLREEL
  720.       ELSE IF (IMAT.EQ.1) THEN
  721. *
  722.         DO 9043 IM=1,NMATT
  723.           IF (IVAL(IM).NE.0) THEN
  724.             MELVAL=IVAL(IM)
  725.             IBMN=MIN(IB  ,VELCHE(/2))
  726.             VALMAT(IM)=VELCHE(1,IBMN)
  727.           ELSE
  728.             VALMAT(IM)=0.D0
  729.           ENDIF
  730.  9043   CONTINUE
  731.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  732.      1  CALL DOHFIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  733.       ENDIF
  734. C
  735. C     CHERCHER LES CARACTERISTIQUES
  736. C
  737.       MPTVAL=IVACAR
  738.       DO 4043 IC=1,NCARR
  739.         MELVAL=IVAL(IC)
  740.         IBMN=MIN(IB,VELCHE(/2))
  741.         WORK(IC)=VELCHE(1,IBMN)
  742. 4043  CONTINUE
  743. C
  744. C     ON CALCULE SA RAIDEUR
  745. C
  746.       CALL TUFIRI(REL,WORK(1),DDHOOK,I137)
  747.       IF(I137.NE.0) INTERR(1)=ISOUS
  748.       IF(I137.NE.0) INTERR(2)=IB
  749. C
  750. *      SEGINI XMATRI
  751. *      IMATTT(IB)=XMATRI
  752. C
  753. C     REMPLISSAGE DE XMATRI
  754. C
  755.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  756. *      SEGDES XMATRI
  757.  3043 CONTINUE
  758.       IF(I137.EQ.1) CALL ERREUR(137)
  759.       IF(I137.EQ.2) CALL ERREUR(123)
  760.       IF(I137.EQ.3) CALL ERREUR(266)
  761.       IF(IRTD.EQ.0) THEN
  762.         MOTERR(1:8)=CMATE
  763.         MOTERR(9:16)=NOMFR(MFR/2+1)
  764.        INTERR(1)=IFOUR
  765.        CALL ERREUR(81)
  766.       ENDIF
  767.       SEGDES XMATRI
  768.       SEGSUP WRK1,WRK3,MVELCH
  769.       GOTO 510
  770. C_______________________________________________________________________
  771. C
  772. C      ELEMENT POI1
  773. C_______________________________________________________________________
  774. C
  775.   45  CONTINUE
  776.       if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
  777.      &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') then
  778.  
  779.         MPTVAL=IVAMAT
  780.         MELVAL=IVAL(1)
  781.         if (ival(/1).gt.1) then
  782.           melva1 = ival(2)
  783.         else
  784.           melva1 = 0
  785.         endif
  786.         DO IB = 1,NBELEM
  787.           JDIAG = 0
  788. *          SEGINI XMATRI
  789. *          IMATTT(IB)=XMATRI
  790.           IBMN=MIN(IB,VELCHE(/2))
  791.           do igau = 1,NBPGAU
  792.               IGMN=MIN(IGAU,VELCHE(/1))
  793.               XRAID = VELCHE(IGMN,IBMN)
  794.               XTORS = XRAID
  795.               if (melva1.gt.0) then
  796.                 XTORS = melva1.VELCHE(IGMN,IBMN)
  797.               endif
  798.            do j =1,LRE
  799.             JDIAG = JDIAG + 1
  800.             if (j.le.3) then
  801.              RE(JDIAG,JDIAG,IB) = XRAID
  802.             else
  803.              RE(JDIAG,JDIAG,IB) = XTORS
  804.             endif
  805.            enddo
  806.           enddo
  807. *          SEGDES XMATRI
  808.         ENDDO
  809.         SEGDES XMATRI
  810.        goto 510
  811.       endif
  812.  
  813.       IF (CMATE.EQ.'MODAL') THEN
  814. * MODAL
  815.         DO IB = 1,NBELEM
  816.           MPTVAL=IVAMAT
  817.           MELVAL=IVAL(1)
  818.           IBMN=MIN(IB,VELCHE(/2))
  819.           XFREQ=VELCHE(1,IBMN)
  820.           MELVAL=IVAL(2)
  821.           IBMN=MIN(IB,VELCHE(/2))
  822.           XMASS=VELCHE(1,IBMN)
  823.           OMEG = 2. * XPI * XFREQ
  824.           RE(1,1,IB) = XMASS * OMEG * OMEG
  825. cbp-2017-10-02          if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.)
  826.           if (XFREQ.LT.0.D0) RE(1,1,IB) = 0.D0
  827.         ENDDO
  828.         SEGDES XMATRI
  829.         GOTO 510
  830. *
  831.  
  832.       ELSE IF (CMATE.EQ.'STATIQUE') THEN
  833. * STATIQUE
  834.         DO IB = 1,NBELEM
  835.           MPTVAL=IVAMAT
  836.           MELVAL=IVAL(1)
  837.           IBMN=MIN(IB,IELCHE(/2))
  838.           idepl=IELCHE(1,IBMN)
  839.           MELVAL=IVAL(2)
  840.           IBMN=MIN(IB,IELCHE(/2))
  841.           itreac=IELCHE(1,IBMN)
  842.           CALL XTY1(idepl,itreac,iinc,idua,X1)
  843.           if (ierr.ne.0) return
  844.           re(1,1,IB) = x1
  845.         ENDDO
  846.         SEGDES XMATRI
  847.         GOTO 510
  848.       ENDIF
  849. *
  850.       IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  851.         GOTO 99
  852.       ENDIF
  853.       NBBB=NBNN
  854.       SEGINI WRK1,WRK3
  855. C
  856. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  857. C
  858.       KERRE=0
  859.       DO 3045 IB=1,NBELEM
  860. C
  861. C  ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  862. C
  863.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  864. C
  865. C
  866. C  ON RECUPERE LA SECTION DE L'ELEMENT
  867. C
  868.       MPTVAL=IVACAR
  869.       MELVAL=IVAL(1)
  870.       IBMN=MIN(IB,VELCHE(/2))
  871.       SECT=VELCHE(1,IBMN)
  872. C
  873. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  874. C
  875.       MPTVAL=IVAMAT
  876.       IF(IMAT.EQ.2) THEN
  877.         MELVAL=IVAL(1)
  878.         IBMN=MIN(IB  ,IELCHE(/2))
  879.         MLREEL=IELCHE(1,IBMN)
  880.         SEGACT MLREEL
  881.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  882.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  883.         SEGDES MLREEL
  884.       ELSE IF (IMAT.EQ.1) THEN
  885. *
  886.         DO 9045 IM=1,NMATT
  887.           IF (IVAL(IM).NE.0) THEN
  888.             MELVAL=IVAL(IM)
  889.             IBMN=MIN(IB  ,VELCHE(/2))
  890.             VALMAT(IM)=VELCHE(1,IBMN)
  891.           ELSE
  892.             VALMAT(IM)=0.D0
  893.           ENDIF
  894.  9045   CONTINUE
  895.         CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  896.       ENDIF
  897.       CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE)
  898. C
  899. *      SEGINI XMATRI
  900. *      IMATTT(IB)=XMATRI
  901. C
  902. C     REMPLISSAGE DE XMATRI
  903. C
  904.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  905. *      SEGDES XMATRI
  906.  3045 CONTINUE
  907.       IF(IRTD.EQ.0) THEN
  908.         MOTERR(1:8)=CMATE
  909.         MOTERR(9:16)=NOMFR(MFR/2+1)
  910.        INTERR(1)=IFOUR
  911.        CALL ERREUR(81)
  912.       ENDIF
  913.       SEGDES XMATRI
  914.       SEGSUP WRK1,WRK3,MVELCH
  915.       GOTO 510
  916. C_______________________________________________________________________
  917. C
  918. C     ELEMENTS BARRE ET CERCE
  919. C_______________________________________________________________________
  920. C
  921.   46  CONTINUE
  922. *
  923.       IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  924.         GO TO 99
  925.       ENDIF
  926.       NBBB=NBNN
  927.       SEGINI WRK1,WRK3
  928.       IF(MELE.EQ.123) THEN
  929.         NSTN=NBNN
  930.         LRN =LRE
  931.         SEGINI WRK5
  932.       ENDIF
  933. C
  934. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  935. C
  936.       KERRE=0
  937.       DO 3046 IB=1,NBELEM
  938. C
  939. C  ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  940. C
  941.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  942. C
  943. C
  944. C  ON RECUPERE LA SECTION DE L'ELEMENT
  945. C
  946.       MPTVAL=IVACAR
  947.       MELVAL=IVAL(1)
  948.       IBMN=MIN(IB,VELCHE(/2))
  949.       SECT=VELCHE(1,IBMN)
  950. C
  951. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  952. C
  953.       MPTVAL=IVAMAT
  954.       IF(IMAT.EQ.2) THEN
  955.         MELVAL=IVAL(1)
  956.         IBMN=MIN(IB  ,IELCHE(/2))
  957.         MLREEL=IELCHE(1,IBMN)
  958.         SEGACT MLREEL
  959.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  960.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  961.         SEGDES MLREEL
  962.       ELSE IF (IMAT.EQ.1) THEN
  963. *
  964.         DO 9046 IM=1,NMATT
  965.           IF (IVAL(IM).NE.0) THEN
  966.             MELVAL=IVAL(IM)
  967.             IBMN=MIN(IB  ,VELCHE(/2))
  968.             VALMAT(IM)=VELCHE(1,IBMN)
  969.           ELSE
  970.             VALMAT(IM)=0.D0
  971.           ENDIF
  972.  9046   CONTINUE
  973.         CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  974.       ENDIF
  975.       IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  976.       IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  977.       IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  978.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  979.       IF(KERRE.NE.0) INTERR(2)=IB
  980. C
  981. *      SEGINI XMATRI
  982. *      IMATTT(IB)=XMATRI
  983. C
  984. C     REMPLISSAGE DE XMATRI
  985. C
  986.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  987. *      SEGDES XMATRI
  988.  3046 CONTINUE
  989.       IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  990.       IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  991.       IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  992.       IF(IRTD.EQ.0) THEN
  993.         MOTERR(1:8)=CMATE
  994.         MOTERR(9:16)=NOMFR(MFR/2+1)
  995.        INTERR(1)=IFOUR
  996.        CALL ERREUR(81)
  997.       ENDIF
  998.       SEGDES XMATRI
  999.       SEGSUP WRK1,WRK3,MVELCH
  1000.       IF(MELE.EQ.123) SEGSUP WRK5
  1001.       GOTO 510
  1002. C
  1003. C_______________________________________________________________________
  1004. C
  1005. C     ELEMENT BARRE 3D EXCENTRE (BAEX)
  1006. C_______________________________________________________________________
  1007. C
  1008.  124  CONTINUE
  1009.       NBBB=NBNN
  1010.       NBNO=NBNN
  1011.       NSTRS1=NSTRS
  1012.       NSTRS=NBNN
  1013.       SEGINI WRK1,WRK2,WRK3
  1014. C
  1015. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1016. C
  1017.       KERRE=0
  1018.       DO 3108 IB=1,NBELEM
  1019. C
  1020. C  ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  1021. C  ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  1022. C  SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  1023. C
  1024.       MPTVAL=IVACAR
  1025.       DO IC=1,NCARR
  1026.         IF(IVAL(IC).NE.0) THEN
  1027.           MELVAL=IVAL(IC)
  1028.           IBMN=MIN(IB,VELCHE(/2))
  1029.           WORK(IC)=VELCHE(1,IBMN)
  1030.         ELSE
  1031.           WORK(IC)=0.D0
  1032.         ENDIF
  1033.       END DO
  1034.       SECT=WORK(1)
  1035. C
  1036. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  1037. C
  1038.       MPTVAL=IVAMAT
  1039.       IF(IMAT.EQ.2) THEN
  1040.         MELVAL=IVAL(1)
  1041.         IBMN=MIN(IB  ,IELCHE(/2))
  1042.         MLREEL=IELCHE(1,IBMN)
  1043.         SEGACT MLREEL
  1044.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1045.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1046.         SEGDES MLREEL
  1047.       ELSE IF (IMAT.EQ.1) THEN
  1048.         DO 9108 IM=1,NMATT
  1049.           IF (IVAL(IM).NE.0) THEN
  1050.             MELVAL=IVAL(IM)
  1051.             IBMN=MIN(IB  ,VELCHE(/2))
  1052.             VALMAT(IM)=VELCHE(1,IBMN)
  1053.           ELSE
  1054.             VALMAT(IM)=0.D0
  1055.           ENDIF
  1056.  9108   CONTINUE
  1057.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1058.      1  CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  1059.       ENDIF
  1060. C
  1061. C   BGENE  STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  1062. C
  1063.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1064.       CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  1065.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  1066.       IF(KERRE.NE.0) INTERR(2)=IB
  1067.       IF(KERRE.EQ.1) CALL ERREUR(128)
  1068.       CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  1069. C
  1070. *      SEGINI XMATRI
  1071. *      IMATTT(IB)=XMATRI
  1072. C
  1073. C     REMPLISSAGE DE XMATRI
  1074. C
  1075.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  1076. *      SEGDES XMATRI
  1077.  3108 CONTINUE
  1078.       NSTRS=NSTRS1
  1079.       SEGDES XMATRI
  1080.       SEGSUP WRK1,WRK2,WRK3,MVELCH
  1081.       GOTO 510
  1082. C_______________________________________________________________________
  1083. C
  1084. C     LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1085. C_______________________________________________________________________
  1086. C
  1087.  125  CONTINUE
  1088.       NBBB=NBNN
  1089.       NBNO=NBNN
  1090.       SEGINI WRK1,WRK2,WRK3,WRK4
  1091. C
  1092. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1093. C
  1094.       KERRE=0
  1095.       DO  3109 IB=1,NBELEM
  1096. C
  1097.       MPTVAL=IVACAR
  1098.       DO IC=1,NCARR
  1099.         IF(IVAL(IC).NE.0) THEN
  1100.           MELVAL=IVAL(IC)
  1101.           IBMN=MIN(IB,VELCHE(/2))
  1102.           WORK(IC)=VELCHE(1,IBMN)
  1103.         ELSE
  1104.           WORK(IC)=0.D0
  1105.         ENDIF
  1106.       END DO
  1107. C
  1108.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1109.       CALL MAPALI(XE,NBNN,WORK,BPSS,KERRE)
  1110.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  1111.       IF(KERRE.NE.0) INTERR(2)=IB
  1112.       IF(KERRE.EQ.1) CALL ERREUR(128)
  1113.       CALL RIGLI2(REL,LRE,BPSS,WORK)
  1114. C
  1115. *      SEGINI XMATRI
  1116. *      IMATTT(IB)=XMATRI
  1117. C
  1118. C     REMPLISSAGE DE XMATRI
  1119. C
  1120.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  1121. *      SEGDES XMATRI
  1122.  3109 CONTINUE
  1123.       SEGDES XMATRI
  1124.       SEGSUP WRK1,WRK2,WRK3,MVELCH
  1125.       GOTO 510
  1126. *-------------------------------------------------------------
  1127. C_______________________________________________________________________
  1128. C
  1129. C     JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1130. C_______________________________________________________________________
  1131. C
  1132.  129  CONTINUE
  1133.       NBBB=NBNN
  1134.       NBNO=NBNN
  1135.       SEGINI WRK1,WRK2,WRK3,WRK4
  1136. C
  1137. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1138. C
  1139.       KERRE=0
  1140.       DO  3110 IB=1,NBELEM
  1141. C
  1142.         MPTVAL=IVAMAT
  1143.  
  1144.         IF(IMAT.EQ.2) THEN
  1145.  
  1146.           MELVAL=IVAL(1)
  1147.           IBMN=MIN(IB  ,IELCHE(/2))
  1148.           MLREEL=IELCHE(1,IBMN)
  1149.           SEGACT MLREEL
  1150.           IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1151.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1152.           SEGDES MLREEL
  1153.  
  1154.           CALL RIGJOL(REL,LRE,DDHOOK,LHOOK,IDIM)
  1155.  
  1156.           IF(IDIM.EQ.2) THEN
  1157.             NCA=2
  1158.           ELSE
  1159.             NCA=6
  1160.           ENDIF
  1161. *
  1162.           MPTVAL=IVACAR
  1163.           DO IC=1,NCA
  1164.             IF(IVAL(IC).NE.0) THEN
  1165.               MELVAL=IVAL(IC)
  1166.               IBMN=MIN(IB,VELCHE(/2))
  1167.               WORK(IC)=VELCHE(1,IBMN)
  1168.             ELSE
  1169.               WORK(IC)=0.D0
  1170.             ENDIF
  1171.           END DO
  1172.           CALL MAPALU(NCA,WORK,BPSS,IDIM)
  1173.         ELSE
  1174.           DO IC=1,NMATT
  1175.             IF(IVAL(IC).NE.0) THEN
  1176.               MELVAL=IVAL(IC)
  1177.               IBMN=MIN(IB,VELCHE(/2))
  1178.               WORK(IC)=VELCHE(1,IBMN)
  1179.             ELSE
  1180.               WORK(IC)=0.D0
  1181.             ENDIF
  1182.           END DO
  1183. c
  1184. c         on calcule la matrice de rigidité locale
  1185. c
  1186.           CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE)
  1187.           CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1188.       ENDIF
  1189. c
  1190. c        on passe en repère global
  1191. c
  1192.        IAW1=101
  1193.        IAW2=IAW1+LRE*LRE
  1194.        IAW3=IAW2+LRE*LRE
  1195.        IAW4=IAW3+LRE*LRE
  1196.        CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
  1197.      &                 WORK(IAW3),WORK(IAW4),LRE,IDIM)
  1198. *
  1199. C
  1200. *      SEGINI XMATRI
  1201. *      IMATTT(IB)=XMATRI
  1202. C
  1203. C     REMPLISSAGE DE XMATRI
  1204. C
  1205.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  1206. *
  1207. *      SEGDES XMATRI
  1208.  3110 CONTINUE
  1209.       SEGDES XMATRI
  1210.       SEGSUP WRK1,WRK2,WRK3,MVELCH
  1211.       GOTO 510
  1212. *-------------------------------------------------------------
  1213. c
  1214. c    element coaxial COS2 (3D pour liaison acier-beton)
  1215. c
  1216.   271 continue
  1217.       NBBB=NBNN
  1218.       lw=5
  1219.       SEGINI WRK1,WRK4,wrk3
  1220.       do 3271 ib= 1,nbelem
  1221. C
  1222. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1223. C
  1224.  
  1225.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1226.       CALL ZERO (REL,LRE,LRE)
  1227.       CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1228.       MPTVAL=IVAmat
  1229.       if(imat.eq.1) then
  1230.       DO IC=1,2
  1231.         IF(IVAL(IC).NE.0) THEN
  1232.           MELVAL=IVAL(IC)
  1233.           IBMN=MIN(IB,VELCHE(/2))
  1234.           WORK(ic)=VELCHE(1,IBMN)
  1235.         ELSE
  1236.           WORK(IC)=0.D0
  1237.         ENDIF
  1238.       END DO
  1239.       ELSE
  1240.          MELVAL=IVAL(1)
  1241.          IBMN=MIN(IB,IELCHE(/2))
  1242.          MLREEL=IELCHE(1,IBMN)
  1243.          SEGACT MLREEL
  1244.        if(idim.eq.3) then
  1245.          work(1)= prog(1)
  1246.          work(2) = prog(9)
  1247.        else if (idim.eq.1.or.idim.eq.2) then
  1248.           CALL ERREUR(81)
  1249.        endif
  1250.        segdes mlreel
  1251.       endif
  1252. C
  1253. C
  1254. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1255. C
  1256.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1257.          xv1= xe(1,2)-xe(1,1)
  1258.          yv1= xe(2,2)-xe(2,1)
  1259.          zv1=0.d0
  1260.          if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1261.          xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1262. C
  1263. C recuperation de la section et calcul du diamètre
  1264. C
  1265.       MPTVAL=IVACAR
  1266.       DO 2712 ICOMP=1,NCARR
  1267.           MELVAL=IVAL(ICOMP)
  1268.           IGMN = VELCHE(/1)
  1269.           IBMN=MIN(IB,VELCHE(/2))
  1270.           SECA =VELCHE(IGMN,IBMN)
  1271. 2712  CONTINUE
  1272.       diam = sqrt(4.d0*SECA/xpi)
  1273. C
  1274.       xls1 = (3.d0*xpi*diam*xl)/8.d0
  1275.       xls2 = (1.d0*xpi*diam*xl)/8.d0
  1276.       xks1 = xls1*work(1)
  1277.       xks2 = xls2*work(1)
  1278.       xln1 = (3.d0*diam*xl)/8.d0
  1279.       xln2 = (1.d0*diam*xl)/8.d0
  1280.       xkn1 = xln1*work(2)
  1281.       xkn2 = xln2*work(2)
  1282.       xks = work(1)
  1283.       xkn = work(2)
  1284.        if (idim.eq.2) then
  1285. C cas de matrice elastique
  1286.           rel(1,1)= xks1
  1287.           rel(1,3)= xks2
  1288.           rel(1,5)= -xks2
  1289.           rel(1,7)=-xks1
  1290.           rel(7,7)= xks1
  1291.           rel(7,1)=-xks1
  1292.           rel(7,3)= -xks2
  1293.           rel(7,5)= xks2
  1294.           rel(3,3)=xks1
  1295.           rel(3,5)=-xks1
  1296.           rel(3,1)= xks2
  1297.           rel(3,7)= -xks2
  1298.           rel(5,5)=xks1
  1299.           rel(5,3)=-xks1
  1300.           rel(5,1)= -xks2
  1301.           rel(5,7)= xks2
  1302. c ---------------------------
  1303.           rel(2,2)= xkn1
  1304.           rel(2,4)= xkn2
  1305.           rel(2,6)= -xkn2
  1306.           rel(2,8)=-xkn1
  1307.           rel(8,8)= xkn1
  1308.           rel(8,2)=-xkn1
  1309.           rel(8,4)= -xkn2
  1310.           rel(8,6)= xkn2
  1311.           rel(4,4)=xkn1
  1312.           rel(4,6)=-xkn1
  1313.           rel(4,2)= xkn2
  1314.           rel(4,8)= -xkn2
  1315.           rel(6,6)=xkn1
  1316.           rel(6,4)=-xkn1
  1317.           rel(6,2)= -xkn2
  1318.           rel(6,8)= xkn2
  1319.        else if (idim.eq.3) then
  1320. C cas de matrice elastique
  1321.           rel(1,1)= xks1
  1322.           rel(1,4)= xks2
  1323.           rel(1,7)= -xks2
  1324.           rel(1,10)=-xks1
  1325.           rel(10,10)= xks1
  1326.           rel(10,1)=-xks1
  1327.           rel(10,4)= -xks2
  1328.           rel(10,7)= xks2
  1329.           rel(4,4)=xks1
  1330.           rel(4,7)=-xks1
  1331.           rel(4,1)= xks2
  1332.           rel(4,10)= -xks2
  1333.           rel(7,7)=xks1
  1334.           rel(7,4)=-xks1
  1335.           rel(7,1)= -xks2
  1336.           rel(7,10)= xks2
  1337. C ------- remplissage de KN ------------
  1338.           rel(2,2)= xkn1
  1339.           rel(2,5)= xkn2
  1340.           rel(2,8)= -xkn2
  1341.           rel(2,11)=-xkn1
  1342.           rel(11,11)= xkn1
  1343.           rel(11,2)=-xkn1
  1344.           rel(11,5)= -xkn2
  1345.           rel(11,8)= xkn2
  1346.           rel(5,5)=xkn1
  1347.           rel(5,8)=-xkn1
  1348.           rel(5,2)= xkn2
  1349.           rel(5,11)= -xkn2
  1350.           rel(8,8)=xkn1
  1351.           rel(8,5)=-xkn1
  1352.           rel(8,2)= -xkn2
  1353.           rel(8,11)= xkn2
  1354. c------------
  1355.           rel(3,3)= xkn1
  1356.           rel(3,6)= xkn2
  1357.           rel(3,9)= -xkn2
  1358.           rel(3,12)=-xkn1
  1359.           rel(12,12)= xkn1
  1360.           rel(12,3)=-xkn1
  1361.           rel(12,6)= -xkn2
  1362.           rel(12,9)= xkn2
  1363.           rel(6,6)=xkn1
  1364.           rel(6,9)=-xkn1
  1365.           rel(6,3)= xkn2
  1366.           rel(6,12)= -xkn2
  1367.           rel(9,9)=xkn1
  1368.           rel(9,6)=-xkn1
  1369.           rel(9,3)= -xkn2
  1370.           rel(9,12)= xkn2
  1371.        endif
  1372.        do  ia = 1, 4
  1373.        do  ic = 1,4
  1374.          do  io=1,idim
  1375.          do  iu=1,idim
  1376.            xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1377.          enddo
  1378.          enddo
  1379.          call prodt(xpb,xpa,bpss,idim,idim)
  1380.          do io=1,idim
  1381.          do iu=1,idim
  1382.             rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1383.          enddo
  1384.          enddo
  1385.        enddo 
  1386.        enddo 
  1387. C
  1388. C     REMPLISSAGE DE XMATRI
  1389. C
  1390.       CALL REMPMT(RELL,LRE,RE(1,1,IB))
  1391.  3271 continue
  1392.       SEGDES XMATRI
  1393.       SEGSUP WRK1,WRK3,WRK4
  1394.       GOTO 510
  1395. c cccccc
  1396. C_______________________________________________________________________
  1397. C
  1398. C     SECTEUR DE CALCUL POUR LE COA2
  1399. C
  1400. C_______________________________________________________________________
  1401. C
  1402.   272 continue
  1403.       NBNO=NBNN
  1404.       NBBB=NBNN
  1405.       SEGINI WRK1,WRK2,WRK4
  1406. C
  1407. C     BOUCLE POUR TOUS LES ELEMENTS
  1408. C
  1409.       DO 2721  IB=1,NBELEM
  1410. C
  1411. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1412. C
  1413.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1414. C
  1415.       CALL ZERO (REL,LRE,LRE)
  1416. C
  1417. C     CALCUL DES AXES LOCAUX
  1418. C
  1419.       CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1420.       DO 2722  IGAU=1,NBPGAU
  1421. C
  1422. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1423. C
  1424.       CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1425.      .               BGENE,DJAC,IRRT,IDIM,NBNN,NSTRS,LRE)
  1426.       IF(IRRT.NE.0) THEN
  1427.              INTERR(1)=IB
  1428.              CALL ERREUR(764)
  1429.              GOTO 9985
  1430.       ENDIF
  1431.  
  1432. C
  1433. C
  1434. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1435. C
  1436.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1437.       xv1= xe(1,2)-xe(1,1)
  1438.       yv1= xe(2,2)-xe(2,1)
  1439.       zv1=0.d0
  1440.       if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1441.       xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1442. C
  1443. C recuperation de la section et calcul du diamètre
  1444. C
  1445.       MPTVAL=IVACAR
  1446.       DO 2729 ICOMP=1,NCARR
  1447.           MELVAL=IVAL(ICOMP)
  1448.           IGMN = VELCHE(/1)
  1449.           IBMN=MIN(IB,VELCHE(/2))
  1450.           SECA =VELCHE(IGMN,IBMN)
  1451. 2729  CONTINUE
  1452.       diam = sqrt(4.d0*SECA/xpi)
  1453. C
  1454.       DJAC=DJAC*POIGAU(IGAU)
  1455. C
  1456. C     CALCUL DE LA MATRICE DE HOOK
  1457. C
  1458.       MPTVAL=IVAMAT
  1459.       IF(IMAT.EQ.2) THEN
  1460.           MELVAL=IVAL(1)
  1461.           IBMN=MIN(IB  ,IELCHE(/2))
  1462.           IGMN=MIN(IGAU,IELCHE(/1))
  1463.           MLREEL=IELCHE(IGMN,IBMN)
  1464.           SEGACT MLREEL
  1465.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1466.      1    CALL DOHOCO(PROG,LHOOK,DDHOOK,XL,DIAM)
  1467.           SEGDES MLREEL
  1468.         ELSE IF (IMAT.EQ.1) THEN
  1469.           DO 2723 IM=1,NMATT
  1470.             IF (IVAL(IM).NE.0) THEN
  1471.               MELVAL=IVAL(IM)
  1472.               IBMN=MIN(IB  ,VELCHE(/2))
  1473.               IGMN=MIN(IGAU,VELCHE(/1))
  1474.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  1475.             ELSE
  1476.               VALMAT(IM)=0.D0
  1477.             ENDIF
  1478.  2723     CONTINUE
  1479.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1480.      1     CALL DOUCO2(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD,XL,DIAM)
  1481.         END IF
  1482. C
  1483. C     CALCUL ET INTEGRATION DE BDB
  1484. C
  1485.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1486.  
  1487.  
  1488.  2722 CONTINUE
  1489. C
  1490.       do  ia = 1,4
  1491.       do  ic = 1,4
  1492.          do  io=1,idim
  1493.          do  iu=1,idim
  1494.            xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1495.          enddo
  1496.          enddo
  1497.          call prodt(xpb,xpa,bpss,idim,idim)
  1498.          do io=1,idim
  1499.          do iu=1,idim
  1500.             rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1501.          enddo
  1502.          enddo
  1503.       enddo
  1504.       enddo
  1505. C
  1506. C     REMPLISSAGE DE XMATRI
  1507. C
  1508.       CALL REMPMT(RELL,LRE,RE(1,1,IB))
  1509.  2721 CONTINUE
  1510. C
  1511. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1512. C
  1513.       IF (IRTD.EQ.0) THEN
  1514.           MOTERR(1:8) = CMATE
  1515.           MOTERR(9:16) = NOMFR(MFR/2+1)
  1516.           INTERR(1) = IFOUR
  1517.           CALL ERREUR(81)
  1518.       ENDIF
  1519. C
  1520. c      SEGDES XMATRI
  1521.  9985 CONTINUE
  1522.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  1523.       GOTO 510
  1524. *-----------------------------------------------------------------------
  1525. C_______________________________________________________________________
  1526. C
  1527. C     SECTEUR DE CALCUL POUR LE JOI2
  1528. C
  1529. C_______________________________________________________________________
  1530. C
  1531.   85  CONTINUE
  1532.       NBNO=NBNN
  1533.       NBBB=NBNN
  1534.       SEGINI WRK1,WRK2,WRK4
  1535. C
  1536. C     BOUCLE POUR TOUS LES ELEMENTS
  1537. C
  1538.       DO 3085  IB=1,NBELEM
  1539. C
  1540. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1541. C
  1542.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1543. C
  1544.       CALL ZERO (REL,LRE,LRE)
  1545. C
  1546. C     CALCUL DES AXES LOCAUX
  1547. C
  1548.       CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1549. C
  1550. CCC      IF (NOQUAL.EQ.1) THEN
  1551. CCCC                      NOEUDS TROP VOISINS
  1552. CCC         INTERR(1)=IB
  1553. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1554. CCC         CALL ERREUR(323)
  1555. CCC      ELSE IF ( NOQUAL.EQ.2 ) THEN
  1556. CCCC                      JOINT NON PLAN
  1557. CCC         INTERR(1)=IB
  1558. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1559. CCC         CALL ERREUR(323)
  1560. CCC         RETURN
  1561. CCC      ENDIF
  1562. C
  1563. C     BOUCLE SUR LES POINTS DE GAUSS
  1564. C
  1565.       DO 4085  IGAU=1,NBPGAU
  1566. C
  1567. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1568. C
  1569.       CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1570.      +                                BGENE,DJAC,IRRT)
  1571.       DJAC=DJAC*POIGAU(IGAU)
  1572.  
  1573. *
  1574.       IF (IFOUR.EQ.0) THEN
  1575. C
  1576. C     EN AXISYMETRIE, ON MULTIPLIE PAR R
  1577. C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1578. C
  1579.         RAYON=0.0D0
  1580.         NUMSUP=NBNO/2
  1581. *
  1582.         DO 5085 IRAY=1,NUMSUP
  1583.           RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1584.  5085   CONTINUE
  1585. * modif TC
  1586. *          dr =  XE(1,2)-xe(1,1)
  1587. *          ra= XE(1,1)
  1588. *          rb= XE(1,2)
  1589. *          rayona =  rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0
  1590. *          rayona=rayona *2.d0 /dr / dr
  1591. *          rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0
  1592. *         rayonb=rayonb *2.d0 / dr / dr
  1593.  
  1594. *        rayon= rayona
  1595. *        if(igau.eq.2) rayon=rayonb
  1596.         DJAC=DJAC*RAYON
  1597.       ENDIF
  1598. C
  1599. C     IRRT=1 JACOBIEN <= 0
  1600.       IF(IRRT.NE.0) THEN
  1601.          INTERR(1)=IB
  1602.          CALL ERREUR(612)
  1603.       ENDIF
  1604. C
  1605. C     CALCUL DE LA MATRICE DE HOOK
  1606. C
  1607.       MPTVAL=IVAMAT
  1608.       IF(IMAT.EQ.2) THEN
  1609.           MELVAL=IVAL(1)
  1610.           IBMN=MIN(IB  ,IELCHE(/2))
  1611.           IGMN=MIN(IGAU,IELCHE(/1))
  1612.           MLREEL=IELCHE(IGMN,IBMN)
  1613.           SEGACT MLREEL
  1614.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1615.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1616.           SEGDES MLREEL
  1617.       ELSE IF (IMAT.EQ.1) THEN
  1618.           DO 9085 IM=1,NMATT
  1619.             IF (IVAL(IM).NE.0) THEN
  1620.               MELVAL=IVAL(IM)
  1621.               IBMN=MIN(IB  ,VELCHE(/2))
  1622.               IGMN=MIN(IGAU,VELCHE(/1))
  1623.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  1624.             ELSE
  1625.               VALMAT(IM)=0.D0
  1626.             ENDIF
  1627.  9085     CONTINUE
  1628.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1629.      1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1630.       ENDIF
  1631. C
  1632. C     CALCUL ET INTEGRATION DE BDB
  1633. C
  1634.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1635.  4085 CONTINUE
  1636. C
  1637. *      SEGINI XMATRI
  1638. *      IMATTT(IB)=XMATRI
  1639. C
  1640. C     REMPLISSAGE DE XMATRI
  1641. C
  1642.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  1643. *      SEGDES XMATRI
  1644.  3085 CONTINUE
  1645. C
  1646. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1647. C
  1648.       IF (IRTD.EQ.0) THEN
  1649.           MOTERR(1:8) = CMATE
  1650.           MOTERR(9:16) = NOMFR(MFR/2+1)
  1651.           INTERR(1) = IFOUR
  1652.           CALL ERREUR(81)
  1653.       ENDIF
  1654. C
  1655.       SEGDES XMATRI
  1656.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  1657.       GOTO 510
  1658. C_______________________________________________________________________
  1659. C
  1660. C     SECTEUR DE CALCUL POUR LE JGI2
  1661. C
  1662. C_______________________________________________________________________
  1663. C
  1664.   170 CONTINUE
  1665.       NBNO=NBNN
  1666.       NBBB=NBNN
  1667.       SEGINI WRK1,WRK2,WRK4
  1668. C
  1669. C     BOUCLE POUR TOUS LES ELEMENTS
  1670. C
  1671.       DO IB=1,NBELEM
  1672. C
  1673. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1674. C
  1675.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1676. C
  1677.         CALL ZERO (REL,LRE,LRE)
  1678. C
  1679. C     CALCUL DES AXES LOCAUX
  1680. C
  1681.         CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1682. C
  1683. C     BOUCLE SUR LES POINTS DE GAUSS
  1684. C
  1685.         DO IGAU=1,NBPGAU
  1686. C
  1687. C        ON CHERCHE L EPAISSEUR DU JOINT
  1688. C
  1689.           EPAIST=0.D0
  1690.           MPTVAL=IVACAR
  1691.           MELVAL=IVAL(1)
  1692.           IF (MELVAL.NE.0) THEN
  1693.             IGMN=MIN(IGAU,VELCHE(/1))
  1694.             IBMN=MIN(IB,VELCHE(/2))
  1695.             EPAIST=VELCHE(IGMN,IBMN)
  1696.           ENDIF
  1697. C
  1698. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1699. C
  1700. CcPPj     CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1701. CcPPj.                         EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1702.           CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1703.      .                         EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1704.           DJAC=DJAC*POIGAU(IGAU)
  1705. C
  1706.           IF (IFOUR.EQ.0) THEN
  1707. C
  1708. C     EN AXISYMETRIE, ON MULTIPLIE PAR R
  1709. C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1710. C
  1711.             RAYON=0.0D0
  1712.             NUMSUP=NBNO/2
  1713.             DO IRAY=1,NUMSUP
  1714.                RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1715.             ENDDO
  1716.             DJAC=DJAC*RAYON
  1717.           ENDIF
  1718. C
  1719. C         IRRT=1 JACOBIEN <= 0
  1720.           IF(IRRT.NE.0) THEN
  1721.              INTERR(1)=IB
  1722.              CALL ERREUR(612)
  1723.           ENDIF
  1724. C
  1725. C     CALCUL DE LA MATRICE DE HOOK
  1726. C
  1727.           MPTVAL=IVAMAT
  1728.           IF(IMAT.EQ.2) THEN
  1729.               MELVAL=IVAL(1)
  1730.               IBMN=MIN(IB  ,IELCHE(/2))
  1731.               IGMN=MIN(IGAU,IELCHE(/1))
  1732.               MLREEL=IELCHE(IGMN,IBMN)
  1733.               SEGACT MLREEL
  1734.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1735.      1         CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1736.               SEGDES MLREEL
  1737.           ELSE IF (IMAT.EQ.1) THEN
  1738.               DO IM=1,NMATT
  1739.                 IF (IVAL(IM).NE.0) THEN
  1740.                   MELVAL=IVAL(IM)
  1741.                   IBMN=MIN(IB  ,VELCHE(/2))
  1742.                   IGMN=MIN(IGAU,VELCHE(/1))
  1743.                   VALMAT(IM)=VELCHE(IGMN,IBMN)
  1744.                 ELSE
  1745.                   VALMAT(IM)=0.D0
  1746.                 ENDIF
  1747.               ENDDO
  1748.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1749.      1         CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1750.           ENDIF
  1751. C
  1752. C     CALCUL ET INTEGRATION DE BDB
  1753. C
  1754.           CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1755.         ENDDO
  1756. C
  1757. *        SEGINI XMATRI
  1758. *        IMATTT(IB)=XMATRI
  1759. C
  1760. C     REMPLISSAGE DE XMATRI
  1761. C
  1762.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  1763. *        SEGDES XMATRI
  1764.       ENDDO
  1765. C
  1766. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1767. C
  1768.       IF (IRTD.EQ.0) THEN
  1769.           MOTERR(1:8) = CMATE
  1770.           MOTERR(9:16) = NOMFR(MFR/2+1)
  1771.           INTERR(1) = IFOUR
  1772.           CALL ERREUR(81)
  1773.       ENDIF
  1774. C
  1775.       SEGDES XMATRI
  1776.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  1777.       GOTO 510
  1778. C_______________________________________________________________________
  1779. C
  1780. C     SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement
  1781. C
  1782. C_______________________________________________________________________
  1783. C
  1784.   168 CONTINUE
  1785.       NBNO=NBNN
  1786.       NBBB=NBNN
  1787.       SEGINI WRK1,WRK2,WRK4
  1788. C
  1789. C     BOUCLE POUR TOUS LES ELEMENTS
  1790. C
  1791.       DO IB=1,NBELEM
  1792. C
  1793. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1794. C
  1795.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1796. C
  1797.         CALL ZERO (REL,LRE,LRE)
  1798. C
  1799. C     CALCUL DES AXES LOCAUX
  1800. C
  1801.         CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1802. C
  1803.         IF (NOQUAL.EQ.1) THEN
  1804.            INTERR(1)=IB
  1805.            MOTERR(1:4) = 'JGT3'
  1806.            CALL ERREUR(765)
  1807.            RETURN
  1808.         ELSE IF ( NOQUAL.EQ.2) THEN
  1809.            INTERR(1)=IB
  1810.            MOTERR(1:4) = 'JGT3'
  1811.            CALL ERREUR(766)
  1812.            RETURN
  1813.         ENDIF
  1814. C
  1815. C     BOUCLE SUR LES POINTS DE GAUSS
  1816. C
  1817.         DO IGAU=1,NBPGAU
  1818. C               4
  1819. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1820. C
  1821.           CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1822.      +                               BGENE,DJAC,IRRT)
  1823.           DJAC=DJAC*POIGAU(IGAU)
  1824. C     IRRT=1 JACOBIEN <= 0
  1825.           IF(IRRT.NE.0) THEN
  1826.              CALL ERREUR(764)
  1827.           ENDIF
  1828. C
  1829. C     CALCUL DE LA MATRICE DE HOOK
  1830. C
  1831.           MPTVAL=IVAMAT
  1832.           IF(IMAT.EQ.2) THEN
  1833.             MELVAL=IVAL(1)
  1834.             IBMN=MIN(IB  ,IELCHE(/2))
  1835.             IGMN=MIN(IGAU,IELCHE(/1))
  1836.             MLREEL=IELCHE(IGMN,IBMN)
  1837.             SEGACT MLREEL
  1838.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1839.      1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1840.             SEGDES MLREEL
  1841.           ELSE IF (IMAT.EQ.1) THEN
  1842.             DO IM=1,NMATT
  1843.               IF (IVAL(IM).NE.0) THEN
  1844.                 MELVAL=IVAL(IM)
  1845.                 IBMN=MIN(IB  ,VELCHE(/2))
  1846.                 IGMN=MIN(IGAU,VELCHE(/1))
  1847.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  1848.               ELSE
  1849.                 VALMAT(IM)=0.D0
  1850.               ENDIF
  1851.             ENDDO
  1852.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1853.      1       CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1854.           ENDIF
  1855. C
  1856. C     CALCUL ET INTEGRATION DE BDB
  1857. C
  1858.           CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1859.         ENDDO
  1860. C
  1861. *        SEGINI XMATRI
  1862. *        IMATTT(IB)=XMATRI
  1863. C
  1864. C     REMPLISSAGE DE XMATRI
  1865. C
  1866.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  1867. *        SEGDES XMATRI
  1868.       ENDDO
  1869. C
  1870. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1871. C
  1872.       IF (IRTD.EQ.0) THEN
  1873.           MOTERR(1:8) = CMATE
  1874.           MOTERR(9:16) = NOMFR(MFR/2+1)
  1875.           INTERR(1) = IFOUR
  1876.           CALL ERREUR(81)
  1877.       ENDIF
  1878. C
  1879.       SEGDES XMATRI
  1880.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  1881.       GOTO 510
  1882. C_______________________________________________________________________
  1883. C
  1884. C     SECTEUR DE CALCUL POUR LE JGT3 GENERALISE
  1885. C
  1886. C_______________________________________________________________________
  1887. C
  1888.   171 CONTINUE
  1889.       NBNO=NBNN
  1890.       NBBB=NBNN
  1891.       SEGINI WRK1,WRK2,WRK4
  1892. C
  1893. C     BOUCLE POUR TOUS LES ELEMENTS
  1894. C
  1895.       DO IB=1,NBELEM
  1896. C
  1897. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1898. C
  1899.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1900. C
  1901.         CALL ZERO (REL,LRE,LRE)
  1902. C
  1903. C     CALCUL DES AXES LOCAUX
  1904. C
  1905.         CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1906. C
  1907.         IF (NOQUAL.EQ.1) THEN
  1908.            INTERR(1)=IB
  1909.            MOTERR(1:4) = 'JGT3'
  1910.            CALL ERREUR(765)
  1911.            RETURN
  1912.         ELSE IF ( NOQUAL.EQ.2) THEN
  1913.            INTERR(1)=IB
  1914.            MOTERR(1:4) = 'JGT3'
  1915.            CALL ERREUR(766)
  1916.            RETURN
  1917.         ENDIF
  1918. C
  1919. C     BOUCLE SUR LES POINTS DE GAUSS
  1920. C
  1921.         DO IGAU=1,NBPGAU
  1922. C
  1923. C  ON CHERCHE L'EPAISSEUR DU JOINT
  1924. C
  1925.           EPAIST=0.D0
  1926.           MPTVAL=IVACAR
  1927.           MELVAL=IVAL(1)
  1928.           IF (MELVAL.NE.0) THEN
  1929.             IGMN=MIN(IGAU,VELCHE(/1))
  1930.             IBMN=MIN(IB,VELCHE(/2))
  1931.             EPAIST=VELCHE(IGMN,IBMN)
  1932.           ENDIF
  1933. C               4
  1934. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1935. C
  1936. CcPPj     CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1937.           CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1938.      +                               EPAIST,BGENE,DJAC,IRRT)
  1939.           DJAC=DJAC*POIGAU(IGAU)
  1940. C     IRRT=1 JACOBIEN <= 0
  1941.           IF(IRRT.NE.0) THEN
  1942.              CALL ERREUR(764)
  1943.           ENDIF
  1944. C
  1945. C     CALCUL DE LA MATRICE DE HOOK
  1946. C
  1947.           MPTVAL=IVAMAT
  1948.           IF(IMAT.EQ.2) THEN
  1949.             MELVAL=IVAL(1)
  1950.             IBMN=MIN(IB  ,IELCHE(/2))
  1951.             IGMN=MIN(IGAU,IELCHE(/1))
  1952.             MLREEL=IELCHE(IGMN,IBMN)
  1953.             SEGACT MLREEL
  1954.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1955.      1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1956.             SEGDES MLREEL
  1957.           ELSE IF (IMAT.EQ.1) THEN
  1958.             DO IM=1,NMATT
  1959.               IF (IVAL(IM).NE.0) THEN
  1960.                 MELVAL=IVAL(IM)
  1961.                 IBMN=MIN(IB  ,VELCHE(/2))
  1962.                 IGMN=MIN(IGAU,VELCHE(/1))
  1963.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  1964.               ELSE
  1965.                 VALMAT(IM)=0.D0
  1966.               ENDIF
  1967.             ENDDO
  1968.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1969.      1       CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1970.           ENDIF
  1971. C
  1972. C     CALCUL ET INTEGRATION DE BDB
  1973. C
  1974.           CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1975.         ENDDO
  1976. C
  1977. *        SEGINI XMATRI
  1978. *        IMATTT(IB)=XMATRI
  1979. C
  1980. C     REMPLISSAGE DE XMATRI
  1981. C
  1982.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  1983. *        SEGDES XMATRI
  1984.       ENDDO
  1985. C
  1986. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1987. C
  1988.       IF (IRTD.EQ.0) THEN
  1989.           MOTERR(1:8) = CMATE
  1990.           MOTERR(9:16) = NOMFR(MFR/2+1)
  1991.           INTERR(1) = IFOUR
  1992.           CALL ERREUR(81)
  1993.       ENDIF
  1994. C
  1995.       SEGDES XMATRI
  1996.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  1997.       GOTO 510
  1998. C_______________________________________________________________________
  1999. C
  2000. C     SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement
  2001. C
  2002. C_______________________________________________________________________
  2003. C
  2004.   169 CONTINUE
  2005.       NBNO=NBNN
  2006.       NBBB=NBNN
  2007.       SEGINI WRK1,WRK2,WRK4
  2008. C
  2009. C     BOUCLE POUR TOUS LES ELEMENTS
  2010. C
  2011.       DO IB=1,NBELEM
  2012. C
  2013. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2014. C
  2015.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2016. C
  2017.         CALL ZERO (REL,LRE,LRE)
  2018. C
  2019. C     CALCUL DES AXES LOCAUX
  2020. C
  2021.         CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2022.  
  2023.         IF (NOQUAL.EQ.1) THEN
  2024.           INTERR(1)=IB
  2025.           MOTERR(1:4) = 'JCI4'
  2026.           CALL ERREUR(765)
  2027.           RETURN
  2028.         ELSE IF ( NOQUAL.EQ.2 ) THEN
  2029.           INTERR(1)=IB
  2030.           MOTERR(1:4) = 'JCI4'
  2031.           CALL ERREUR(766)
  2032.           RETURN
  2033.         ENDIF
  2034. C
  2035. C     BOUCLE SUR LES POINTS DE GAUSS
  2036. C
  2037.         DO IGAU=1,NBPGAU
  2038. C
  2039. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2040. C
  2041.           CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  2042.           DJAC=DJAC*POIGAU(IGAU)
  2043. C     IRRT=1 JACOBIEN <= 0
  2044.           IF(IRRT.NE.0) THEN
  2045.             INTERR(1)=IB
  2046.             CALL ERREUR(611)
  2047.           ENDIF
  2048. C
  2049. C     CALCUL DE LA MATRICE DE HOOK
  2050. C
  2051.           MPTVAL=IVAMAT
  2052.           IF(IMAT.EQ.2) THEN
  2053.             MELVAL=IVAL(1)
  2054.             IBMN=MIN(IB  ,IELCHE(/2))
  2055.             IGMN=MIN(IGAU,IELCHE(/1))
  2056.             MLREEL=IELCHE(IGMN,IBMN)
  2057.             SEGACT MLREEL
  2058.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2059.      1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2060.             SEGDES MLREEL
  2061.           ELSE IF (IMAT.EQ.1) THEN
  2062.             DO IM=1,NMATT
  2063.               IF (IVAL(IM).NE.0) THEN
  2064.                 MELVAL=IVAL(IM)
  2065.                 IBMN=MIN(IB  ,VELCHE(/2))
  2066.                 IGMN=MIN(IGAU,VELCHE(/1))
  2067.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  2068.               ELSE
  2069.                 VALMAT(IM)=0.D0
  2070.               ENDIF
  2071.             ENDDO
  2072.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2073.      1       CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2074.           ENDIF
  2075. C
  2076. C     CALCUL ET INTEGRATION DE BDB
  2077. C
  2078.           CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2079.         ENDDO
  2080. C
  2081. *        SEGINI XMATRI
  2082. *        IMATTT(IB)=XMATRI
  2083. C
  2084. C     REMPLISSAGE DE XMATRI
  2085. C
  2086.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  2087. *        SEGDES XMATRI
  2088.       ENDDO
  2089. C
  2090. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2091. C
  2092.       IF (IRTD.EQ.0) THEN
  2093.           MOTERR(1:8) = CMATE
  2094.           MOTERR(9:16) = NOMFR(MFR/2+1)
  2095.           INTERR(1) = IFOUR
  2096.           CALL ERREUR(81)
  2097.       ENDIF
  2098. C
  2099.       SEGDES XMATRI
  2100.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  2101.       GOTO 510
  2102. C_______________________________________________________________________
  2103. C
  2104. C     SECTEUR DE CALCUL POUR LE JGI4 GENERALISE
  2105. C
  2106. C_______________________________________________________________________
  2107. C
  2108.   172 CONTINUE
  2109.       NBNO=NBNN
  2110.       NBBB=NBNN
  2111.       SEGINI WRK1,WRK2,WRK4
  2112. C
  2113. C     BOUCLE POUR TOUS LES ELEMENTS
  2114. C
  2115.       DO IB=1,NBELEM
  2116. C
  2117. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2118. C
  2119.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2120. C
  2121.         CALL ZERO (REL,LRE,LRE)
  2122. C
  2123. C     CALCUL DES AXES LOCAUX
  2124. C
  2125.         CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2126.  
  2127.         IF (NOQUAL.EQ.1) THEN
  2128.           INTERR(1)=IB
  2129.           MOTERR(1:4) = 'JGI4'
  2130.           CALL ERREUR(765)
  2131.           RETURN
  2132.         ELSE IF ( NOQUAL.EQ.2 ) THEN
  2133. CbPPj     INTERR(1)=IB
  2134. CbPPj     MOTERR(1:4) = 'JGI4'
  2135. CbPPj     CALL ERREUR(766)
  2136. CbPPj     RETURN
  2137.           WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB,
  2138.      .                  ' not planar'
  2139.         ENDIF
  2140. C
  2141. C     BOUCLE SUR LES POINTS DE GAUSS
  2142. C
  2143.         DO IGAU=1,NBPGAU
  2144. C
  2145. C  ON CHERCHE L'EPAISSEUR DU JOINT
  2146. C
  2147.           EPAIST=0.D0
  2148.           MPTVAL=IVACAR
  2149.           MELVAL=IVAL(1)
  2150.           IF (MELVAL.NE.0) THEN
  2151.             IGMN=MIN(IGAU,VELCHE(/1))
  2152.             IBMN=MIN(IB,VELCHE(/2))
  2153.             EPAIST=VELCHE(IGMN,IBMN)
  2154.           ENDIF
  2155. C
  2156. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2157. C
  2158. CcPPj     CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT)
  2159.           CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,
  2160.      .                                                           IRRT)
  2161.           DJAC=DJAC*POIGAU(IGAU)
  2162. C     IRRT=1 JACOBIEN <= 0
  2163.           IF(IRRT.NE.0) THEN
  2164.             INTERR(1)=IB
  2165.             CALL ERREUR(611)
  2166.           ENDIF
  2167. C
  2168. C     CALCUL DE LA MATRICE DE HOOK
  2169. C
  2170.           MPTVAL=IVAMAT
  2171.           IF(IMAT.EQ.2) THEN
  2172.             MELVAL=IVAL(1)
  2173.             IBMN=MIN(IB  ,IELCHE(/2))
  2174.             IGMN=MIN(IGAU,IELCHE(/1))
  2175.             MLREEL=IELCHE(IGMN,IBMN)
  2176.             SEGACT MLREEL
  2177.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2178.      1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2179.             SEGDES MLREEL
  2180.           ELSE IF (IMAT.EQ.1) THEN
  2181.             DO IM=1,NMATT
  2182.               IF (IVAL(IM).NE.0) THEN
  2183.                 MELVAL=IVAL(IM)
  2184.                 IBMN=MIN(IB  ,VELCHE(/2))
  2185.                 IGMN=MIN(IGAU,VELCHE(/1))
  2186.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  2187.               ELSE
  2188.                 VALMAT(IM)=0.D0
  2189.               ENDIF
  2190.             ENDDO
  2191.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2192.      1       CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  2193.           ENDIF
  2194. C
  2195. C     CALCUL ET INTEGRATION DE BDB
  2196. C
  2197.           CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2198.         ENDDO
  2199. C
  2200. *        SEGINI XMATRI
  2201. *        IMATTT(IB)=XMATRI
  2202. C
  2203. C     REMPLISSAGE DE XMATRI
  2204. C
  2205.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  2206. *        SEGDES XMATRI
  2207.       ENDDO
  2208. C
  2209. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2210. C
  2211.       IF (IRTD.EQ.0) THEN
  2212.           MOTERR(1:8) = CMATE
  2213.           MOTERR(9:16) = NOMFR(MFR/2+1)
  2214.           INTERR(1) = IFOUR
  2215.           CALL ERREUR(81)
  2216.       ENDIF
  2217. C
  2218.       SEGDES XMATRI
  2219.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  2220.       GOTO 510
  2221. C
  2222. C_______________________________________________________________________
  2223. C
  2224. C     SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE
  2225. C                                    ET SANS REPERE LOCAL
  2226. C
  2227. C_______________________________________________________________________
  2228. C
  2229.   86  CONTINUE
  2230.       NBNO=NBNN
  2231.       NBBB=NBNN
  2232.       SEGINI WRK1,WRK2,WRK4
  2233. C
  2234. C     BOUCLE POUR TOUS LES ELEMENTS
  2235. C
  2236.       DO 3086  IB=1,NBELEM
  2237. C
  2238. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2239. C
  2240.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2241. C
  2242.       CALL ZERO (REL,LRE,LRE)
  2243. C
  2244. C     BOUCLE SUR LES POINTS DE GAUSS
  2245. C
  2246.       DO 4086  IGAU=1,NBPGAU
  2247. C
  2248. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2249. C
  2250.  
  2251.       CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS)
  2252.       CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  2253.      +                               BGENE,DJAC,IRRT)
  2254.       DJAC=DJAC*POIGAU(IGAU)
  2255. *
  2256.       IF (IFOUR.EQ.0) THEN
  2257. C
  2258. C     EN AXISYMETRIE, ON MULTIPLIE PAR R
  2259. C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
  2260. C
  2261.         RAYON=0.0D0
  2262.         NUMSUP=NBNO/2
  2263.         DO 5086 IRAY=1,NUMSUP
  2264.            RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  2265.  5086   CONTINUE
  2266.         DJAC=DJAC*RAYON
  2267.       ENDIF
  2268. C
  2269. C     IRRT=1 JACOBIEN <= 0
  2270.       IF(IRRT.NE.0) THEN
  2271.          INTERR(1)=IB
  2272.          CALL ERREUR(612)
  2273.       ENDIF
  2274. C
  2275. C     CALCUL DE LA MATRICE DE HOOK
  2276. C
  2277.       MPTVAL=IVAMAT
  2278.       IF(IMAT.EQ.2) THEN
  2279.           MELVAL=IVAL(1)
  2280.           IBMN=MIN(IB  ,IELCHE(/2))
  2281.           IGMN=MIN(IGAU,IELCHE(/1))
  2282.           MLREEL=IELCHE(IGMN,IBMN)
  2283.           SEGACT MLREEL
  2284.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2285.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2286.           SEGDES MLREEL
  2287.       ELSE IF (IMAT.EQ.1) THEN
  2288.           DO 9086 IM=1,NMATT
  2289.             IF (IVAL(IM).NE.0) THEN
  2290.               MELVAL=IVAL(IM)
  2291.               IBMN=MIN(IB  ,VELCHE(/2))
  2292.               IGMN=MIN(IGAU,VELCHE(/1))
  2293.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  2294.             ELSE
  2295.               VALMAT(IM)=0.D0
  2296.             ENDIF
  2297.  9086     CONTINUE
  2298.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2299.      1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2300.       ENDIF
  2301. C
  2302. C     CALCUL ET INTEGRATION DE BDB
  2303. C
  2304.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2305.  4086 CONTINUE
  2306. C
  2307. *      SEGINI XMATRI
  2308. *      IMATTT(IB)=XMATRI
  2309. C
  2310. C     REMPLISSAGE DE XMATRI
  2311. C
  2312.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2313. *      SEGDES XMATRI
  2314.  3086 CONTINUE
  2315. C
  2316. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2317. C
  2318.       IF (IRTD.EQ.0) THEN
  2319.           MOTERR(1:8) = CMATE
  2320.           MOTERR(9:16) = NOMFR(MFR/2+1)
  2321.           INTERR(1) = IFOUR
  2322.           CALL ERREUR(81)
  2323.       ENDIF
  2324. C
  2325.       SEGDES XMATRI
  2326.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  2327.       GOTO 510
  2328. C_______________________________________________________________________
  2329. C
  2330. C     SECTEUR DE CALCUL POUR LE JOT3
  2331. C
  2332. C_______________________________________________________________________
  2333. C
  2334.   87  CONTINUE
  2335.       NBNO=NBNN
  2336.       NBBB=NBNN
  2337.       SEGINI WRK1,WRK2,WRK4
  2338. C
  2339. C     BOUCLE POUR TOUS LES ELEMENTS
  2340. C
  2341.       DO 3087  IB=1,NBELEM
  2342. C
  2343. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2344. C
  2345.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2346. C
  2347.       CALL ZERO (REL,LRE,LRE)
  2348. C
  2349. C     CALCUL DES AXES LOCAUX
  2350. C
  2351.       CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2352. C
  2353.       IF (NOQUAL.EQ.1) THEN
  2354.          INTERR(1)=IB
  2355.          MOTERR(1:4) = 'JOT3'
  2356.          CALL ERREUR(765)
  2357.          RETURN
  2358.       ELSE IF ( NOQUAL.EQ.2) THEN
  2359.          INTERR(1)=IB
  2360.          MOTERR(1:4) = 'JOT3'
  2361.          CALL ERREUR(766)
  2362.          RETURN
  2363.       ENDIF
  2364. C
  2365. C     BOUCLE SUR LES POINTS DE GAUSS
  2366. C
  2367.       DO 4087  IGAU=1,NBPGAU
  2368. C               4
  2369. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2370. C
  2371.       CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  2372.      +                               BGENE,DJAC,IRRT)
  2373.       DJAC=DJAC*POIGAU(IGAU)
  2374. C     IRRT=1 JACOBIEN <= 0
  2375.       IF(IRRT.NE.0) THEN
  2376.          CALL ERREUR(764)
  2377.       ENDIF
  2378. C
  2379. C     CALCUL DE LA MATRICE DE HOOK
  2380. C
  2381.       MPTVAL=IVAMAT
  2382.       IF(IMAT.EQ.2) THEN
  2383.           MELVAL=IVAL(1)
  2384.           IBMN=MIN(IB  ,IELCHE(/2))
  2385.           IGMN=MIN(IGAU,IELCHE(/1))
  2386.           MLREEL=IELCHE(IGMN,IBMN)
  2387.           SEGACT MLREEL
  2388.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2389.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2390.           SEGDES MLREEL
  2391.       ELSE IF (IMAT.EQ.1) THEN
  2392.           DO 9087 IM=1,NMATT
  2393.             IF (IVAL(IM).NE.0) THEN
  2394.               MELVAL=IVAL(IM)
  2395.               IBMN=MIN(IB  ,VELCHE(/2))
  2396.               IGMN=MIN(IGAU,VELCHE(/1))
  2397.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  2398.             ELSE
  2399.               VALMAT(IM)=0.D0
  2400.             ENDIF
  2401.  9087     CONTINUE
  2402.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2403.      1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2404.       ENDIF
  2405. C
  2406. C     CALCUL ET INTEGRATION DE BDB
  2407. C
  2408.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2409.  4087 CONTINUE
  2410. C
  2411. *      SEGINI XMATRI
  2412. *      IMATTT(IB)=XMATRI
  2413. C
  2414. C     REMPLISSAGE DE XMATRI
  2415. C
  2416.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2417. *      SEGDES XMATRI
  2418.  3087 CONTINUE
  2419. C
  2420. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2421. C
  2422.       IF (IRTD.EQ.0) THEN
  2423.           MOTERR(1:8) = CMATE
  2424.           MOTERR(9:16) = NOMFR(MFR/2+1)
  2425.           INTERR(1) = IFOUR
  2426.           CALL ERREUR(81)
  2427.       ENDIF
  2428. C
  2429.       SEGDES XMATRI
  2430.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  2431.       GOTO 510
  2432. C_______________________________________________________________________
  2433. C
  2434. C     SECTEUR DE CALCUL POUR LE JOI4
  2435. C
  2436. C_______________________________________________________________________
  2437. C
  2438.   88  CONTINUE
  2439.       NBNO=NBNN
  2440.       NBBB=NBNN
  2441.       SEGINI WRK1,WRK2,WRK4
  2442. C
  2443. C     BOUCLE POUR TOUS LES ELEMENTS
  2444. C
  2445.       DO 3088  IB=1,NBELEM
  2446. C
  2447. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2448. C
  2449.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2450. C
  2451.       CALL ZERO (REL,LRE,LRE)
  2452. C
  2453. C     CALCUL DES AXES LOCAUX
  2454. C
  2455.       CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2456.  
  2457.       IF (NOQUAL.EQ.1) THEN
  2458.          INTERR(1)=IB
  2459.          MOTERR(1:4) = 'JOI4'
  2460.          CALL ERREUR(765)
  2461.          RETURN
  2462.       ELSE IF ( NOQUAL.EQ.2 ) THEN
  2463.          INTERR(1)=IB
  2464.          MOTERR(1:4) = 'JOI4'
  2465.          CALL ERREUR(766)
  2466.          RETURN
  2467.       ENDIF
  2468. C
  2469. C     BOUCLE SUR LES POINTS DE GAUSS
  2470. C
  2471.       DO 4088  IGAU=1,NBPGAU
  2472. C
  2473. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2474. C
  2475.       CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  2476.       DJAC=DJAC*POIGAU(IGAU)
  2477. C     IRRT=1 JACOBIEN <= 0
  2478.       IF(IRRT.NE.0) THEN
  2479.          INTERR(1)=IB
  2480.          CALL ERREUR(611)
  2481.       ENDIF
  2482. C
  2483. C     CALCUL DE LA MATRICE DE HOOK
  2484. C
  2485.       MPTVAL=IVAMAT
  2486.       IF(IMAT.EQ.2) THEN
  2487.           MELVAL=IVAL(1)
  2488.           IBMN=MIN(IB  ,IELCHE(/2))
  2489.           IGMN=MIN(IGAU,IELCHE(/1))
  2490.           MLREEL=IELCHE(IGMN,IBMN)
  2491.           SEGACT MLREEL
  2492.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2493.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2494.           SEGDES MLREEL
  2495.       ELSE IF (IMAT.EQ.1) THEN
  2496.           DO 9088 IM=1,NMATT
  2497.             IF (IVAL(IM).NE.0) THEN
  2498.               MELVAL=IVAL(IM)
  2499.               IBMN=MIN(IB  ,VELCHE(/2))
  2500.               IGMN=MIN(IGAU,VELCHE(/1))
  2501.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  2502.             ELSE
  2503.               VALMAT(IM)=0.D0
  2504.             ENDIF
  2505.  9088     CONTINUE
  2506.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2507.      1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2508.       ENDIF
  2509. C
  2510. C     CALCUL ET INTEGRATION DE BDB
  2511. C
  2512.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2513.  4088 CONTINUE
  2514. C
  2515. *      SEGINI XMATRI
  2516. *      IMATTT(IB)=XMATRI
  2517. C
  2518. C     REMPLISSAGE DE XMATRI
  2519. C
  2520.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2521. *      SEGDES XMATRI
  2522.  3088 CONTINUE
  2523. C
  2524. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2525. C
  2526.       IF (IRTD.EQ.0) THEN
  2527.           MOTERR(1:8) = CMATE
  2528.           MOTERR(9:16) = NOMFR(MFR/2+1)
  2529.           INTERR(1) = IFOUR
  2530.           CALL ERREUR(81)
  2531.       ENDIF
  2532. C
  2533.       SEGDES XMATRI
  2534.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  2535.       GOTO 510
  2536. C_______________________________________________________________________
  2537. C
  2538. C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE  TRIH
  2539. C_______________________________________________________________________
  2540. C
  2541.   92  CONTINUE
  2542.       NBNO=NBNN
  2543.       NBBB=NBNN
  2544.       LRN =NBNN
  2545.       NSTN=3
  2546.       SEGINI WRK1,WRK2 ,WRK5
  2547.       I195=0
  2548.       DO 3092  IB=1,NBELEM
  2549. C
  2550. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2551. C
  2552.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2553.       CALL ZERO (REL,LRE,LRE)
  2554. *
  2555.         MPTVAL=IVAMAT
  2556.         DO 9092 IM=1,10
  2557.           IF (IVAL(IM).NE.0) THEN
  2558.             MELVAL=IVAL(IM)
  2559.             IBMN=MIN(IB  ,VELCHE(/2))
  2560.             VALMAT(IM)=VELCHE(1,IBMN)
  2561.           ELSE
  2562.             VALMAT(IM)=0.D0
  2563.  
  2564.           ENDIF
  2565.  9092   CONTINUE
  2566. C
  2567. C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2568. C
  2569.       RHOF  =VALMAT(4)
  2570.       E     =VALMAT(6)
  2571.       C     =VALMAT(7)
  2572.       RHOREF=VALMAT(8)
  2573.       CREF  =VALMAT(9)
  2574.       RLCAR =VALMAT(10)
  2575. C
  2576. C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2577. C
  2578.       MPTVAL=IVACAR
  2579.       IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  2580.         MELVAL=IVAL(1)
  2581.           IBMN=MIN(IB,VELCHE(/2))
  2582.           SCEL  =VELCHE(1,IBMN)
  2583.         MELVAL=IVAL(2)
  2584.           IBMN=MIN(IB,VELCHE(/2))
  2585.           SFLU  =VELCHE(1,IBMN)
  2586.         MELVAL=IVAL(3)
  2587.           IBMN=MIN(IB,VELCHE(/2))
  2588.           EPS   =VELCHE(1,IBMN)
  2589.         MELVAL=IVAL(4)
  2590.           IBMN=MIN(IB,VELCHE(/2))
  2591.           XINERT=VELCHE(1,IBMN)
  2592.         EI = E*XINERT/(EPS*EPS)
  2593.       ELSE
  2594.         MELVAL=IVAL(1)
  2595.           IBMN=MIN(IB,VELCHE(/2))
  2596.           SCEL  =VELCHE(1,IBMN)
  2597.         MELVAL=IVAL(2)
  2598.           IBMN=MIN(IB,VELCHE(/2))
  2599.           SFLU  =VELCHE(1,IBMN)
  2600.         MELVAL=IVAL(3)
  2601.           IBMN=MIN(IB,VELCHE(/2))
  2602.           EPS   =VELCHE(1,IBMN)
  2603. C       E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE
  2604.         EI = E /(EPS*EPS)
  2605.       ENDIF
  2606. C
  2607. C     CALCUL DES COEFFICIENTS DE NORMALISATION
  2608. C
  2609.       COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2610.       VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2611.       VKL2  = EI/SCEL
  2612. C
  2613. C     BOUCLE SUR LES POINTS DE GAUSS
  2614. C
  2615.       ISDJC=0
  2616.       DO 4092  IGAU=1,NBPGAU
  2617.       CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2618.      #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2619.       IF(IRRT.NE.1) GOTO 5092
  2620.       DJAC=DJAC*POIGAU(IGAU)
  2621.       CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2622.  4092 CONTINUE
  2623.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2624. *      SEGINI XMATRI
  2625. *      IMATTT(IB)=XMATRI
  2626. C
  2627. C     REMPLISSAGE DE XMATRI
  2628. C
  2629.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2630. *      SEGDES XMATRI
  2631.  3092 CONTINUE
  2632. C
  2633. C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
  2634. C
  2635.  5092 CONTINUE
  2636.       IF(IRRT.EQ.0) THEN
  2637.       MOTERR(1:4)=NOMTP(MELE)
  2638.       CALL ERREUR(420)
  2639.       ELSE
  2640.       IF(IRRT.EQ.2) THEN
  2641.       INTERR(1)=IB
  2642.       CALL ERREUR(405)
  2643.       ENDIF
  2644.       ENDIF
  2645.       IF(I195.NE.0) INTERR(1)=I195
  2646.       IF(I195.NE.0) CALL ERREUR(195)
  2647.       SEGDES XMATRI
  2648.       SEGSUP WRK1,WRK2,WRK5,MVELCH
  2649.       GOTO 510
  2650. *_______________________________________________________________________
  2651. *
  2652. *     ELEMENT  TUYO
  2653. *_______________________________________________________________________
  2654. *
  2655.   96  CONTINUE
  2656.       NBNO=IPORE
  2657.       NBBB=NBNN
  2658.       SEGINI WRK1,WRK2,WRK3,WRK6
  2659. C
  2660. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  2661. C
  2662.       DO  3096 IB=1,NBELEM
  2663.       KERRE=0
  2664. C
  2665. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2666. C
  2667.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2668.       CALL ZERO (REL,LRE,LRE)
  2669. *
  2670.       XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+
  2671.      .   (XE(3,2)-XE(3,1))**2
  2672.       XL=SQRT(XL)
  2673.       IF(XL.EQ.0.D0) THEN
  2674.         KERRE=1
  2675.         GO TO 3096
  2676.       ENDIF
  2677. C
  2678. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  2679. C     ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT
  2680. C     VX VY VZ sont supposes etre a la fin
  2681. C
  2682. **    write(6,*) 'rigi4 en 2695'
  2683.       MPTVAL=IVACAR
  2684.       DO 6096 IC=1,NCARR
  2685.         IF (IVAL(IC).NE.0) THEN
  2686.           MELVAL=IVAL(IC)
  2687.           IBMN=MIN(IB,VELCHE(/2))
  2688.           WORK(IC)=VELCHE(1,IBMN)
  2689.         ELSE
  2690.           WORK(IC)=0.D0
  2691.         ENDIF
  2692.  6096 CONTINUE
  2693. C
  2694. C     TRAITEMENT DU VECTEUR
  2695. C
  2696. **      IF (IVAL(NCARR).NE.0) THEN
  2697. **        MELVAL=IVAL(NCARR)
  2698. **        IBMN=MIN(IB,IELCHE(/2))
  2699. **        IP=IELCHE(1,IBMN)
  2700. **        IREF=(IP-1)*(IDIM+1)
  2701. **        DO 6196 IC=1,IDIM
  2702. **          WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  2703. *6196     CONTINUE
  2704. **      ELSE
  2705. **        DO 6296 IC=1,IDIM
  2706. **          WORK(NCARR+IC-1)=0.D0
  2707. *6296     CONTINUE
  2708. **      ENDIF
  2709. C
  2710. C     CALCUL DU REPERE LOCAL
  2711. C
  2712.       CALL TUYPAS(XE,XL,WORK,PSS,KERRE)
  2713.       IF(KERRE.NE.0) THEN
  2714.          INTERR(1)=IB
  2715.          CALL ERREUR(5 )
  2716.          RETURN
  2717.       ENDIF
  2718. C
  2719. C     BOUCLE SUR LES POINTS DE GAUSS
  2720. C
  2721.       DO 4096  IGAU=1,NBPGAU
  2722. C
  2723. C     TRAITEMENT DU MATERIAU
  2724. C     IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE
  2725. C
  2726.       MPTVAL=IVAMAT
  2727.       IF(IMAT.EQ.2) THEN
  2728.         MELVAL=IVAL(1)
  2729.         IGMN=MIN(IGAU,VELCHE(/1))
  2730.         IBMN=MIN(IB  ,IELCHE(/2))
  2731.         MLREEL=IELCHE(IGMN,IBMN)
  2732.         SEGACT MLREEL
  2733.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2734.      .      CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2735.         SEGDES MLREEL
  2736. *
  2737.       ELSE IF (IMAT.EQ.1) THEN
  2738. *
  2739.         DO 9096 IM=1,NMATT
  2740.           IF (IVAL(IM).NE.0) THEN
  2741.             MELVAL=IVAL(IM)
  2742.             IGMN=MIN(IGAU,VELCHE(/1))
  2743.             IBMN=MIN(IB  ,VELCHE(/2))
  2744.             VALMAT(IM)=VELCHE(IGMN,IBMN)
  2745.           ELSE
  2746.             VALMAT(IM)=0.D0
  2747.           ENDIF
  2748.  9096   CONTINUE
  2749.         CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2750.         EPAIST=WORK(1)
  2751.         CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  2752.       ENDIF
  2753. *
  2754. *     CALCUL DE LA MATRICE B ET DU JACOBIEN
  2755. *
  2756.       CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE)
  2757.       DJAC=DJAC*POIGAU(IGAU)
  2758. *
  2759.       IF(KERRE.NE.0) THEN
  2760.          INTERR(1)=IB
  2761.          CALL ERREUR(5)
  2762.       ENDIF
  2763. *
  2764. *     CALCUL ET INTEGRATION DE BTDB
  2765. *
  2766.       CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL)
  2767.  4096 CONTINUE
  2768. *
  2769. *    CHANGEMENT DE BASE
  2770. *
  2771.       CALL TUYROT(REL,LRE,PSS,1)
  2772. *
  2773. *      SEGINI XMATRI
  2774. *      IMATTT(IB)=XMATRI
  2775. C
  2776. C     REMPLISSAGE DE XMATRI
  2777. C
  2778.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2779. *      SEGDES XMATRI
  2780.  3096 CONTINUE
  2781.       IF(KERRE.EQ.1) CALL ERREUR(128)
  2782.       IF(KERRE.EQ.2) CALL ERREUR(138)
  2783.       IF(IRTD.EQ.0) THEN
  2784.         MOTERR(1:8)=CMATE
  2785.         MOTERR(9:16)=NOMFR(MFR/2+1)
  2786.        INTERR(1)=IFOUR
  2787.        CALL ERREUR(81)
  2788.        return
  2789.       ENDIF
  2790.       SEGDES XMATRI
  2791.       SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH
  2792.       GOTO 510
  2793. C_______________________________________________________________________
  2794. C
  2795. C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES  QUAH
  2796. C_______________________________________________________________________
  2797. C
  2798.  126  CONTINUE
  2799. C
  2800.       NBNO=NBNN
  2801.       NBBB=NBNN
  2802.       LRN =NBNN+NBNN
  2803.       NSTN=2
  2804.       SEGINI WRK1,WRK2 ,WRK5
  2805.       I195=0
  2806.       DO 3126  IB=1,NBELEM
  2807. C
  2808. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2809. C
  2810.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2811.       CALL ZERO (REL,LRE,LRE)
  2812. *
  2813.         MPTVAL=IVAMAT
  2814.         DO 9126 IM=1,10
  2815.           IF (IVAL(IM).NE.0) THEN
  2816.             MELVAL=IVAL(IM)
  2817.             IBMN=MIN(IB  ,VELCHE(/2))
  2818.             VALMAT(IM)=VELCHE(1,IBMN)
  2819.           ELSE
  2820.             VALMAT(IM)=0.D0
  2821.  
  2822.           ENDIF
  2823.  9126   CONTINUE
  2824. C
  2825. C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2826. C
  2827.       RHOF  =VALMAT(4)
  2828.  
  2829.       E     =VALMAT(6)
  2830.  
  2831.       C     =VALMAT(7)
  2832.  
  2833.       RHOREF=VALMAT(8)
  2834.  
  2835.       CREF  =VALMAT(9)
  2836.  
  2837.       RLCAR =VALMAT(10)
  2838.  
  2839. C
  2840. C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2841. C
  2842.       MPTVAL=IVACAR
  2843.         MELVAL=IVAL(1)
  2844.           IBMN=MIN(IB,VELCHE(/2))
  2845.           SCEL  =VELCHE(1,IBMN)
  2846.  
  2847.         MELVAL=IVAL(2)
  2848.           IBMN=MIN(IB,VELCHE(/2))
  2849.           SFLU  =VELCHE(1,IBMN)
  2850.  
  2851.         MELVAL=IVAL(3)
  2852.           IBMN=MIN(IB,VELCHE(/2))
  2853.           EPS   =VELCHE(1,IBMN)
  2854.  
  2855.         MELVAL=IVAL(5)
  2856.           IBMN=MIN(IB,VELCHE(/2))
  2857.           XINERT=VELCHE(1,IBMN)
  2858.           EI = E*XINERT/(EPS*EPS)
  2859. C
  2860. C     CALCUL DES COEFFICIENTS DE NORMALISATION
  2861. C
  2862.       COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2863.       VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2864.       VKL2  = EI/SCEL
  2865. C
  2866. C
  2867. C     BOUCLE SUR LES POINTS DE GAUSS
  2868. C
  2869.       ISDJC=0
  2870.       DO 4126  IGAU=1,NBPGAU
  2871.       CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2872.      #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2873.       IF(IRRT.NE.1) GOTO 5126
  2874.       DJAC=DJAC*POIGAU(IGAU)
  2875.       CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2876.  4126 CONTINUE
  2877.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2878. *      SEGINI XMATRI
  2879. *      IMATTT(IB)=XMATRI
  2880. C
  2881. C     REMPLISSAGE DE XMATRI
  2882. C
  2883.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2884. *      SEGDES XMATRI
  2885.  3126 CONTINUE
  2886. C
  2887. C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
  2888. C
  2889.  5126 CONTINUE
  2890.       IF(IRRT.EQ.0) THEN
  2891.       MOTERR(1:4)=NOMTP(MELE)
  2892.       CALL ERREUR(420)
  2893.       ELSE
  2894.       IF(IRRT.EQ.2) THEN
  2895.       INTERR(1)=IB
  2896.       CALL ERREUR(405)
  2897.       ENDIF
  2898.       ENDIF
  2899.       IF(I195.NE.0) INTERR(1)=I195
  2900.       IF(I195.NE.0) CALL ERREUR(195)
  2901.       SEGDES XMATRI
  2902.       SEGSUP WRK1,WRK2,WRK5,MVELCH
  2903.       GOTO 510
  2904. C_______________________________________________________________________
  2905. C
  2906. C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES  CUBH
  2907. C_______________________________________________________________________
  2908. C
  2909.  127  CONTINUE
  2910.       NBNO=NBNN
  2911.       NBBB=NBNN
  2912.       LRN =NBNN*2
  2913.       NSTN=2
  2914. C
  2915.       SEGINI WRK1,WRK2 ,WRK5
  2916.       I195=0
  2917.       DO 3127  IB=1,NBELEM
  2918. C
  2919. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2920. C
  2921.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2922.       CALL ZERO (REL,LRE,LRE)
  2923. *
  2924.         MPTVAL=IVAMAT
  2925.         DO 9127 IM=1,10
  2926.           IF (IVAL(IM).NE.0) THEN
  2927.             MELVAL=IVAL(IM)
  2928.             IBMN=MIN(IB  ,VELCHE(/2))
  2929.             VALMAT(IM)=VELCHE(1,IBMN)
  2930.           ELSE
  2931.             VALMAT(IM)=0.D0
  2932.  
  2933.           ENDIF
  2934.  9127   CONTINUE
  2935. C
  2936. C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2937. C
  2938.       RHOF  =VALMAT(4)
  2939.  
  2940.       E     =VALMAT(6)
  2941.  
  2942.       C     =VALMAT(7)
  2943.  
  2944.       RHOREF=VALMAT(8)
  2945.  
  2946.       CREF  =VALMAT(9)
  2947.  
  2948.       RLCAR =VALMAT(10)
  2949. C
  2950. C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2951. C
  2952.       MPTVAL=IVACAR
  2953.         MELVAL=IVAL(1)
  2954.           IBMN=MIN(IB,VELCHE(/2))
  2955.           SCEL  =VELCHE(1,IBMN)
  2956.  
  2957.         MELVAL=IVAL(2)
  2958.           IBMN=MIN(IB,VELCHE(/2))
  2959.           SFLU  =VELCHE(1,IBMN)
  2960.  
  2961.         MELVAL=IVAL(3)
  2962.           IBMN=MIN(IB,VELCHE(/2))
  2963.           EPS   =VELCHE(1,IBMN)
  2964.  
  2965.         MELVAL=IVAL(5)
  2966.           IBMN=MIN(IB,VELCHE(/2))
  2967.           XINERT=VELCHE(1,IBMN)
  2968.         EI = E*XINERT/(EPS*EPS)
  2969. C
  2970. C     CALCUL DES COEFFICIENTS DE NORMALISATION
  2971. C
  2972.       COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2973.       VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2974.       VKL2  = EI/SCEL
  2975. C
  2976. C     BOUCLE SUR LES POINTS DE GAUSS
  2977. C
  2978.       ISDJC=0
  2979.       DO 4127  IGAU=1,NBPGAU
  2980.       CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT,
  2981.      #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2982.       IF(IRRT.NE.1) GOTO 5127
  2983.       DJAC=DJAC*POIGAU(IGAU)
  2984. C
  2985. C
  2986.       CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2987.  4127 CONTINUE
  2988.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2989. *      SEGINI XMATRI
  2990. *      IMATTT(IB)=XMATRI
  2991. C
  2992. C     REMPLISSAGE DE XMATRI
  2993. C
  2994.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  2995. *      SEGDES XMATRI
  2996.  3127 CONTINUE
  2997. C
  2998. C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
  2999. C
  3000.  5127 CONTINUE
  3001.       IF(IRRT.EQ.0) THEN
  3002.       MOTERR(1:4)=NOMTP(MELE)
  3003.       CALL ERREUR(420)
  3004.       ELSE
  3005.       IF(IRRT.EQ.2) THEN
  3006.       INTERR(1)=IB
  3007.       CALL ERREUR(405)
  3008.       ENDIF
  3009.       ENDIF
  3010.       IF(I195.NE.0) INTERR(1)=I195
  3011.       IF(I195.NE.0) CALL ERREUR(195)
  3012.       SEGDES XMATRI
  3013.       SEGSUP WRK1,WRK2,WRK5,MVELCH
  3014.       GOTO 510
  3015.  
  3016. C_______________________________________________________________________
  3017. C
  3018. C     ELEMENTS  CIFL   MACRO ELEMENT CISAILLEMENT FLEXION
  3019. C
  3020. C_______________________________________________________________________
  3021. C
  3022.  258  CONTINUE
  3023.       NBNO=NBNN
  3024.       NBBB=NBNN
  3025.       SEGINI WRK1,WRK2,WRK3,WRK4
  3026. C
  3027. C     BOUCLE POUR TOUS LES ELEMENTS
  3028. C
  3029.       DO IB=1,NBELEM
  3030. C
  3031. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  3032. C
  3033.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  3034. C
  3035.         CALL ZERO (REL,LRE,LRE)
  3036. C
  3037. C     PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  3038. C
  3039.          CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
  3040. C
  3041. C     CALCUL DE LA MATRICE DE HOOK
  3042. C
  3043.           MPTVAL=IVAMAT
  3044.           IF(IMAT.EQ.2) THEN
  3045.               MELVAL=IVAL(1)
  3046.               IGMN=MIN(1,IELCHE(/1))
  3047.               MLREEL=IELCHE(IGMN,IBMN)
  3048.               SEGACT MLREEL
  3049.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  3050.      1         CALL DOHOOO(PROG,LHOOK,DDHOOK)
  3051.               SEGDES MLREEL
  3052.           ELSE IF (IMAT.EQ.1) THEN
  3053.               DO IM=1,NMATT
  3054.                 IF (IVAL(IM).NE.0) THEN
  3055.                   MELVAL=IVAL(IM)
  3056.                   IBMN=MIN(IB  ,VELCHE(/2))
  3057.                   VALMAT(IM)=VELCHE(1,IBMN)
  3058.                 ELSE
  3059.                   VALMAT(IM)=0.D0
  3060.                 ENDIF
  3061.               ENDDO
  3062. C
  3063.               MPTVAL=IVACAR
  3064.               DO IC=1,NCARR
  3065.                 IF (IVAL(IC).NE.0) THEN
  3066.                   MELVAL=IVAL(IC)
  3067.                   IBMN=MIN(IB,VELCHE(/2))
  3068.                   WORK(IC)=VELCHE(1,IBMN)
  3069.                 ELSE
  3070.                   WORK(IC)=0.D0
  3071.                 ENDIF
  3072.               ENDDO
  3073. C
  3074.               CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  3075.           ENDIF
  3076. C
  3077. C     CALCUL ET INTEGRATION DE BDB
  3078. C
  3079.           DDHOOK(1,1)=DDHOOK(1,1)/(XH/2)
  3080.           DDHOOK(2,2)=DDHOOK(2,2)/(XH/2)
  3081.           DDHOOK(3,3)=DDHOOK(3,3)/ XH
  3082.           DDHOOK(4,4)=DDHOOK(4,4)/(XH/2)
  3083.           DDHOOK(5,5)=DDHOOK(5,5)/(XH/2)
  3084.           CALL BDBST(BGENE,1.D0,DDHOOK,LRE,NSTRS,REL)
  3085. C
  3086. *        SEGINI XMATRI
  3087. *        IMATTT(IB)=XMATRI
  3088. C
  3089. C     REMPLISSAGE DE XMATRI
  3090. C
  3091.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  3092. *        SEGDES XMATRI
  3093.       ENDDO
  3094. C
  3095.       SEGDES XMATRI
  3096.       SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH
  3097.       GOTO 510
  3098. C_______________________________________________________________________
  3099. C
  3100. C   ELEMENT DE COQUE VOLUMIQUE SHB8
  3101. C_______________________________________________________________________
  3102. C
  3103.   260 CONTINUE
  3104.       NBNO=NBNN
  3105.       NBBB=NBNN
  3106.       SEGINI WRK1,WRK2,WRK4,WRK7,MVELCH
  3107. C
  3108. C     BOUCLE POUR TOUS LES ELEMENTS
  3109. C
  3110.        DO IB=1,NBELEM
  3111. C
  3112. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  3113. C
  3114.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  3115. C
  3116.         CALL ZERO (REL,LRE,LRE)
  3117.  
  3118.          MPTVAL=IVAMAT
  3119.          DO 9070 IM=1,NMATT
  3120.           IF (IVAL(IM).NE.0) THEN
  3121.             MELVAL=IVAL(IM)
  3122.             IBMN=MIN(IB  ,VELCHE(/2))
  3123.             VALMAT(IM)=VELCHE(1,IBMN)
  3124.           ELSE
  3125.             VALMAT(IM)=XZERO
  3126.           ENDIF
  3127.  9070   CONTINUE
  3128.  
  3129.          PROPEL(1)=VALMAT(1)
  3130.          PROPEL(2)=VALMAT(2)
  3131.          DO IM=3,12
  3132.           PROPEL(IM)=VALMAT(1)
  3133.          ENDDO
  3134.          PROPEL(13)=XZERO
  3135.          PROPEL(14)=VALMAT(1)
  3136.          WORK1(1)=IB
  3137.  
  3138.          DO IM=1,5
  3139.           REL(IM,1)=XZERO
  3140.          ENDDO
  3141.  
  3142. cbp      loi de comportement a utiliser = 
  3143. c        1 : improved plane-stress constitutive law 
  3144. c            [Abed-Meiram & Combescure, IJNME, 2009]
  3145. c        2 : plane-stress constitutive law
  3146. c        3 : tridimensional constitutive law
  3147. cbp          OUT(1)=3
  3148.          OUT(1)=1
  3149. C
  3150. C     CALCUL DE LA MATRICE DE RIGIDITE
  3151. C
  3152.          call SHB8 (2,XE,DDHOOK,PROPEL,WORK1,REL,OUT)
  3153. C
  3154. *        SEGINI XMATRI
  3155. *        IMATTT(IB)=XMATRI
  3156. C
  3157. C     REMPLISSAGE DE XMATRI
  3158. C
  3159.         CALL REMPMT(REL,LRE,RE(1,1,IB))
  3160. *        SEGDES XMATRI
  3161.       ENDDO
  3162.       SEGDES XMATRI
  3163.       SEGSUP WRK1,WRK2,WRK4,WRK7,MVELCH
  3164.       GOTO 510
  3165. *
  3166. C_______________________________________________________________________
  3167. C
  3168. C   ELEMENTS DE ZONE COHESIVE ZCO2, ZCO3, ZCO4
  3169. C_______________________________________________________________________
  3170. C
  3171.   266 CONTINUE
  3172.  
  3173.       NDIM = 2
  3174.       IF(IFOUR.GT.0) NDIM = 3
  3175.       NBNO=NBNN
  3176.       NBBB=NBNN
  3177.       SEGINI WRK1,WRK2,WRK4
  3178. C
  3179.       DO 3266 IB=1,NBELEM
  3180. C
  3181. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  3182. C
  3183.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  3184. C
  3185.       CALL ZERO (REL,LRE,LRE)
  3186. C
  3187. C  BOUCLE SUR LES POINTS DE GAUSS
  3188. C
  3189.       DO 6266 IGAU=1,NBPGAU
  3190. C
  3191.        CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
  3192. C
  3193.        CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
  3194.      .          NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT)
  3195.        IF (IERT.NE.0) THEN
  3196.          INTERR(1)=IB
  3197.          CALL ERREUR(612)
  3198.          GOTO 99266
  3199.        ENDIF
  3200. C
  3201.       DJAC=DJAC*POIGAU(IGAU)
  3202. C
  3203. C     CALCUL DE LA MATRICE DE HOOKE
  3204. C
  3205.  
  3206.       MPTVAL=IVAMAT
  3207.       IF(IMAT.EQ.2) THEN
  3208.         MELVAL=IVAL(1)
  3209.         IBMN=MIN(IB  ,IELCHE(/2))
  3210.         MLREEL=IELCHE(1,IBMN)
  3211.         SEGACT MLREEL
  3212.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  3213.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  3214.         SEGDES MLREEL
  3215.       ELSE IF (IMAT.EQ.1) THEN
  3216.           DO 9266 IM=1,NMATT
  3217.             IF (IVAL(IM).NE.0) THEN
  3218.               MELVAL=IVAL(IM)
  3219.               IBMN=MIN(IB  ,VELCHE(/2))
  3220.               IGMN=MIN(IGAU,VELCHE(/1))
  3221.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  3222.             ELSE
  3223.               VALMAT(IM)=0.D0
  3224.             ENDIF
  3225.  9266     CONTINUE
  3226.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  3227.      1    CALL DOU266(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  3228.       ENDIF
  3229. C
  3230. C     CALCUL ET INTEGRATION DE BDB
  3231. C
  3232.       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  3233.  6266 CONTINUE
  3234. C
  3235. *      SEGINI XMATRI
  3236. *      IMATTT(IB)=XMATRI
  3237. C
  3238. C     REMPLISSAGE DE XMATRI
  3239. C
  3240.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  3241. *      SEGDES XMATRI
  3242.  3266 CONTINUE
  3243. C
  3244. C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  3245. C
  3246.       IF (IRTD.EQ.0) THEN
  3247.           MOTERR(1:8) = CMATE
  3248.           MOTERR(9:16) = NOMFR(MFR/2+1)
  3249.           INTERR(1) = IFOUR
  3250.           CALL ERREUR(81)
  3251.       ENDIF
  3252. C
  3253. 99266 CONTINUE
  3254.       SEGDES XMATRI
  3255.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  3256.       GOTO 510
  3257. *_______________________________________________________________________
  3258. *
  3259.    99 CONTINUE
  3260.       MOTERR(1:4)=NOMTP(MELE)
  3261.       MOTERR(9:12)='RIGI4'
  3262.       CALL ERREUR(86)
  3263. *
  3264.   510 CONTINUE
  3265.       IF (CMATE.eq.'STATIQUE') THEN
  3266.         mlmots = iinc
  3267.         if (iinc.gt.0) segsup mlmots
  3268.         mlmots = idua
  3269.         if (idua.gt.0) segsup mlmots
  3270.       ENDIF
  3271.       RETURN
  3272.       END
  3273.  
  3274.  
  3275.  
  3276.  
  3277.  
  3278.  
  3279.  
  3280.  
  3281.  
  3282.  
  3283.  
  3284.  

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