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

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