Télécharger la plaquette Cast3M


fr en

Télécharger masse4.eso

Retour à la liste

Numérotation des lignes : 

masse4

  1. C MASSE4    SOURCE    OF166741  25/02/21    21:17:59     12166          
  2.  
  3. *---------------------------------------------------------------------*
  4. *         ________________________________                            *
  5. *        |                                |                           *
  6. *        |  calcul de la matrice de masse |                           *
  7. *        |________________________________|                           *
  8. *                                                                     *
  9. *  raccords liquide/massifs,raccords liquide/coque,barre,homogenise   *
  10. *  cerce,joints 2-3d                                                  *
  11. *                                                                     *
  12. *---------------------------------------------------------------------*
  13. *                                                                     *
  14. *   entrees :                                                         *
  15. *   ________                                                          *
  16. *                                                                     *
  17. *        ipmail   pointeur sur un segment  meleme                     *
  18. *        lw       dimension du tableau de travail de l'element        *
  19. *        lre      nombre de ddl dans la matrice de masse              *
  20. *        ivamat   pointeur sur un segment mptval pour le materiau     *
  21. *        nmatt    nombre de composante de materiau (imat=1)           *
  22. *        ivacar   pointeur sur un segment mptval pour les caracteri-  *
  23. *                 stiques                                             *
  24. *        ncarr    nombre de caracteristiques geometriques             *
  25. *        nbpgau   nombre de point d'integration pour la masse         *
  26. *        ipmint   pointeur sur un segment minte                       *
  27. *        ipmin1   pointeur sur un segment minte (aux noeuds)          *
  28. *        nddl     nombre de degre de liberte /noeud                   *
  29. *        mele     numero de l'element fini                            *
  30. *        nbpgmi   nombre de noeuds /element                           *
  31. *        ilump    =1 si l'opeateur LUMP est appele                    *
  32. *                                                                     *
  33. *   sorties :                                                         *
  34. *   ________                                                          *
  35. *                                                                     *
  36. *        ipmatr   pointeur sur la matrice de masse de la sous-zone    *
  37. *                                                                     *
  38. *---------------------------------------------------------------------*
  39.  
  40.       SUBROUTINE MASSE4(IPMAIL,LW,LRE,IVAMAT,NMATT,IVACAR,NCARR,
  41.      &                  NBPGAU,IPMINT,NDDL,MELE,MFR,IPMATR,ILUMP,
  42.      &                  ISOUS,IIPDPG,IMOD)
  43.  
  44.       IMPLICIT INTEGER(I-N)
  45.       IMPLICIT REAL*8(A-H,O-Z)
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC CCHAMP
  50. -INC CCREEL
  51.  
  52. -INC SMRIGID
  53. -INC SMCHAML
  54. -INC SMELEME
  55. -INC SMCOORD
  56. -INC SMINTE
  57. -INC SMMODEL
  58. -INC SMLMOTS
  59.  
  60. -INC TMPTVAL
  61.  
  62.       SEGMENT WRK1
  63.         REAL*8 REL(LRE,LRE),XE(3,NBBB)
  64.       ENDSEGMENT
  65.  
  66.       SEGMENT WRK2
  67.         REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  68.       ENDSEGMENT
  69.  
  70.       SEGMENT WRK3
  71.         REAL*8 WORK(LW)
  72.       ENDSEGMENT
  73.  
  74.       SEGMENT WRK4
  75.         REAL*8 BPSS(3,3),XEL(3,NBBB)
  76.       ENDSEGMENT
  77.  
  78.       SEGMENT WRK5
  79.         REAL*8 XGENE(NCOM,LRN)
  80.       ENDSEGMENT
  81.  
  82.       SEGMENT MVELCH
  83.         REAL*8 VALMAT(NV1)
  84.       ENDSEGMENT
  85.  
  86.       CHARACTER*8 CMATE
  87.       CHARACTER*4 lesinc(7),lesdua(7)
  88.       DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  89.       DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  90.       INTEGER KERRE
  91.  
  92.       MELEME=IPMAIL
  93.       NBNN=NUM(/1)
  94.       NBELEM=NUM(/2)
  95.  
  96.       xMATRI=IPMATR
  97.  
  98.       NV1=NMATT
  99.       SEGINI,MVELCH
  100.  
  101.       KERRE=0
  102.       I195=0
  103.       I259=0
  104.  
  105.       WRK1 = 0
  106.       WRK2 = 0
  107.       WRK3 = 0
  108.       WRK4 = 0
  109.       WRK5 = 0
  110. *
  111. *     introduction du point autour duquel se fait le mouvement
  112. *     de la section en defo plane generalisee
  113. *
  114.       IF (IFOUR.EQ.-3.AND.MFR.NE.35) THEN
  115.         IREF=(IIPDPG-1)*(IDIM+1)
  116.         XDPGE=XCOOR(IREF+1)
  117.         YDPGE=XCOOR(IREF+2)
  118.       ELSE
  119.         XDPGE=0.D0
  120.         YDPGE=0.D0
  121.       ENDIF
  122.  
  123.       NHRM=NIFOUR
  124.  
  125.       MINTE=IPMINT
  126.  
  127.       IMODEL = IMOD
  128.       CMATE = imodel.CMATEE
  129.  
  130.       jmat = 0
  131.       iinc = 0
  132.       idua = 0
  133.  
  134.       DO imat = 1 , matmod(/2)
  135.         if (matmod(imat).eq.'IMPEDANCE') then
  136.           jmat = imat
  137.           goto 45
  138.         endif
  139.       ENDDO
  140.  
  141.       IF (mfr.eq.28) THEN
  142.         jgn = 8
  143.         if (ifour.eq.2) then
  144.         jgm = 6
  145.         segini mlmots
  146.         iinc = mlmots
  147.         do igm = 1,jgm
  148.           mots(igm) = lesinc(igm)
  149.         enddo
  150.         segini mlmots
  151.         idua = mlmots
  152.         do igm= 1,jgm
  153.           mots(igm) = lesdua(igm)
  154.         enddo
  155.         else if (ifour.lt.0) then
  156.         jgm = 4
  157.         segini mlmots
  158.         iinc = mlmots
  159.         mots(1) = lesinc(1)
  160.         mots(2) = lesinc(2)
  161.         mots(3) = lesinc(4)
  162.         mots(4) = lesinc(5)
  163.         segini mlmots
  164.         idua = mlmots
  165.         mots(1) = lesdua(1)
  166.         mots(2) = lesdua(2)
  167.         mots(3) = lesdua(4)
  168.         mots(4) = lesdua(5)
  169.         else if (ifour.eq.0) then
  170.         jgm = 3
  171.         segini mlmots
  172.         iinc = mlmots
  173.         mots(1) = lesinc(7)
  174.         mots(2) = lesinc(3)
  175.         mots(3) = lesinc(6)
  176.         segini mlmots
  177.         idua = mlmots
  178.         mots(1) = lesdua(7)
  179.         mots(2) = lesdua(3)
  180.         mots(3) = lesdua(6)
  181.         else if (ifour.eq.1) then
  182. * a faire
  183.         endif
  184.       ENDIF
  185.  
  186. c     numero des etiquettes      :
  187. c     etiquettes de 1 a 98 pour traitement specifique a l element
  188. c     dans la zone specifique a chaque element commencant par :
  189. c     5  continue
  190. c     element 5   etiquettes 1005 2005 3005 4005   ...
  191. c     44 continue
  192. c     element 44  etiquettes 1044 2044 3044 4044   ...
  193. c_______________________________________________________________________
  194.  
  195. *                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  196.             GOTO (  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  197. *                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  198.      &           ,  12,  99,  99,  99,  99,  99,  18,  18,  99,  99,  99
  199. *                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
  200.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  201. *                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  202.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  203. *                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  204.      &           ,  45,  46,  47,  99,  99,  99,  99,  99,  99,  99,  55
  205. *                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  206.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  207. *                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  208.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  209. *                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  210.      &           ,  99,  99,  99,  99,  99,  99,  99,  85,  99,  87,  88
  211. *                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
  212.      &           ,  99,  99,  99,  92,  99,  94,  46,  99,  99,  12,  99
  213. *                 HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  214.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  215. *                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  216.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  217. *                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  218.      &           ,  99,  46, 124,  99, 126, 127,  99,  99,  99,  99,  99
  219. *                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  220.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  221. *                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  222.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  223. *                 TE56 PY91 TRH6
  224.      &           ,  99,  99, 157),MELE
  225. *
  226.       GOTO(168,169,170,171,172),MELE-167
  227. *
  228. *          JOI1
  229.       GOTO(265),MELE-264
  230.  
  231. C--- CAS NON PREVUS ICI-------------------------------------------------
  232.  99   CONTINUE
  233.       MOTERR(1:4)=NOMTP(MELE)
  234.       MOTERR(5:12)='MASSE4'
  235.       CALL ERREUR(86)
  236.       GOTO 510
  237. c_______________________________________________________________________
  238.  
  239. c     secteur de calcul pour les elements de raccord   rac2 rac3 litu
  240. c        liquide massif lineaire   cas bidimensionnel
  241. c_______________________________________________________________________
  242.   12  CONTINUE
  243.       IF (ILUMP .EQ. 1) GOTO 99
  244.       NBBB=NBNN
  245.       IF (MELE.NE.98) LW=IDIM
  246.       SEGINI WRK1,WRK3
  247.       DO 3012 IB=1,NBELEM
  248.  
  249. c     on cherche les coordonnees de l element ib
  250.  
  251.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  252.         CALL ZERO(REL,LRE,LRE)
  253.  
  254. c     calcul des coefficients de normalisation
  255.  
  256.         MPTVAL=IVAMAT
  257.         IF (MELE.NE.98) THEN
  258.  
  259.               DO 5012 IM=1,NMATT
  260.                   MELVAL=IVAL(IM)
  261.                   IBMN=MIN(IB,VELCHE(/2))
  262.                   VALMAT(IM)=VELCHE(1,IBMN)
  263.  5012         CONTINUE
  264.               RHOREF=VALMAT(1)
  265.               RLCAR = VALMAT(2)
  266.  
  267.               CFPI= RHOREF*RLCAR
  268.  
  269.         ELSE
  270.  
  271. c cas de l'element litu
  272.  
  273.               DO 7012 IM=1,NMATT
  274.                   MELVAL=IVAL(IM)
  275.                   IBMN=MIN(IB,VELCHE(/2))
  276.                   WORK(IM+9)=VELCHE(1,IBMN)
  277.  7012         CONTINUE
  278.         ENDIF
  279.  
  280. c lecture des caracteristiques dans work
  281.  
  282.         MPTVAL=IVACAR
  283.         DO 4012 IC=1,NCARR
  284.           IF (IVAL(IC).NE.0) THEN
  285.                   MELVAL=IVAL(IC)
  286.                   IBMN=MIN(IB,VELCHE(/2))
  287.                   WORK(IC)=VELCHE(1,IBMN)
  288.               ELSE
  289.                   WORK(IC)=0.D0
  290.               ENDIF
  291.  4012   CONTINUE
  292.  
  293.           IF (MELE.EQ.98) THEN
  294.               CALL COUMAS(REL,LRE,WORK,XE,KERRE)
  295.           ELSE
  296.               CALL RACMAS(NBPGAU,IFOUR,NIFOUR,IDIM,NBNN,XE,CFPI,WORK,
  297.      1        POIGAU,SHPTOT,REL,LRE)
  298.           ENDIF
  299.  
  300. c        remplissage de xmatri
  301.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  302.  
  303.  3012 CONTINUE
  304.       GOTO 510
  305. c_______________________________________________________________________
  306.  
  307. c  secteur de calcul pour les elements de raccord   lia3 lia4
  308. c         liquide massif lineaire    cas tridimensionnel
  309. c_______________________________________________________________________
  310.  
  311.   18  CONTINUE
  312.       IF (ILUMP .EQ. 1) GOTO 99
  313.       NBBB=NBNN
  314.       LW=IDIM
  315.       SEGINI WRK1,WRK3
  316.       DO 3018 IB=1,NBELEM
  317.  
  318. c        on cherche les coordonnees de l element ib
  319.  
  320.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  321.           CALL ZERO(REL,LRE,LRE)
  322.  
  323. c        calcul des coefficients de normalisation
  324.  
  325.           MPTVAL=IVAMAT
  326.           DO 5018 IM=1,NMATT
  327.               MELVAL=IVAL(IM)
  328.               IBMN=MIN(IB,VELCHE(/2))
  329.               VALMAT(IM)=VELCHE(1,IBMN)
  330.  5018     CONTINUE
  331.           RHOREF=VALMAT(1)
  332.           RLCAR = VALMAT(2)
  333.  
  334.           CFPI= RHOREF*RLCAR
  335.  
  336.           MPTVAL=IVACAR
  337.           DO 4018 IC=1,NCARR
  338.               IF (IVAL(IC).NE.0) THEN
  339.                   MELVAL=IVAL(IC)
  340.                   IBMN=MIN(IB,VELCHE(/2))
  341.                   WORK(IC)=VELCHE(1,IBMN)
  342.               ELSE
  343.                   WORK(IC)=0.D0
  344.               ENDIF
  345.  4018     CONTINUE
  346.  
  347.           CALL LIAMAS(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  348.      1    SHPTOT,REL,LRE,IER246)
  349.           IF(IER246.NE.0) THEN
  350.               CALL ERREUR(IER246)
  351.               GOTO 510
  352.           ENDIF
  353.  
  354. c        remplissage de xmatri
  355.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  356.  
  357.  3018 CONTINUE
  358.       GOTO 510
  359. c_______________________________________________________________________
  360.  
  361. c     impedance
  362. c_______________________________________________________________________
  363.  
  364.   45  CONTINUE
  365.       IF (jmat.gt.0) THEN
  366.         MPTVAL=IVAMAT
  367.         MELVAL=IVAL(1)
  368.         if (ival(/1).gt.1) then
  369.           melva1 = ival(2)
  370.         else
  371.           melva1 = 0
  372.         endif
  373.         jddl = LRE/NBPGAU
  374.         DO IB = 1,NBELEM
  375.           JDIAG = 0
  376.           XMASS = 0.D0
  377.           if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2))
  378.          do IG = 1, NBPGAU
  379.            if (melval.gt.0) then
  380.              igmn = MIN(IG,VELCHE(/1))
  381.              XMASS=VELCHE(IGMN,IBMN)
  382.            endif
  383.            XINER = XMASS
  384.               if (melva1.gt.0) then
  385.                 igmn = MIN(IG,melva1.VELCHE(/1))
  386.                 XINER = melva1.VELCHE(IGMN,IBMN)
  387.               endif
  388.              do idl = 1,jddl
  389.               JDIAG = JDIAG + 1
  390.               RE(JDIAG,JDIAG,ib) = XMASS
  391.               if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINER
  392.               if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINER
  393.              enddo
  394.          enddo
  395.         ENDDO
  396.         GOTO 510
  397.       ENDIF
  398.  
  399.        IF (MFR.EQ.26) THEN
  400. * MODAL (car goto 510 sous IMPEDANCE)
  401.         MPTVAL=IVAMAT
  402.         MELVAL=IVAL(2)
  403.         DO IB = 1,NBELEM
  404.           IBMN=MIN(IB,VELCHE(/2))
  405.           RE(1,1,ib) = VELCHE(1,IBMN)
  406.         ENDDO
  407. *
  408.       ELSE IF (MFR.EQ.28) THEN
  409. * STATIQUE (car goto 510 sous IMPEDANCE)
  410.         MPTVAL=IVAMAT
  411.         DO IB = 1,NBELEM
  412.           MELVAL=IVAL(1)
  413.           IBMN=MIN(IB,IELCHE(/2))
  414.           idepl=IELCHE(1,IBMN)
  415.           MELVAL=IVAL(3)
  416.           IBMN=MIN(IB,IELCHE(/2))
  417.           imade=IELCHE(1,IBMN)
  418.           CALL XTY1(idepl,imade,iinc,idua,X1)
  419.           re(1,1,ib) = x1
  420.         ENDDO
  421.       ENDIF
  422.       GOTO 510
  423.  
  424. c_______________________________________________________________________
  425.  
  426. c     element point (poi1) en defos planes generalisees
  427. c_______________________________________________________________________
  428.  
  429.       IF(MELE.EQ.45.AND.IFOUR.NE.-3) GOTO 99
  430.       NBBB=NBNN
  431.       SEGINI WRK1,WRK3
  432.  
  433. c     boucle de calcul pour les differents elements
  434.  
  435.       DO 3045 IB=1,NBELEM
  436.  
  437. c        on cherche les coordonnees de l element ib
  438.  
  439.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  440.  
  441. c     on recherche rho et la section
  442.  
  443.           MPTVAL=IVAMAT
  444.           MELVAL=IVAL(1)
  445.           IBMN=MIN(IB,VELCHE(/2))
  446.           RR=VELCHE(1,IBMN)
  447.           MPTVAL=IVACAR
  448.           MELVAL=IVAL(1)
  449.           IBMN=MIN(IB,VELCHE(/2))
  450.           RR=RR*VELCHE(1,IBMN)
  451.  
  452. c        on calcule la matrice de masse
  453.  
  454.           CALL PO1MAS(XE,XDPGE,YDPGE,RR,LRE,REL)
  455.  
  456.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  457.  
  458.  3045 CONTINUE
  459.       GO TO 510
  460. c_______________________________________________________________________
  461.  
  462. c     elements barre et cerce
  463. c_______________________________________________________________________
  464.  
  465.   46  CONTINUE
  466. *
  467.       IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) GOTO 99
  468. *
  469.       NBBB=NBNN
  470.       SEGINI WRK1,WRK3
  471.       IF(MELE.EQ.123) THEN
  472.           NCOM=NBNN
  473.           LRN =LRE
  474.           SEGINI WRK5
  475.       ENDIF
  476.  
  477. c     boucle de calcul pour les differents elements
  478.  
  479.       DO 3046 IB=1,NBELEM
  480.  
  481. c        on cherche les coordonnees de l element ib
  482.  
  483.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  484.  
  485.           MPTVAL=IVAMAT
  486.           MELVAL=IVAL(1)
  487.           IBMN=MIN(IB,VELCHE(/2))
  488.           RR=VELCHE(1,IBMN)
  489.           MPTVAL=IVACAR
  490.           MELVAL=IVAL(1)
  491.           IBMN=MIN(IB,VELCHE(/2))
  492.           RR=RR*VELCHE(1,IBMN)
  493.  
  494. c        on calcule la matrice de masse
  495.  
  496.           IF(MELE.EQ.46)  CALL BARMAS(REL,LRE,RR,XE)
  497.           IF(MELE.EQ.95)  CALL CERMAS(REL,LRE,RR,XE)
  498.           IF(MELE.EQ.123) CALL MASBA3(REL,LRE,RR,XE,XGENE,KERRE)
  499.           IF (KERRE.NE.0) THEN
  500.             INTERR(1)=ISOUS
  501.             INTERR(2)=IB
  502.             IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  503.             GOTO 510
  504.           ENDIF
  505.  
  506.           IF (ILUMP .EQ. 1) THEN
  507.               CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  508.           ELSE
  509.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  510.           ENDIF
  511.  3046 CONTINUE
  512.       GO TO 510
  513. c_______________________________________________________________________
  514.  
  515. c     JOINT UNIDIMENSIONNEL JOI1
  516. c_______________________________________________________________________
  517.  
  518.   265  CONTINUE
  519.  
  520.       NBBB=NBNN
  521.       SEGINI WRK1,WRK3,WRK4
  522.  
  523.       IAW1=101
  524.       IAW2=IAW1+LRE*LRE
  525.       IAW3=IAW2+LRE*LRE
  526.       IAW4=IAW3+LRE*LRE
  527.  
  528.       MPTVAL=IVAMAT
  529.  
  530.       DO 3265 IB=1,NBELEM
  531.  
  532.         DO IC=1,NMATT
  533.           IF (IVAL(IC).NE.0) THEN
  534.             MELVAL=IVAL(IC)
  535.             IBMN=MIN(IB,VELCHE(/2))
  536.             WORK(IC)=VELCHE(1,IBMN)
  537.           ELSE
  538.             WORK(IC)=0.D0
  539.           ENDIF
  540.         END DO
  541.  
  542.         CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  543.  
  544. c        on calcule la matrice de masse localement
  545.  
  546.         CALL JOIMAS(REL,LRE,WORK,NMATT,IDIM)
  547.  
  548. c        on passe en repère global
  549.  
  550.         CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
  551.      &              WORK(IAW3),WORK(IAW4),LRE,IDIM)
  552.  
  553.         IF (ILUMP .EQ. 1) THEN
  554.           CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  555.         ELSE
  556.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  557.         ENDIF
  558.  3265 CONTINUE
  559.       GO TO 510
  560. c_______________________________________________________________________
  561.  
  562. c     element barre 3d excentre (baex)
  563. c_______________________________________________________________________
  564.  
  565.  124  CONTINUE
  566.       NBBB=NBNN
  567.       NCOM=2
  568.       LRN =LRE
  569.       SEGINI WRK1,WRK3,WRK5
  570.  
  571. c     boucle de calcul pour les differents elements
  572.  
  573.       DO 3199 IB=1,NBELEM
  574.  
  575. c  on recupere la section de l'element, ses excentrements et son
  576. c  orientation. les caracteristiques sont rangees dans work
  577. c  selon l'ordre suivant: sect excz excy vx vy vz
  578.  
  579.           MPTVAL=IVACAR
  580.           DO IC=1,NCARR
  581.           IF(IVAL(IC).NE.0) THEN
  582.               MELVAL=IVAL(IC)
  583.               IBMN=MIN(IB,VELCHE(/2))
  584.               WORK(IC)=VELCHE(1,IBMN)
  585.           ELSE
  586.               WORK(IC)=0.D0
  587.           ENDIF
  588.           END DO
  589.           SECT=WORK(1)
  590.  
  591. c   xgene  stocke la matrice de passage de l'element excentre
  592.  
  593.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  594.           CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  595.           IF (KERRE.NE.0) THEN
  596.             INTERR(1)=ISOUS
  597.             INTERR(2)=IB
  598.             IF (KERRE.EQ.1) CALL ERREUR(128)
  599.           ENDIF
  600.  
  601.           MPTVAL=IVAMAT
  602.           MELVAL=IVAL(1)
  603.           IBMN=MIN(IB,VELCHE(/2))
  604.           RR=VELCHE(1,IBMN)*SECT
  605.  
  606. c        on calcule la matrice de masse
  607.  
  608.           CALL BAMAEX(REL,LRE,RR,AL,XGENE)
  609.  
  610.           IF (ILUMP .EQ. 1) THEN
  611.               CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  612.           ELSE
  613.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  614.           ENDIF
  615.  3199 CONTINUE
  616.       GO TO 510
  617. c_______________________________________________________________________
  618.  
  619. c     secteur de calcul pour les elements de raccord
  620. c        liquide coque             cas bidimensionnel
  621. c_______________________________________________________________________
  622.  
  623.   47  CONTINUE
  624.       IF (ILUMP .EQ. 1) GOTO 99
  625.       NBBB=NBNN
  626.       LW=IDIM
  627.       SEGINI WRK1,WRK3
  628.       DO 3047 IB=1,NBELEM
  629.  
  630. c        on cherche les coordonnees de l element ib
  631.  
  632.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  633.           CALL ZERO(REL,LRE,LRE)
  634.  
  635. c        calcul des coefficients de normalisation
  636.  
  637.           MPTVAL=IVAMAT
  638.           DO 5047 IM=1,NMATT
  639.               MELVAL=IVAL(IM)
  640.               IBMN=MIN(IB,VELCHE(/2))
  641.               VALMAT(IM)=VELCHE(1,IBMN)
  642.  5047     CONTINUE
  643.           RHOREF=VALMAT(1)
  644.           RLCAR = VALMAT(2)
  645.  
  646.           CFPI= RHOREF*RLCAR
  647.  
  648.           MPTVAL=IVACAR
  649.           DO 4047 IC=1,NCARR
  650.               IF (IVAL(IC).NE.0) THEN
  651.                   MELVAL=IVAL(IC)
  652.                   IBMN=MIN(IB,VELCHE(/2))
  653.                   WORK(IC)=VELCHE(1,IBMN)
  654.               ELSE
  655.                   WORK(IC)=0.D0
  656.               ENDIF
  657.  4047     CONTINUE
  658.  
  659.           CALL RACOMA(IFOUR,NIFOUR,IDIM,XE,CFPI,WORK,REL,LRE)
  660.  
  661. c        remplissage de xmatri
  662.  
  663.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  664.  
  665.  3047 CONTINUE
  666.       GOTO 510
  667. c_______________________________________________________________________
  668.  
  669. c     secteur de calcul pour les elements de raccord
  670. c      liquide coque 3 noeuds - cas tridimensionnel
  671. c_______________________________________________________________________
  672.  
  673.   55  CONTINUE
  674.       IF (ILUMP .EQ. 1) GOTO 99
  675.       NBBB=NBNN
  676.       LW=IDIM
  677.       SEGINI WRK1,WRK3
  678.       DO 3055 IB=1,NBELEM
  679.  
  680. c        on cherche les coordonnees de l element ib
  681.  
  682.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  683.           CALL ZERO(REL,LRE,LRE)
  684.  
  685. c        calcul des coefficients de normalisation
  686.  
  687.           MPTVAL=IVAMAT
  688.           DO 5055 IM=1,NMATT
  689.               MELVAL=IVAL(IM)
  690.               IBMN=MIN(IB,VELCHE(/2))
  691.               VALMAT(IM)=VELCHE(1,IBMN)
  692.  5055     CONTINUE
  693.           RHOREF=VALMAT(1)
  694.           RLCAR = VALMAT(2)
  695.  
  696.           CFPI= RHOREF*RLCAR
  697.  
  698.           MPTVAL=IVACAR
  699.           DO 4055 IC=1,NCARR
  700.               IF (IVAL(IC).NE.0) THEN
  701.                   MELVAL=IVAL(IC)
  702.                   IBMN=MIN(IB,VELCHE(/2))
  703.                   WORK(IC)=VELCHE(1,IBMN)
  704.               ELSE
  705.                   WORK(IC)=0.D0
  706.               ENDIF
  707.  4055     CONTINUE
  708.  
  709.           CALL LICOMA(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  710.      1    QSIGAU,ETAGAU,SHPTOT,REL,LRE,IER246)
  711.           IF (IER246.NE.0) THEN
  712.               CALL ERREUR(IER246)
  713.               GOTO 510
  714.           ENDIF
  715.  
  716. c        remplissage de xmatri
  717.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  718.  
  719.  3055 CONTINUE
  720.       GOTO 510
  721. c_______________________________________________________________________
  722.  
  723. c     secteur de calcul pour les elements joints joi2
  724. c_______________________________________________________________________
  725.  
  726.   85  CONTINUE
  727.       IF (ILUMP .EQ. 1) GOTO 99
  728.       NBNO=NBNN
  729.       NBBB=NBNN
  730.       SEGINI WRK1,WRK2,WRK4
  731.       DO 3085  IB=1,NBELEM
  732.  
  733. c        on cherche  les coordonnees des noeuds de l element ib
  734.  
  735.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  736.           CALL ZERO (REL,LRE,LRE)
  737.  
  738. c        calcul des coordonnees locales de l'element
  739.  
  740.           CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  741.  
  742. c        boucle sur les points de gauss
  743.  
  744.           ISDJC=0
  745.           DO 4085  IGAU=1,NBPGAU
  746.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  747.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  748. *
  749.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  750.               IF(DJAC.EQ.0.) I259=IB
  751.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  752.               MPTVAL=IVAMAT
  753.               IF (IVAL(1).NE.0) THEN
  754.                   MELVAL=IVAL(1)
  755.                   IGMN=MIN(IGAU,VELCHE(/1))
  756.                   IBMN=MIN(IB,VELCHE(/2))
  757.                   VALMAT(1)=VELCHE(IGMN,IBMN)
  758.               ELSE
  759.                   VALMAT(1)=0.D0
  760.               ENDIF
  761. CCCCCCCCCCC   DJAC=DJAC*VALMAT(1)/3.0D0
  762.  
  763. C    IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  764. C       LE B PAR 2...
  765.  
  766.               DJAC=DJAC*VALMAT(1)/4.0D0
  767.  
  768. c    cas axisymetrique : multiplication par le rayon de courbure
  769.  
  770.               IF (IFOUR.EQ.0) THEN
  771.                   RAYON = 0.D0
  772.                   NUMSUP=NBNO/2
  773.                   DO 4185 IRAY=1,NUMSUP
  774.                       RAYON=RAYON + ( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  775.  4185             CONTINUE
  776.                   DJAC=DJAC*RAYON
  777.               ENDIF
  778.  
  779.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  780.  4085     CONTINUE
  781.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  782.  
  783. c        remplissage de xmatri
  784.  
  785.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  786.  3085 CONTINUE
  787.       GOTO 510
  788. c_______________________________________________________________________
  789.  
  790. c     secteur de calcul pour les elements joints jot3
  791. c_______________________________________________________________________
  792.  
  793.   87  CONTINUE
  794.       IF (ILUMP .EQ. 1) GOTO 99
  795.       NBNO=NBNN
  796.       NBBB=NBNN
  797.       SEGINI WRK1,WRK2,WRK4
  798.       DO 3087  IB=1,NBELEM
  799.  
  800. c        on cherche  les coordonnees des noeuds de l element ib
  801.  
  802.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  803.           CALL ZERO (REL,LRE,LRE)
  804.  
  805. c        calcul des coordonnees locales de l'element
  806.  
  807.           CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  808.  
  809. c        boucle sur les points de gauss
  810.  
  811.           ISDJC=0
  812.           DO 4087  IGAU=1,NBPGAU
  813.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  814.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  815.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  816.               IF(DJAC.EQ.0.) I259=IB
  817.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  818.               MPTVAL=IVAMAT
  819.               IF (IVAL(1).NE.0) THEN
  820.                   MELVAL=IVAL(1)
  821.                   IGMN=MIN(IGAU,VELCHE(/1))
  822.                   IBMN=MIN(IB,VELCHE(/2))
  823.                   VALMAT(1)=VELCHE(IGMN,IBMN)
  824.               ELSE
  825.                   VALMAT(1)=0.D0
  826.               ENDIF
  827.               DJAC=DJAC*VALMAT(1)
  828. C    IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  829. C       LE B PAR 2...
  830.               DJAC=DJAC/4.0D0
  831.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  832.  4087     CONTINUE
  833.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  834.  
  835. c        remplissage de xmatri
  836.  
  837.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  838.  3087 CONTINUE
  839.       GOTO 510
  840. c_______________________________________________________________________
  841.  
  842. c     secteur de calcul pour les elements joints joi4
  843. c_______________________________________________________________________
  844.  
  845.   88  CONTINUE
  846.       IF (ILUMP .EQ. 1) GOTO 99
  847.       NBNO=NBNN
  848.       NBBB=NBNN
  849.       SEGINI WRK1,WRK2,WRK4
  850.       DO 3088  IB=1,NBELEM
  851.  
  852. c        on cherche  les coordonnees des noeuds de l element ib
  853.  
  854.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  855.           CALL ZERO (REL,LRE,LRE)
  856.  
  857. c        calcul des coordonnees locales de l'element
  858.  
  859.           CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  860.  
  861. c        boucle sur les points de gauss
  862.  
  863.           ISDJC=0
  864.           DO 4088  IGAU=1,NBPGAU
  865.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  866.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  867.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  868.               IF(DJAC.EQ.0.) I259=IB
  869.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  870.               MPTVAL=IVAMAT
  871.               IF (IVAL(1).NE.0) THEN
  872.                   MELVAL=IVAL(1)
  873.                   IGMN=MIN(IGAU,VELCHE(/1))
  874.                   IBMN=MIN(IB,VELCHE(/2))
  875.                   VALMAT(1)=VELCHE(IGMN,IBMN)
  876.               ELSE
  877.                   VALMAT(1)=0.D0
  878.               ENDIF
  879.               DJAC=DJAC*VALMAT(1)
  880. C    IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  881. C       LE B PAR 2...
  882.               DJAC=DJAC/4.0D0
  883.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  884.  4088     CONTINUE
  885.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  886.  
  887. c        remplissage de xmatri
  888.  
  889.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  890.  
  891.  3088 CONTINUE
  892.  
  893.       GOTO 510
  894. c_______________________________________________________________________
  895.  
  896. c     secteur de calcul pour les elements joints jgi2
  897. c_______________________________________________________________________
  898.  
  899.  170  CONTINUE
  900.       IF (IFOUR.EQ.-3) NDDL=NDDL+1
  901.       IF (ILUMP .EQ. 1) GOTO 99
  902.       NBNO=NBNN
  903.       NBBB=NBNN
  904.       SEGINI WRK1,WRK2,WRK4
  905.  
  906.       IG1=0
  907.  
  908.       DO IB=1,NBELEM
  909.  
  910. c        on cherche  les coordonnees des noeuds de l element ib
  911.  
  912.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  913.           CALL ZERO (REL,LRE,LRE)
  914.  
  915. c        calcul des coordonnees locales de l'element
  916.  
  917.           CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  918.  
  919. c        boucle sur les points de gauss
  920.  
  921.           ISDJC=0
  922.           DO IGAU=1,NBPGAU
  923.               MPTVAL=IVAMAT
  924.               DO IM=1,NMATT
  925.                   MELVAL=IVAL(IM)
  926.                   IGMN=MIN(IGAU,VELCHE(/1))
  927.                   IBMN=MIN(IB,VELCHE(/2))
  928.                   VALMAT(IM)=VELCHE(IGMN,IBMN)
  929.               ENDDO
  930.  
  931.               EPAIST=VALMAT(2)
  932.               IF(EPAIST.EQ.0.D0)THEN
  933.                 CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,
  934.      .               SHPWRK,EPAIST,BGENE,DJAC,XDPGE,YDPGE,IERT)
  935.                 IF(IERT.NE.0) IG1=IB
  936.               ENDIF
  937.  
  938.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  939.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  940. *
  941.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  942.               IF(DJAC.EQ.0.) I259=IB
  943.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  944. *
  945. c             valmat(1)=rho, valmat(2)=epai
  946. c             /4 correspnnd en fait a diviser les matrices B par 2
  947. CCCCCCCCCCCC  DJAC=DJAC*VALMAT(1)*VALMAT(2)/4.0D0
  948.               DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  949.  
  950. c    cas axisymetrique : multiplication par le rayon de courbure
  951.  
  952.               IF (IFOUR.EQ.0) THEN
  953.                   RAYON = 0.D0
  954.                   NUMSUP=NBNO/2
  955.                   DO IRAY=1,NUMSUP
  956.                       RAYON=RAYON + ( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  957.                   ENDDO
  958.                   DJAC=DJAC*RAYON
  959.               ENDIF
  960.  
  961.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  962.           ENDDO
  963.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  964.  
  965. c        remplissage de xmatri
  966.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  967.  
  968.       ENDDO
  969.  
  970.       IF (IG1.NE.0) THEN
  971.         INTERR(1)=IG1
  972.         CALL ERREUR (611)
  973.       ENDIF
  974.  
  975.       GOTO 510
  976.  
  977. c_______________________________________________________________________
  978.  
  979. c     secteur de calcul pour les elements joints jct3 en 2D cisaillement
  980. c_______________________________________________________________________
  981.  
  982.  168  CONTINUE
  983.       IF (ILUMP .EQ. 1) GOTO 99
  984.       NBNO=NBNN
  985.       NBBB=NBNN
  986.       SEGINI WRK1,WRK2,WRK4
  987.       DO IB=1,NBELEM
  988.  
  989. c        on cherche  les coordonnees des noeuds de l element ib
  990.  
  991.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  992.         CALL ZERO (REL,LRE,LRE)
  993.  
  994. c        calcul des coordonnees locales de l'element
  995.  
  996.         CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  997.  
  998. c        boucle sur les points de gauss
  999.  
  1000.         ISDJC=0
  1001.         DO IGAU=1,NBPGAU
  1002.           CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1003.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1004.           IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1005.           IF(DJAC.EQ.0.) I259=IB
  1006.           DJAC=ABS(DJAC)*POIGAU(IGAU)
  1007.           MPTVAL=IVAMAT
  1008.           IF (IVAL(1).NE.0) THEN
  1009.             MELVAL=IVAL(1)
  1010.             IGMN=MIN(IGAU,VELCHE(/1))
  1011.             IBMN=MIN(IB,VELCHE(/2))
  1012.             VALMAT(1)=VELCHE(IGMN,IBMN)
  1013.           ELSE
  1014.             VALMAT(1)=0.D0
  1015.           ENDIF
  1016.           DJAC=DJAC*VALMAT(1)
  1017. C    Il faut diviser par 4, ce qui correspond plus exactement a diviser
  1018. C       le B par 2...
  1019.           DJAC=DJAC/4.0D0
  1020.           CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1021.         ENDDO
  1022.         IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1023.  
  1024. c     remplissage de xmatri
  1025.         CALL REMPMT(REL,LRE,RE(1,1,ib))
  1026.  
  1027.       ENDDO
  1028.  
  1029.       GOTO 510
  1030. c_______________________________________________________________________
  1031.  
  1032. c     secteur de calcul pour les elements joints jgt3 generalise
  1033. c_______________________________________________________________________
  1034.  
  1035.  171  CONTINUE
  1036.       IF (ILUMP .EQ. 1) GOTO 99
  1037.       NBNO=NBNN
  1038.       NBBB=NBNN
  1039.       SEGINI WRK1,WRK2,WRK4
  1040.  
  1041.       IG1=0
  1042.  
  1043.       DO IB=1,NBELEM
  1044.  
  1045. c        on cherche  les coordonnees des noeuds de l element ib
  1046.  
  1047.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1048.           CALL ZERO (REL,LRE,LRE)
  1049.  
  1050. c        calcul des coordonnees locales de l'element
  1051.  
  1052.           CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1053.  
  1054. c        boucle sur les points de gauss
  1055.  
  1056.           ISDJC=0
  1057.           DO IGAU=1,NBPGAU
  1058.               MPTVAL=IVAMAT
  1059.               DO IM=1,NMATT
  1060.                   MELVAL=IVAL(IM)
  1061.                   IGMN=MIN(IGAU,VELCHE(/1))
  1062.                   IBMN=MIN(IB,VELCHE(/2))
  1063.                   VALMAT(IM)=VELCHE(IGMN,IBMN)
  1064.               ENDDO
  1065.  
  1066.               EPAIST=VALMAT(2)
  1067.               IF(EPAIST.EQ.0.D0)THEN
  1068.                 CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,
  1069.      .                     SHPWRK,EPAIST,BGENE,DJAC,IERT)
  1070.                 IF(IERT.NE.0) IG1=IB
  1071.               ENDIF
  1072.  
  1073.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1074.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1075. *
  1076.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1077.               IF(DJAC.EQ.0.) I259=IB
  1078.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  1079. *
  1080. c             valmat(1)=rho, valmat(2)=epai
  1081. c             /4 correspond en fait a diviser les matrices B par 2
  1082.               DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  1083. *
  1084.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1085.           ENDDO
  1086.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1087.  
  1088. c        remplissage de xmatri
  1089.  
  1090.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1091.  
  1092.       ENDDO
  1093.  
  1094.       IF (IG1.NE.0) THEN
  1095.         INTERR(1)=IG1
  1096.         CALL ERREUR (611)
  1097.       ENDIF
  1098.  
  1099.       GOTO 510
  1100.  
  1101. c_______________________________________________________________________
  1102.  
  1103. c     secteur de calcul pour les elements joints jci4 en 2D cisaillement
  1104. c_______________________________________________________________________
  1105.  
  1106.  169  CONTINUE
  1107.       IF (ILUMP .EQ. 1) GOTO 99
  1108.       NBNO=NBNN
  1109.       NBBB=NBNN
  1110.       SEGINI WRK1,WRK2,WRK4
  1111.       DO IB=1,NBELEM
  1112.  
  1113. c        on cherche  les coordonnees des noeuds de l element ib
  1114.  
  1115.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1116.           CALL ZERO (REL,LRE,LRE)
  1117.  
  1118. c        calcul des coordonnees locales de l'element
  1119.  
  1120.           CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1121.  
  1122. c        boucle sur les points de gauss
  1123.  
  1124.           ISDJC=0
  1125.           DO IGAU=1,NBPGAU
  1126.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1127.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1128.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1129.               IF(DJAC.EQ.0.) I259=IB
  1130.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  1131.               MPTVAL=IVAMAT
  1132.               IF (IVAL(1).NE.0) THEN
  1133.                   MELVAL=IVAL(1)
  1134.                   IGMN=MIN(IGAU,VELCHE(/1))
  1135.                   IBMN=MIN(IB,VELCHE(/2))
  1136.                   VALMAT(1)=VELCHE(IGMN,IBMN)
  1137.               ELSE
  1138.                   VALMAT(1)=0.D0
  1139.               ENDIF
  1140.               DJAC=DJAC*VALMAT(1)
  1141. CCCCCCCCCCC   DJAC=DJAC/3.0D0
  1142. C    Il faut diviser par 4, ce qui correspond plus exactement a diviser
  1143. C       le B par 2...
  1144.               DJAC=DJAC/4.0D0
  1145.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1146.           ENDDO
  1147.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1148.  
  1149. c        remplissage de xmatri
  1150.  
  1151.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1152.  
  1153.       ENDDO
  1154.  
  1155.       GOTO 510
  1156. c_______________________________________________________________________
  1157.  
  1158. c     secteur de calcul pour les elements joints jgi4 generalise
  1159. c_______________________________________________________________________
  1160.  
  1161.  172  CONTINUE
  1162.       IF (ILUMP .EQ. 1) GOTO 99
  1163.       NBNO=NBNN
  1164.       NBBB=NBNN
  1165.       SEGINI WRK1,WRK2,WRK4
  1166.  
  1167.       IG1=0
  1168.  
  1169.       DO IB=1,NBELEM
  1170.  
  1171. c        on cherche  les coordonnees des noeuds de l element ib
  1172.  
  1173.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1174.           CALL ZERO (REL,LRE,LRE)
  1175.  
  1176. c        calcul des coordonnees locales de l'element
  1177.  
  1178.           CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1179.  
  1180. c        boucle sur les points de gauss
  1181.  
  1182.           ISDJC=0
  1183.           DO IGAU=1,NBPGAU
  1184.               MPTVAL=IVAMAT
  1185.               DO IM=1,NMATT
  1186.                   MELVAL=IVAL(IM)
  1187.                   IGMN=MIN(IGAU,VELCHE(/1))
  1188.                   IBMN=MIN(IB,VELCHE(/2))
  1189.                   VALMAT(IM)=VELCHE(IGMN,IBMN)
  1190.               ENDDO
  1191.  
  1192.               EPAIST=VALMAT(2)
  1193.               IF(EPAIST.EQ.0.D0)THEN
  1194.                 CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1195.      .                     BGENE,DJAC,IERT)
  1196.                 IF(IERT.NE.0) IG1=IB
  1197.               ENDIF
  1198.  
  1199.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1200.      1        1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1201. *
  1202.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1203.               IF(DJAC.EQ.0.) I259=IB
  1204.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  1205. *
  1206. c             valmat(1)=rho, valmat(2)=epai
  1207. c             /4 correspnnd en fait a diviser les matrices B par 2
  1208. CCCCCCCCCCCC  DJAC=DJAC*VALMAT(1)*VALMAT(2)/4.0D0
  1209.               DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  1210. *
  1211.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1212.           ENDDO
  1213.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1214.  
  1215. c        remplissage de xmatri
  1216.  
  1217.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1218.  
  1219.       ENDDO
  1220.  
  1221.       IF (IG1.NE.0) THEN
  1222.         INTERR(1)=IG1
  1223.         CALL ERREUR (611)
  1224.       ENDIF
  1225.  
  1226.       GOTO 510
  1227.  
  1228. c_______________________________________________________________________
  1229.  
  1230. c     secteur de calcul pour les elements  homogeneises
  1231. c       (liquide solide)  trih
  1232. c_______________________________________________________________________
  1233.  
  1234.   92  CONTINUE
  1235.       IF (ILUMP .EQ. 1) GOTO 99
  1236.       NBNO=NBNN
  1237.       NBBB=NBNN
  1238.       SEGINI WRK1,WRK2
  1239.       DO 3092  IB=1,NBELEM
  1240.  
  1241. c        on cherche  les coordonnees des noeuds de l element ib
  1242.  
  1243.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1244.           CALL ZERO (REL,LRE,LRE)
  1245.  
  1246. c        on cherche les caracteristiques du materiau de l element ib
  1247.  
  1248.           MPTVAL=IVAMAT
  1249.           DO 8092 IM=1,NMATT
  1250.               MELVAL=IVAL(IM)
  1251.               IBMN=MIN(IB,VELCHE(/2))
  1252.               VALMAT(IM)=VELCHE(1,IBMN)
  1253.  8092     CONTINUE
  1254.           B11   =VALMAT(1)
  1255.           B22   =VALMAT(2)
  1256.           B12   =VALMAT(3)
  1257.           RHOF  =VALMAT(4)
  1258.           RHOS  =VALMAT(5)
  1259.           C     =VALMAT(6)
  1260.           RHOREF=VALMAT(7)
  1261.           CREF  =VALMAT(8)
  1262.           RLCAR =VALMAT(9)
  1263.  
  1264. c        on cherche les caracteristiques geometriques de l element ib
  1265.  
  1266.           MPTVAL=IVACAR
  1267.           IF (IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1268.               MELVAL=IVAL(1)
  1269.               IBMN=MIN(IB,VELCHE(/2))
  1270.               SECT=VELCHE(1,IBMN)
  1271.               MELVAL=IVAL(2)
  1272.               IBMN=MIN(IB,VELCHE(/2))
  1273.               SCEL=VELCHE(1,IBMN)
  1274.               MELVAL=IVAL(3)
  1275.               IBMN=MIN(IB,VELCHE(/2))
  1276.               SFLU=VELCHE(1,IBMN)
  1277.               MELVAL=IVAL(4)
  1278.               IBMN=MIN(IB,VELCHE(/2))
  1279.               EPS =VELCHE(1,IBMN)
  1280.           ELSE
  1281.               SECT=1.D0
  1282.               MELVAL=IVAL(1)
  1283.               IBMN=MIN(IB,VELCHE(/2))
  1284.               SCEL=VELCHE(1,IBMN)
  1285.               MELVAL=IVAL(2)
  1286.               IBMN=MIN(IB,VELCHE(/2))
  1287.               SFLU=VELCHE(1,IBMN)
  1288.               MELVAL=IVAL(3)
  1289.               IBMN=MIN(IB,VELCHE(/2))
  1290.               EPS =VELCHE(1,IBMN)
  1291.               MELVAL=IVAL(4)
  1292.               IBMN=MIN(IB,VELCHE(/2))
  1293.               F11 =VELCHE(1,IBMN)
  1294.               MELVAL=IVAL(5)
  1295.               IBMN=MIN(IB,VELCHE(/2))
  1296.               F12 =VELCHE(1,IBMN)
  1297.           ENDIF
  1298.  
  1299. c        calcul de  la  masse  m0/eps**2
  1300.  
  1301.           RHOSS=RHOS*SECT/(EPS*EPS)
  1302.  
  1303. c        calcul des coefficients de normalisation
  1304.  
  1305.           COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1306.           COEFPI=RHOREF*RLCAR
  1307.           VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1308.           VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1309.           VKL23 = COEFPI/SCEL
  1310.           VKL33 = 1.D0/SCEL
  1311.           IF(IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1312.               VKL23 =COEFPI*0.5D0*(2.D0*SCEL-B11-B22)/SCEL
  1313.               VKL33 =(RHOSS+RHOF*(SFLU-(B11+B22)/2.D0))/SCEL
  1314.  
  1315. c           calcul des termes en pi*pi
  1316. c           integration par nbpgau points de gauss
  1317.  
  1318.               ISDJC=0
  1319.               DO 4092 IGAU=1,NBPGAU
  1320.                   POIGA2=MINTE.POIGAU(IGAU)
  1321.                   CALL TRIHM1(IGAU,MELE,MFR,NBNO,XE,SHPTOT,SHPWRK,
  1322.      #            IFOUR,NHRM,B11,B22,SFLU,POIGA2,VKL22,LRE,REL,IRRT)
  1323.                   IF(IRRT.NE.1) GOTO 7092
  1324.  
  1325. c              calcul du  reste des termes  de la matrice  masse
  1326. c              integration par nbpgau points de gauss
  1327.  
  1328.                   CALL TRIHM2(IGAU,MELE,MFR,NBNO,XE,MINTE.SHPTOT,SHPWRK
  1329.      #        ,IFOUR,NHRM,VKL12,VKL23,VKL33,POIGA2,ISDJC,LRE,REL,IRRT)
  1330.                   IF(IRRT.NE.1) GOTO 7092
  1331.  4092         CONTINUE
  1332.               IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1333.           ELSE
  1334.  
  1335. c           boucle sur les points de gauss
  1336. c           cas plan
  1337.  
  1338.               ISDJC=0
  1339.               DO 6092 IGAU1=1,NBPGAU
  1340.                   POIGA1=MINTE.POIGAU(IGAU1)
  1341.                   CALL TRIHM3(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK
  1342.      #                       ,RHOSS,RHOF,
  1343.      #            B11,B22,B12,F11,F12,SFLU,SCEL,POIGA1,VKL12,VKL22,
  1344.      #            VKL23,VKL33,LRE,REL,ISDJC,IRRT)
  1345.                   IF(IRRT.NE.1) GOTO 7092
  1346.  6092         CONTINUE
  1347.               IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1348.           ENDIF
  1349.  
  1350. c        remplissage de xmatri
  1351.  
  1352.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1353.  
  1354.  3092 CONTINUE
  1355.  
  1356. c     impression d un eventuel message d erreur
  1357.  
  1358.  7092 CONTINUE
  1359.       IF(IRRT.EQ.0) THEN
  1360.           MOTERR(1:4)=NOMTP(MELE)
  1361.           CALL ERREUR(420)
  1362.       ELSE
  1363.           IF(IRRT.EQ.2) THEN
  1364.               INTERR(1) = IB
  1365.               CALL ERREUR(405)
  1366.           ENDIF
  1367.       ENDIF
  1368.       IF(IRRT.EQ.3) CALL ERREUR(421)
  1369.       IF(IRRT.EQ.4) CALL ERREUR(422)
  1370.  
  1371.       GOTO 510
  1372. c_______________________________________________________________________
  1373.  
  1374. c     secteur de calcul pour les elements de raccord
  1375. c      liquide coque 4 noeuds - cas tridimensionnel
  1376. c_______________________________________________________________________
  1377.  
  1378.   94  CONTINUE
  1379.       IF (ILUMP .EQ. 1) GOTO 99
  1380.       NBBB=NBNN
  1381.       LW=IDIM
  1382.       SEGINI WRK1,WRK3
  1383.       DO 3094 IB=1,NBELEM
  1384.  
  1385. c        on cherche les coordonnees de l element ib
  1386.  
  1387.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1388.           CALL ZERO(REL,LRE,LRE)
  1389.  
  1390. c        calcul des coefficients de normalisation
  1391.  
  1392.           MPTVAL=IVAMAT
  1393.           DO 5094 IM=1,NMATT
  1394.               MELVAL=IVAL(IM)
  1395.               IBMN=MIN(IB,VELCHE(/2))
  1396.               VALMAT(IM)=VELCHE(1,IBMN)
  1397.  5094     CONTINUE
  1398.           RHOREF=VALMAT(1)
  1399.           RLCAR = VALMAT(2)
  1400.  
  1401.           CFPI= RHOREF*RLCAR
  1402.  
  1403.           MPTVAL=IVACAR
  1404.           DO 4094 IC=1,NCARR
  1405.               IF (IVAL(IC).NE.0) THEN
  1406.                   MELVAL=IVAL(IC)
  1407.                   IBMN=MIN(IB,VELCHE(/2))
  1408.                   WORK(IC)=VELCHE(1,IBMN)
  1409.               ELSE
  1410.                   WORK(IC)=0.D0
  1411.               ENDIF
  1412.  4094     CONTINUE
  1413.  
  1414.           CALL LIC4MA(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  1415.      1    QSIGAU,ETAGAU,SHPTOT,REL,LRE,IER246)
  1416.           IF(IER246.NE.0) THEN
  1417.               CALL ERREUR(IER246)
  1418.               GOTO 510
  1419.           ENDIF
  1420.  
  1421. c        remplissage de xmatri
  1422.  
  1423.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1424.  
  1425.  3094 CONTINUE
  1426.  
  1427.       GOTO 510
  1428. c_______________________________________________________________________
  1429.  
  1430. c     secteur de calcul pour les elements  homogeneises
  1431. c       (liquide solide)  quah
  1432. c_______________________________________________________________________
  1433.  
  1434.  126  CONTINUE
  1435.  
  1436.       IF (ILUMP .EQ. 1) GOTO 99
  1437.       NBNO=NBNN
  1438.       NBBB=NBNN
  1439.       SEGINI WRK1,WRK2
  1440.       DO 3126  IB=1,NBELEM
  1441.  
  1442. c        on cherche  les coordonnees des noeuds de l element ib
  1443.  
  1444.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1445.           CALL ZERO (REL,LRE,LRE)
  1446.  
  1447. c        on cherche les caracteristiques du materiau de l element ib
  1448.  
  1449.           MPTVAL=IVAMAT
  1450.           DO 8126 IM=1,NMATT
  1451.               MELVAL=IVAL(IM)
  1452.               IBMN=MIN(IB,VELCHE(/2))
  1453.               VALMAT(IM)=VELCHE(1,IBMN)
  1454.  8126     CONTINUE
  1455.           B11   =VALMAT(1)
  1456.           B22   =VALMAT(2)
  1457.           B12   =VALMAT(3)
  1458.           RHOF  =VALMAT(4)
  1459.           RHOS  =VALMAT(5)
  1460.           C     =VALMAT(6)
  1461.           RHOREF=VALMAT(7)
  1462.           CREF  =VALMAT(8)
  1463.           RLCAR =VALMAT(9)
  1464.  
  1465. c        on cherche les caracteristiques geometriques de l element ib
  1466.  
  1467.           MPTVAL=IVACAR
  1468.           MELVAL=IVAL(4)
  1469.           IBMN=MIN(IB,VELCHE(/2))
  1470.           SECT=VELCHE(1,IBMN)
  1471.  
  1472.           MELVAL=IVAL(1)
  1473.           IBMN=MIN(IB,VELCHE(/2))
  1474.           SCEL=VELCHE(1,IBMN)
  1475.  
  1476.           MELVAL=IVAL(2)
  1477.           IBMN=MIN(IB,VELCHE(/2))
  1478.           SFLU=VELCHE(1,IBMN)
  1479.  
  1480.           MELVAL=IVAL(3)
  1481.           IBMN=MIN(IB,VELCHE(/2))
  1482.           EPS =VELCHE(1,IBMN)
  1483.  
  1484.  
  1485. c        calcul de  la  masse  m0/eps**2
  1486.  
  1487.           RHOSS=RHOS*SECT/(EPS*EPS)
  1488.  
  1489. c        calcul des coefficients de normalisation
  1490.  
  1491.           COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1492.           COEFPI=RHOREF*RLCAR
  1493.           VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1494.           VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1495.           VKL23 =COEFPI*0.5D0*(2.D0*SCEL-B11-B22)/SCEL
  1496.           VKL33 =(RHOSS+RHOF*(SFLU-(B11+B22)/2.D0))/SCEL
  1497.  
  1498. c           calcul des termes en pi*pi
  1499. c           integration par nbpgau points de gauss
  1500.  
  1501.           ISDJC=0
  1502.           DO 4126 IGAU=1,NBPGAU
  1503.               POIGA2=MINTE.POIGAU(IGAU)
  1504.               CALL QUAHM1(IGAU,MELE,MFR,NBNO,XE,SHPTOT,SHPWRK,IFOUR
  1505.      #        ,NHRM,B11,B22,SFLU,POIGA2,VKL22,LRE,REL,IRRT)
  1506.               IF(IRRT.NE.1) GOTO 7126
  1507.  
  1508. c              calcul du  reste des termes  de la matrice  masse
  1509. c              integration par nbpgau points de gauss
  1510.  
  1511.               CALL QUAHM2(IGAU,MELE,MFR,NBNO,XE,MINTE.SHPTOT,SHPWRK
  1512.      #        ,IFOUR,NHRM,VKL12,VKL23,VKL33,POIGA2,ISDJC,LRE,REL,IRRT)
  1513.               IF(IRRT.NE.1) GOTO 7126
  1514.  4126     CONTINUE
  1515.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1516.  
  1517. c        remplissage de xmatri
  1518.  
  1519.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1520.  
  1521.  3126 CONTINUE
  1522.  
  1523. c     impression d un eventuel message d erreur
  1524.  
  1525.  7126 CONTINUE
  1526.       IF(IRRT.EQ.0) THEN
  1527.           MOTERR(1:4)=NOMTP(MELE)
  1528.           CALL ERREUR(420)
  1529.       ELSE
  1530.           IF(IRRT.EQ.2) THEN
  1531.               INTERR(1) = IB
  1532.               CALL ERREUR(405)
  1533.           ENDIF
  1534.       ENDIF
  1535.       IF(IRRT.EQ.3) CALL ERREUR(421)
  1536.       IF(IRRT.EQ.4) CALL ERREUR(422)
  1537.       GOTO 510
  1538.  
  1539. c_______________________________________________________________________
  1540.  
  1541. c     secteur de calcul pour les elements homogeneises
  1542. c       (liquide solide)  cubh
  1543. c_______________________________________________________________________
  1544.  
  1545.  127  CONTINUE
  1546.       IF (ILUMP .EQ. 1) GOTO 99
  1547.       NBNO=NBNN
  1548.       NBBB=NBNN
  1549.       LW=IDIM
  1550.       SEGINI WRK1,WRK2
  1551.       DO 3127  IB=1,NBELEM
  1552.  
  1553. c        on cherche  les coordonnees des noeuds de l element ib
  1554.  
  1555.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1556.           CALL ZERO (REL,LRE,LRE)
  1557.  
  1558. c        on cherche les caracteristiques du materiau de l element ib
  1559.  
  1560.           MPTVAL=IVAMAT
  1561.           DO 8127 IM=1,NMATT
  1562.               MELVAL=IVAL(IM)
  1563.               IBMN=MIN(IB,VELCHE(/2))
  1564.               VALMAT(IM)=VELCHE(1,IBMN)
  1565.  8127     CONTINUE
  1566.           B11   =VALMAT(1)
  1567.           B22   =VALMAT(2)
  1568.           B12   =VALMAT(3)
  1569.           RHOF  =VALMAT(4)
  1570.           RHOS  =VALMAT(5)
  1571.           C     =VALMAT(6)
  1572.           RHOREF=VALMAT(7)
  1573.           CREF  =VALMAT(8)
  1574.           RLCAR =VALMAT(9)
  1575.  
  1576. c        on cherche les caracteristiques geometriques de l element ib
  1577.  
  1578.           MPTVAL=IVACAR
  1579.  
  1580.           MELVAL=IVAL(1)
  1581.           IBMN=MIN(IB,VELCHE(/2))
  1582.           SCEL=VELCHE(1,IBMN)
  1583.  
  1584.           MELVAL=IVAL(2)
  1585.           IBMN=MIN(IB,VELCHE(/2))
  1586.           SFLU=VELCHE(1,IBMN)
  1587.  
  1588.           MELVAL=IVAL(3)
  1589.           IBMN=MIN(IB,VELCHE(/2))
  1590.           EPS =VELCHE(1,IBMN)
  1591.  
  1592.           MELVAL=IVAL(4)
  1593.           IBMN=MIN(IB,VELCHE(/2))
  1594.           SECT =VELCHE(1,IBMN)
  1595.  
  1596. c        calcul de  la  masse  m0/eps**2
  1597.  
  1598.           RHOSS=RHOS*SECT/(EPS*EPS)
  1599.  
  1600. c        calcul des coefficients de normalisation
  1601.  
  1602.           COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1603.           COEFPI=RHOREF*RLCAR
  1604.  
  1605.  
  1606.           VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1607.           VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1608.  
  1609.           VKL23 = COEFPI/SCEL
  1610.           VKL33 = 1.D0/SCEL
  1611.  
  1612.           ISDJC=0
  1613.           DO 6127 IGAU1=1,NBPGAU
  1614.               POIGA1=MINTE.POIGAU(IGAU1)
  1615.               CALL CUBHM1(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK,
  1616.      #        RHOSS,RHOF,B11,B22,B12,SFLU,SCEL,POIGA1,VKL12,VKL22,VKL23,
  1617.      #        VKL33,LRE,REL,ISDJC,IRRT)
  1618.               IF(IRRT.NE.1) GOTO 7127
  1619.  6127     CONTINUE
  1620.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1621.  
  1622. c        remplissage de xmatri
  1623.  
  1624.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1625.  3127 CONTINUE
  1626.  
  1627. c     impression d un eventuel message d erreur
  1628.  
  1629.  7127 CONTINUE
  1630.  
  1631.       IF(IRRT.EQ.0) THEN
  1632.           MOTERR(1:4)=NOMTP(MELE)
  1633.           CALL ERREUR(420)
  1634.       ELSE
  1635.           IF(IRRT.EQ.2) THEN
  1636.               INTERR(1) = IB
  1637.               CALL ERREUR(405)
  1638.           ENDIF
  1639.       ENDIF
  1640.       IF(IRRT.EQ.3) CALL ERREUR(421)
  1641.       IF(IRRT.EQ.4) CALL ERREUR(422)
  1642.  
  1643.       GOTO 510
  1644. c_______________________________________________________________________
  1645.  
  1646. c     secteur de calcul pour les elements  homogeneises
  1647. c       (liquide solide)  trh6
  1648. c_______________________________________________________________________
  1649.  
  1650.  157  CONTINUE
  1651.       IF (ILUMP .EQ. 1) GOTO 99
  1652.       NBNO=NBNN
  1653.       NBBB=NBNN
  1654.       SEGINI WRK1,WRK2
  1655.       DO 3157  IB=1,NBELEM
  1656.  
  1657. c        on cherche  les coordonnees des noeuds de l element ib
  1658.  
  1659.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1660.           CALL ZERO (REL,LRE,LRE)
  1661.  
  1662. c        on cherche les caracteristiques du materiau de l element ib
  1663.  
  1664.           MPTVAL=IVAMAT
  1665.           DO 8157 IM=1,NMATT
  1666.               MELVAL=IVAL(IM)
  1667.               IBMN=MIN(IB,VELCHE(/2))
  1668.               VALMAT(IM)=VELCHE(1,IBMN)
  1669.  8157     CONTINUE
  1670.           B11   =VALMAT(1)
  1671.           B22   =VALMAT(2)
  1672.           B12   =VALMAT(3)
  1673.           RHOF  =VALMAT(4)
  1674.           RHOS  =VALMAT(5)
  1675.           C     =VALMAT(6)
  1676.           RHOREF=VALMAT(7)
  1677.           CREF  =VALMAT(8)
  1678.           RLCAR =VALMAT(9)
  1679.           E111  =VALMAT(10)
  1680.           E112  =VALMAT(11)
  1681.           E121  =VALMAT(12)
  1682.           E122  =VALMAT(13)
  1683.           E221  =VALMAT(14)
  1684.           E222  =VALMAT(15)
  1685.  
  1686. c        on cherche les caracteristiques geometriques de l element ib
  1687.  
  1688.           MPTVAL=IVACAR
  1689.           IF (IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1690.               MELVAL=IVAL(1)
  1691.               IBMN=MIN(IB,VELCHE(/2))
  1692.               SECT=VELCHE(1,IBMN)
  1693.               MELVAL=IVAL(2)
  1694.               IBMN=MIN(IB,VELCHE(/2))
  1695.               SCEL=VELCHE(1,IBMN)
  1696.               MELVAL=IVAL(3)
  1697.               IBMN=MIN(IB,VELCHE(/2))
  1698.               SFLU=VELCHE(1,IBMN)
  1699.               MELVAL=IVAL(4)
  1700.               IBMN=MIN(IB,VELCHE(/2))
  1701.               EPS =VELCHE(1,IBMN)
  1702.           ELSE
  1703.               SECT=1.D0
  1704.               MELVAL=IVAL(1)
  1705.               IBMN=MIN(IB,VELCHE(/2))
  1706.               SCEL=VELCHE(1,IBMN)
  1707.               MELVAL=IVAL(2)
  1708.               IBMN=MIN(IB,VELCHE(/2))
  1709.               SFLU=VELCHE(1,IBMN)
  1710.               MELVAL=IVAL(3)
  1711.               IBMN=MIN(IB,VELCHE(/2))
  1712.               EPS =VELCHE(1,IBMN)
  1713.               MELVAL=IVAL(4)
  1714.               IBMN=MIN(IB,VELCHE(/2))
  1715.               F11 =VELCHE(1,IBMN)
  1716.               MELVAL=IVAL(5)
  1717.               IBMN=MIN(IB,VELCHE(/2))
  1718.               F12 =VELCHE(1,IBMN)
  1719.           ENDIF
  1720.  
  1721. c        calcul de  la  masse  m0/eps**2
  1722.  
  1723.           RHOSS=RHOS*SECT/(EPS*EPS)
  1724.  
  1725. c        calcul des coefficients de normalisation
  1726.  
  1727.           COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1728.           COEFPI=RHOREF*RLCAR
  1729.           VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1730.           VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1731.           VKL23 = COEFPI/SCEL
  1732.           VKL33 = 1.D0/SCEL
  1733.           VKL41 = EPS*EPS/2.D0/SCEL*(COEFPR*COEFPI)
  1734.           VKL42 = EPS*EPS/2.D0/SCEL*COEFPI*COEFPI
  1735.           VKL43 = EPS*EPS/2.D0/SCEL*COEFPI
  1736.           VKL44 = EPS*EPS/2.D0/SCEL
  1737.  
  1738. c           boucle sur les points de gauss
  1739. c           cas plan
  1740.  
  1741.               ISDJC=0
  1742.               DO 6157 IGAU1=1,NBPGAU
  1743.                   POIGA1=MINTE.POIGAU(IGAU1)
  1744.                   CALL TRIHM31(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK
  1745.      #                       ,RHOSS,RHOF,
  1746.      #            B11,B22,B12,F11,F12,SFLU,SCEL,POIGA1,VKL12,VKL22,
  1747.      #            VKL23,VKL33,VKL42,VKL43,VKL44,E111,E112,E121,E122,
  1748.      #            E221,E222,LRE,REL,ISDJC,IRRT)
  1749.                   IF (IRRT.NE.1) GOTO 7157
  1750.  6157         CONTINUE
  1751.               IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1752.  
  1753. c        remplissage de xmatri
  1754.  
  1755.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  1756.  
  1757.  3157 CONTINUE
  1758.  
  1759. c     impression d un eventuel message d erreur
  1760.  
  1761.  7157 CONTINUE
  1762.       IF(IRRT.EQ.0) THEN
  1763.           MOTERR(1:4)=NOMTP(MELE)
  1764.           CALL ERREUR(420)
  1765.       ELSE
  1766.           IF(IRRT.EQ.2) THEN
  1767.               INTERR(1) = IB
  1768.               CALL ERREUR(405)
  1769.           ENDIF
  1770.       ENDIF
  1771.       IF(IRRT.EQ.3) CALL ERREUR(421)
  1772.       IF(IRRT.EQ.4) CALL ERREUR(422)
  1773.       GOTO 510
  1774. c_______________________________________________________________________
  1775.   510 CONTINUE
  1776.       IF (I195.NE.0) THEN
  1777.         INTERR(1)=I195
  1778.         CALL ERREUR(195)
  1779.       ENDIF
  1780.       IF (I259.NE.0) THEN
  1781.         INTERR(1)=I259
  1782.         CALL ERREUR(259)
  1783.       ENDIF
  1784.  
  1785.       SEGSUP,MVELCH
  1786.  
  1787.       SEGSUP,WRK1
  1788.       IF (WRK2.NE.0) SEGSUP,WRK2
  1789.       IF (WRK3.NE.0) SEGSUP,WRK3
  1790.       IF (WRK4.NE.0) SEGSUP,WRK4
  1791.       IF (WRK5.NE.0) SEGSUP,WRK5
  1792.  
  1793.       mlmots = iinc
  1794.       if (mlmots.gt.0) segsup mlmots
  1795.       mlmots = idua
  1796.       if (mlmots.gt.0) segsup mlmots
  1797.  
  1798.       RETURN
  1799.       END
  1800.  
  1801.  
  1802.  

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