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

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