Télécharger la plaquette Cast3M


fr en

Télécharger sigma1.eso

Retour à la liste

Numérotation des lignes : 

sigma1

  1. C SIGMA1    SOURCE    SP204843  25/07/03    21:15:08     12308          
  2.  
  3.       SUBROUTINE SIGMA1(MATE,IMAT,IPMAIL,IPMINT,MELE,IELE,
  4.      &  IVADEP,NBPTEL,LRE,NSTRS,IVAMAT,NBGMAT,NELMAT,LHOOK,NMATT,
  5.      &  CMATE,MFR,NDEP,IPORE,IREPS2,NBPGAU,IVASTR,UZDPG,RYDPG,RXDPG,
  6.      &  IIPDPG,inoer)
  7.  
  8. *---------------------------------------------------------------------*
  9. *         _________________________                                   *
  10. *        |                         |                                  *
  11. *        |  calcul des contraintes |                                  *
  12. *        |_________________________|                                  *
  13. *                                                                     *
  14. *        massif, poreux, joints poreux, incompressibles               *
  15. *                                                                     *
  16. *---------------------------------------------------------------------*
  17. *                                                                     *
  18. *   entrees :                                                         *
  19. *   ________                                                          *
  20. *                                                                     *
  21. *        mate     numero du materiau                                  *
  22. *        imat     (2 il y a une matrice de hooke,1 non  )             *
  23. *        ipmail   pointeur sur un segment  meleme                     *
  24. *        ipmint   pointeur sur un segment minte                       *
  25. *        mele     numero de l'element fini                            *
  26. *        iele     numero geometrique de l'element
  27. *        nbpgau   nombre de point d'integration pour la rigidite      *
  28. *        ivadep   pointeur sur le chamelem de deplacements            *
  29. *        nbptel   nombre de points par element                        *
  30. *        lre      nombre de ddl dans la matrice de rigidite           *
  31. *        nstrs    nombre de composante de contraintes/deformations    *
  32. *        ivamat   pointeur sur un segment mptval pour le materiau ou  *
  33. *                 pour une matrice de hooke                           *
  34. *        nbgmat   taille maxi des melval du materiau (pt de gauss)    *
  35. *        nelmat   taille maxi des melval du materiau (no d'element)   *
  36. *        lhook    dimension de la matrice de hooke                    *
  37. *        nmatt    nombre de composante de materiau (imat=1)           *
  38. *        cmate    nom du materiau                                     *
  39. *        mfr      numero de la formulation de l'element fini          *
  40. *        ndep     nombre de composantes de deplacements               *
  41. *        ipore    nombre de fonctions de forme                        *
  42. *        iresp2   flag pour indiquer si on veut les contraintes       *
  43. *                  de piola-kirchhoff                                 *
  44. *        uzdpg    = deformation au point nsdpge support de la         *
  45. *        rydpf    = deformation plane generalisee                     *
  46. *        rxdpg    =                                                   *
  47. *                                                                     *
  48. *   sorties :                                                         *
  49. *   ________                                                          *
  50. *                                                                     *
  51. *        ivastr   pointeur sur un segment mptval contenant les        *
  52. *                 les melvals de contraints
  53. *                                                                     *
  54. *---------------------------------------------------------------------*
  55.  
  56.       IMPLICIT INTEGER(I-N)
  57.       IMPLICIT REAL*8(A-H,O-Z)
  58.  
  59. -INC PPARAM
  60. -INC CCOPTIO
  61. -INC CCHAMP
  62. -INC CCREEL
  63. -INC CCGEOME
  64.  
  65. -INC SMCHAML
  66. -INC SMINTE
  67. -INC SMELEME
  68. -INC SMCOORD
  69. -INC SMLREEL
  70.  
  71. -INC TMPTVAL
  72.  
  73.       SEGMENT WRK1
  74.        REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS)
  75.        REAL*8 XE(3,NBBB) ,DDHOMU(NSTRS,NSTRS)
  76.       ENDSEGMENT
  77. c
  78.       SEGMENT WRK2
  79.        REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  80.       ENDSEGMENT
  81. c
  82.       SEGMENT WRK3
  83.        REAL*8 BPSS(3,3),XEL(3,NBBB)
  84.       ENDSEGMENT
  85. c
  86.       SEGMENT WRK5
  87.        REAL*8 XGENE(NSTN,LRN),COBMA(LHOOK),XWRK(LHOOK)
  88.        REAL*8 COBB(IDECAP),CPBB(IDECAP),KKBB(IDECAP,IDECAP)
  89.       ENDSEGMENT
  90. c
  91.       SEGMENT WRK8
  92.        REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  93.        REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  94.       ENDSEGMENT
  95. c
  96.       SEGMENT,MVELCH
  97.        REAL*8 VALMAT(NV1)
  98.       ENDSEGMENT
  99.  
  100.       SEGMENT MTRACE
  101.         REAL*8 TRACE(3,NBPTEL)
  102.       ENDSEGMENT
  103. *
  104.       CHARACTER*8 CMATE
  105.       DIMENSION A(4,60),BB(3,60),UDPGE(3),PP(4,4)
  106.       LOGICAL BDPGE
  107.  
  108. c   Introduction du point autour duquel se fait le mouvement
  109. c   de la section en defo plane generalisee
  110. c   Pas de rotation en 1D
  111.       BDPGE=.FALSE.
  112.       NDPGE=0
  113.       XDPGE=XZero
  114.       YDPGE=XZero
  115.       IF (IFOUR.EQ.-3) THEN
  116.         BDPGE=.TRUE.
  117.         NDPGE=3
  118.         UDPGE(1)=UZDPG
  119.         UDPGE(2)=RYDPG
  120.         UDPGE(3)=RXDPG
  121.         SEGACT,MCOORD
  122.         IREF=(IIPDPG-1)*(IDIM+1)
  123.         XDPGE=XCOOR(IREF+1)
  124.         YDPGE=XCOOR(IREF+2)
  125.       ELSE IF (IDIM.EQ.1) THEN
  126.         IF ((IFOUR.GE.7 .AND. IFOUR.LE.10) .OR. IFOUR.EQ.14) THEN
  127.           BDPGE=.TRUE.
  128.           NDPGE=1
  129.           UDPGE(1)=UZDPG
  130.         ELSE IF (IFOUR.EQ.11) THEN
  131.           BDPGE=.TRUE.
  132.           NDPGE=2
  133.           UDPGE(1)=UZDPG
  134.           UDPGE(2)=RXDPG
  135.         ENDIF
  136.       ENDIF
  137. *
  138.       MELEME=IPMAIL
  139.       NBNN=NUM(/1)
  140.       NBELEM=NUM(/2)
  141. *
  142.       IDECAP=0
  143.       NHRM=NIFOUR
  144. *
  145.       NV1=NMATT
  146.       SEGINI,MVELCH
  147. *
  148.       MINTE=IPMINT
  149. *
  150.       NBBB=NBNN
  151.       SEGINI WRK1
  152. *
  153.       IRTD=1
  154. c_______________________________________________________________________
  155. c
  156. c     numero des etiquettes      :
  157. c     etiquettes de 1 a 98 pour traitement specifique a l element
  158. c     dans la zone specifique a chaque element commencant par :
  159. c     5  continue
  160. c     element 5   etiquettes 1005 2005 3005 4005   ...
  161. c     44 continue
  162. c     element 44  etiquettes 1044 2044 3044 4044   ...
  163. c_______________________________________________________________________
  164. c
  165.       GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  166.      1      99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  167.      2      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  168.      3      99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,79,79,
  169.      4      79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  170.      5      99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  171.      6       4, 4),MELE
  172. *
  173.       IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
  174.      .    MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  175.       IF (MELE.GE.173.AND.MELE.LE.182) GOTO 173
  176.       IF (MELE.GE.185.AND.MELE.LE.190) GOTO 185
  177.       IF (MELE.EQ.273.OR.MELE.EQ.274) GOTO 4
  178. *
  179.       GOTO 99
  180.  
  181. c_______________________________________________________________________
  182. c
  183. c   elements massifs et elements incompressibles
  184. c_______________________________________________________________________
  185. c
  186.  4    CONTINUE
  187. c
  188. c  Cas non isotropes :
  189. c  Recuperation des fonctions de forme et leurs derivees au centre de
  190. c  l'element pour le calcul des axes locaux
  191. c
  192.       IPMIN2 = 0
  193.       IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1 ) THEN
  194.         NLG=NUMGEO(MELE)
  195.         CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  196.         MINTE2=IPMIN2
  197.         SEGACT,MINTE2
  198.         SEGINI,WRK8
  199.       ENDIF
  200. c
  201.       NBNO=NBNN
  202.       SEGINI WRK2
  203.       IF (IREPS2.EQ.1) SEGINI MTRACE
  204. c
  205. c*    NDDD=NDEP
  206. c*    IF (IFOUR.EQ.-3) NDDD=NDEP-3
  207.       NDDD=NDEP-NDPGE
  208. c
  209.       DO 3004  IB=1,NBELEM
  210. c
  211. c     on cherche les deplacements
  212. c
  213.         MPTVAL=IVADEP
  214.         IE=1
  215.         DO IGAU=1,NBNN
  216.           DO ICOMP=1,NDDD
  217.             MELVAL=IVAL(ICOMP)
  218.             IGMN=MIN(IGAU,VELCHE(/1))
  219.             IBMN=MIN(IB  ,VELCHE(/2))
  220.             XDDL(IE)=VELCHE(IGMN,IBMN)
  221.             IE=IE+1
  222.           ENDDO
  223.         ENDDO
  224.         IF (BDPGE) THEN
  225.           DO i=1,NDPGE
  226.             XDDL(IE)=UDPGE(i)
  227.             IE=IE+1
  228.           ENDDO
  229.         ENDIF
  230. c
  231. c     on cherche  les coordonnees des noeuds de l element ib
  232. c
  233.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  234. c
  235. c     calcul des axes locaux dans le cas des materiaux orthotropes,
  236. c     anisotropes et unidirectionnel
  237. c
  238. C*      IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  239.         IF (IPMIN2.NE.0) THEN
  240.           NBSH=MINTE2.SHPTOT(/2)
  241.           CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  242.           IF (nbsh.EQ.-1) THEN
  243.             CALL ERREUR(525)
  244.             GOTO 9904
  245.           ENDIF
  246.         ENDIF
  247. c
  248. c     calcul des coeff de modification de la matrice b-barre (incompres)
  249. C
  250.         IF (MFR.EQ.31) THEN
  251.           CALL BBCALC(MELE,NBNN,MFR,IDIM,XE,
  252.      &                NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  253.      &                NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK,
  254.      &                BGENE,XDPGE,YDPGE,PP,NOER)
  255.           IF (NOER.NE.0) THEN
  256.             CALL ERREUR(noer)
  257.             RETURN
  258.           ENDIF
  259.         ENDIF
  260.  
  261. c     boucle sur les points de gauss
  262. c
  263.         ISDJC=0
  264. c
  265.         DO 5004  IGAU=1,NBPTEL
  266. c
  267.           CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  268.      1                MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,1.D0,XE,
  269.      2                SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  270. c
  271.           IF (DJAC.EQ.0.D0) THEN
  272.             INTERR(1)=IB
  273.             CALL ERREUR(259)
  274.             GOTO 9904
  275.           ELSE IF (DJAC.LT.0.D0) THEN
  276.             ISDJC=ISDJC+1
  277.           ENDIF
  278.  
  279. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  280.           IF (MFR.EQ.31) THEN
  281.             CALL BBAR(IGAU,NBPGAU, POIGAU,QSIGAU,ETAGAU,DZEGAU,
  282.      &                MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  283.           ENDIF
  284. c
  285. c       on cherche les matrices de Hooke
  286. c
  287.           MPTVAL=IVAMAT
  288.           IF (IMAT.EQ.2) THEN
  289.             MELVAL=IVAL(1)
  290.             IBMN=MIN(IB  ,IELCHE(/2))
  291.             IGMN=MIN(IGAU,IELCHE(/1))
  292.             MLREEL=IELCHE(IGMN,IBMN)
  293.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  294.               SEGACT MLREEL
  295.               CALL DOHOOO(PROG,LHOOK,DDHOOK)
  296.               SEGDES MLREEL
  297.             ENDIF
  298.           ELSE IF (IMAT.EQ.1) THEN
  299.             DO IM=1,NMATT
  300.               IF (IVAL(IM).NE.0) THEN
  301.                 MELVAL=IVAL(IM)
  302.                 IBMN=MIN(IB  ,VELCHE(/2))
  303.                 IGMN=MIN(IGAU,VELCHE(/1))
  304.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  305.               ELSE
  306.                 VALMAT(IM)=0.D0
  307.               ENDIF
  308.             ENDDO
  309. c
  310.             IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  311.               IF (IGAU.LE.NBGMAT)
  312.      1          CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  313.      2                      ROTH,DDHOOK,LHOOK,1,IRTD)
  314.             ELSE
  315.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  316.      1          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  317.             ENDIF
  318.           ENDIF
  319. c
  320.           CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS)
  321. c
  322. c       calcul des eps 2
  323. c
  324.           IF (IREPS2.EQ.1)
  325.      1      CALL DBST2(SHPWRK,DDHOOK,XDDL,XE,NBNO,IFOUR,NSTRS,XSTRS,
  326.      2                 TRACE,IGAU,XDPGE,YDPGE,UDPGE,NHRM)
  327. c
  328. c       remplissage du segment contenant les contraintes
  329. c
  330.           MPTVAL=IVASTR
  331.           DO ICOMP=1,NSTRS
  332.             MELVAL=IVAL(ICOMP)
  333.             IBMN=MIN(IB,VELCHE(/2))
  334.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  335.           ENDDO
  336. c
  337.  5004   CONTINUE
  338. c
  339.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  340.          if (inoer.eq.0) then
  341.           INTERR(1)=IB
  342.           CALL ERREUR(195)
  343.           GOTO 9904
  344.          else
  345.           call soucis(195)
  346.          ENDIF
  347.         ENDIF
  348. c
  349. c   Correction sur la partie quadratique de la contrainte dans le cas
  350. c   des elements incompressibles
  351. c
  352.         IF (IREPS2.EQ.1) THEN
  353.           IF (MFR.EQ.31) THEN
  354.             CALL DBBST2(TRACE,NBPTEL,IFOUR,MELE,POIGAU,QSIGAU,
  355.      &                  ETAGAU,DZEGAU,SHPTOT,NBNO,SHPWRK,XE,PP)
  356.             L=2
  357.             IF (IDIM.EQ.3 .OR. IFOUR .EQ. 0) L=3
  358.             DO ICOMP=1,L
  359.               MELVAL=IVAL(ICOMP)
  360.               IBMN=MIN(IB  ,VELCHE(/2))
  361.               DO IGAU=1,NBPTEL
  362.                 VELCHE(IGAU,IBMN)=VELCHE(IGAU,IBMN)+TRACE(1,IGAU)
  363.               ENDDO
  364.             ENDDO
  365.             IF (L.EQ.2) THEN
  366.               MELVAL=IVAL(3)
  367.               IBMN=MIN(IB  ,VELCHE(/2))
  368.               DO IGAU=1,NBPTEL
  369.                 VELCHE(IGAU,IBMN) = VELCHE(IGAU,IBMN)
  370.      &              + (TRACE(1,IGAU)/TRACE(2,IGAU)*TRACE(3,IGAU))
  371.               ENDDO
  372.             ENDIF
  373.           ENDIF
  374.         ENDIF
  375.  
  376.  3004 CONTINUE
  377. c
  378.       IF (IRTD.EQ.0) THEN
  379.         MOTERR(1:8)=CMATE
  380.         MOTERR(9:12)=NOMFR(MFR/2+1)
  381.         INTERR(1)=IFOUR
  382.         CALL ERREUR(81)
  383.       ENDIF
  384. c
  385.  9904 CONTINUE
  386.       SEGSUP WRK2
  387.       IF (IREPS2.EQ.1) SEGSUP,MTRACE
  388. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  389.       IF (IPMIN2.NE.0) THEN
  390.         SEGDES MINTE2
  391.         SEGSUP WRK8
  392.       ENDIF
  393.       GOTO 510
  394.  
  395. c____________________________________________________________________
  396. c
  397. c     milieux poreux
  398. c____________________________________________________________________
  399. c
  400.  79   CONTINUE
  401. c
  402. c  Ces cas ne sont pas prevus actuellement !
  403.       IF ( IMAT.EQ.2 .OR.
  404.      &     (IMAT.EQ.1.AND.(MATE.LT.1.OR.MATE.GT.4))
  405.      &   )  GOTO 99
  406.  
  407. c    pour ces elements  nbbb = nombre de noeuds
  408. c                       nbno = nombre de fonctions de forme
  409. c
  410.       NBNO=IPORE
  411.       NSTN=1
  412.       LPP=0
  413. c*****************   AM 08/01/01
  414. c*    NSTMU=2
  415. c*    IF (IFOUR.GE.0) NSTMU=3
  416.       NSTMU=3
  417.       LRN=NBNO-NBBB
  418.       LRB=LRE-LRN
  419. c
  420. c     Cas non isotropes :
  421. c     recuperation des fonctions de forme et leurs derivees
  422. c     au centre de l'element pour le calcul des axes locaux
  423. c
  424.       IPMIN2 = 0
  425.       IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  426.         CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  427.         MINTE2=IPMIN2
  428.         SEGACT MINTE2
  429.         SEGINI WRK8
  430.         NSTMU=LHOOK
  431.       ENDIF
  432. c
  433.       SEGINI WRK2,WRK5
  434. c Segment MTRACE initialise ici, necessaire mais inutilise
  435.       IF (IREPS2.EQ.1) SEGINI MTRACE
  436. c
  437.       I19 =0
  438. c
  439.       DO 3079  IB=1,NBELEM
  440. c
  441. c     on cherche d'abord les deplacements
  442. c
  443.         MPTVAL=IVADEP
  444.         IE=1
  445.         DO IGAU=1,NBNN
  446.           DO ICOMP=1,NDEP-1
  447.             MELVAL=IVAL(ICOMP)
  448.             IGMN=MIN(IGAU,VELCHE(/1))
  449.             IBMN=MIN(IB  ,VELCHE(/2))
  450.             XDDL(IE)=VELCHE(IGMN,IBMN)
  451.             IE=IE+1
  452.           ENDDO
  453.         ENDDO
  454. c
  455. c     puis les pressions
  456. c
  457.         MELVAL=IVAL(NDEP)
  458.         DO IGAU=1,LRN
  459.           IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  460.           IBMN=MIN(IB  ,VELCHE(/2))
  461.           IGMN=MIN(IGAUSO,VELCHE(/1))
  462.           XDDL(IE)=VELCHE(IGMN,IBMN)
  463.           IE=IE+1
  464.         ENDDO
  465. c
  466. c     on cherche  les coordonnees des noeuds de l element ib
  467. c
  468.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  469. c
  470. c     calcul des axes locaux dans le cas des materiaux orthotropes,
  471. c     anisotropes et unidirectionnels
  472. c
  473. C*      IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  474.         IF (IPMIN2.NE.0) THEN
  475.           NBSH=MINTE2.SHPTOT(/2)
  476.           CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  477.           if (nbsh.eq.-1) then
  478.             call erreur(525)
  479.             GOTO 9979
  480.           endif
  481.         ENDIF
  482. c
  483. c     boucle sur les points de gauss
  484. c
  485.         ISDJC=0
  486.         CALL ZERO(COBMA,LHOOK,1)
  487.         DO 5079  IGAU=1,NBPTEL
  488. c
  489.           CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  490.      .                1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  491. c
  492.           IF (DJAC.EQ.0.D0) THEN
  493.             INTERR(1)=IB
  494.             CALL ERREUR(259)
  495.             GOTO 9979
  496.           ELSE IF (DJAC.LT.0.D0) THEN
  497.             ISDJC=ISDJC+1
  498.           ENDIF
  499. c
  500.           MPTVAL=IVAMAT
  501. C*D       IF (IMAT.EQ.2) THEN
  502. C*D cas non prevu
  503. C*D         GO TO 99
  504. C*D       ELSE IF (IMAT.EQ.1) THEN
  505.             DO 9079 IM=1,NMATT
  506.               IF (IVAL(IM).NE.0) THEN
  507.                 MELVAL=IVAL(IM)
  508.                 IBMN=MIN(IB  ,VELCHE(/2))
  509.                 IGMN=MIN(IGAU,VELCHE(/1))
  510.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  511.               ELSE
  512.                 VALMAT(IM)=0.D0
  513.               ENDIF
  514.  9079       CONTINUE
  515.             IF (MATE.EQ.1) THEN
  516.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  517.      .          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  518.             ELSE IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  519.               IF (IGAU.LE.NBGMAT)
  520.      .          CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  521.      .                      ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  522. C*D         ELSE
  523. C*D           GOTO 99
  524.             ENDIF
  525. C*D       ENDIF
  526. c
  527.           CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  528. c
  529. c     calcul des eps 2
  530. c
  531.           IF (IREPS2.EQ.1)
  532.      &      CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,IGAU,
  533.      &                XDPGE,YDPGE,UDPGE,NHRM)
  534. *
  535. *       contribution de epsi a msr0
  536. *
  537.           IF (MATE.EQ.1) THEN
  538. C*D         IF (IMAT.EQ.1) THEN
  539.               DO 4879 I=1,NSTMU
  540.                 COBMA(I)=VALMAT(3)
  541.  4879         CONTINUE
  542.               XMOB=VALMAT(4)
  543. C*D         ELSE IF (IMAT.EQ.2) THEN
  544. C*D           GO TO 99
  545. C*D         ENDIF
  546.           ENDIF
  547. *
  548.           r_z=0.D0
  549.           DO K=1,NSTMU
  550.             r_z = r_z +COBMA(K)*XSTRS(K)
  551.           ENDDO
  552.           XSTRS(NSTRS)=r_z
  553.           DO KA=1,LHOOK
  554.             XWRK(KA)=XSTRS(KA)
  555.          ENDDO
  556. *
  557.           DO 4876 KA=1,LHOOK
  558.             r_z =0.D0
  559.             DO KB=1,LHOOK
  560.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  561.             ENDDO
  562.             XSTRS(KA)=r_z
  563.  4876     CONTINUE
  564. c
  565. c     calcul de l'effet de la pression
  566. c
  567.           IF (XMOB.EQ.0.D0) THEN
  568.             UNSURM=0.D0
  569.           ELSE
  570.             UNSURM=1.D0 / XMOB
  571.           ENDIF
  572. *
  573.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  574.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  575. c
  576. c     remplissage du segment contenant les contraintes
  577. c
  578.           MPTVAL=IVASTR
  579.           DO 7079 ICOMP=1,NSTRS
  580.             MELVAL=IVAL(ICOMP)
  581.             IBMN=MIN(IB  ,VELCHE(/2))
  582.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  583.  7079     CONTINUE
  584. c
  585.  5079   CONTINUE
  586. c
  587.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  588.          if (inoer.eq.0) then
  589.           INTERR(1)=IB
  590.           CALL ERREUR(195)
  591.           GOTO 9979
  592.          else
  593.           call soucis(195)
  594.          ENDIF
  595.         ENDIF
  596. c
  597.  3079 CONTINUE
  598. c
  599.       IF (IRTD.EQ.0) THEN
  600.         MOTERR(1:8)=CMATE
  601.         MOTERR(9:12)=NOMFR(MFR/2+1)
  602.         INTERR(1)=IFOUR
  603.         CALL ERREUR(81)
  604.       ENDIF
  605.       IF (I19.NE.0) CALL ERREUR(19)
  606. c
  607.  9979 CONTINUE
  608.       SEGSUP WRK2,WRK5
  609.       IF (IREPS2.EQ.1) SEGSUP MTRACE
  610. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  611.       IF (IPMIN2.NE.0) THEN
  612.         SEGDES MINTE2
  613.         SEGSUP WRK8
  614.       ENDIF
  615.       GOTO 510
  616.  
  617. c____________________________________________________________________
  618. c
  619. c     milieux poreux  SUITE
  620. c____________________________________________________________________
  621. c
  622.  173  CONTINUE
  623. c
  624. c  Ces cas ne sont pas prevus actuellement !
  625.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  626. c
  627. c    pour ces elements  nbbb = nombre de noeuds
  628. c                       nbno = nombre de fonctions de forme
  629. c
  630.       IF (MELE.GE.173.AND.MELE.LE.177) THEN
  631.         IDECAP = 2
  632.       ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  633.         IDECAP = 3
  634.       ENDIF
  635. *
  636.       NBNO=IPORE
  637.       NSTN=IDECAP
  638.       NSTB=4
  639.       IF(IFOUR.EQ.2) NSTB=6
  640.  
  641.       LPP=NBNO-NBBB
  642.       LRN=IDECAP*LPP
  643.       LRB=LRE-LRN
  644.  
  645.       UNSURM = 0.
  646.  
  647.       SEGINI WRK2,WRK5
  648. c Segment MTRACE initialise ici (necessaire mais inutilise)
  649.       IF (IREPS2.EQ.1) SEGINI MTRACE
  650.  
  651.       I19 =0
  652. c
  653.       DO 3173  IB=1,NBELEM
  654. c
  655. c     on cherche d'abord les deplacements
  656. c
  657.         IE=1
  658.         MPTVAL=IVADEP
  659.         DO IGAU=1,NBNN
  660.           DO ICOMP=1,NDEP-IDECAP
  661.             MELVAL=IVAL(ICOMP)
  662.             IGMN=MIN(IGAU,VELCHE(/1))
  663.             IBMN=MIN(IB  ,VELCHE(/2))
  664.             XDDL(IE)=VELCHE(IGMN,IBMN)
  665.             IE=IE+1
  666.           ENDDO
  667.         ENDDO
  668. c
  669. c     puis les pressions
  670. c
  671.         DO IPR = 1,IDECAP
  672.           MELVAL=IVAL(NDEP-IDECAP+IPR)
  673.           DO IGAU=1,LPP
  674.             IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  675.             IBMN=MIN(IB  ,VELCHE(/2))
  676.             IGMN=MIN(IGAUSO,VELCHE(/1))
  677.             XDDL(IE)=VELCHE(IGMN,IBMN)
  678.             IE=IE+1
  679.           ENDDO
  680.         ENDDO
  681. c
  682. c     on cherche  les coordonnees des noeuds de l element ib
  683. c
  684.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  685. c
  686. c     boucle sur les points de gauss
  687. c
  688.         ISDJC=0
  689.         CALL ZERO (COBB,IDECAP,1)
  690.         CALL ZERO (CPBB,IDECAP,1)
  691.         CALL ZERO (KKBB,IDECAP,IDECAP)
  692. c
  693.         DO 5173  IGAU=1,NBPTEL
  694. c
  695.           CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  696.      &        1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  697. c
  698.           IF (DJAC.EQ.0.D0) THEN
  699.             INTERR(1)=IB
  700.             CALL ERREUR(259)
  701.             GOTO 9973
  702.           ELSE IF (DJAC.LT.0.D0) THEN
  703.             ISDJC=ISDJC+1
  704.           ENDIF
  705. c
  706.           MPTVAL=IVAMAT
  707. C*D       IF (IMAT.EQ.2) THEN
  708. C*D         GO TO 99
  709. C*D       ELSE IF (IMAT.EQ.1) THEN
  710.             DO 6173 IM=1,NMATT
  711.               IF (IVAL(IM).NE.0) THEN
  712.                 MELVAL=IVAL(IM)
  713.                 IBMN=MIN(IB  ,VELCHE(/2))
  714.                 IGMN=MIN(IGAU,VELCHE(/1))
  715.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  716.               ELSE
  717.                 VALMAT(IM)=0.D0
  718.               ENDIF
  719.  6173       CONTINUE
  720. C*D         IF (MATE.EQ.1) THEN
  721.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  722.      .          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  723. C*D         ELSE
  724. C*D           GOTO 99
  725. C*D         ENDIF
  726. C*D       ENDIF
  727. c
  728.           IF (MFR.EQ.57) THEN
  729.             COBB(1)  = VALMAT(3)
  730.             COBB(2)  = VALMAT(4)
  731.             CPBB(1)  = VALMAT(5)
  732.             CPBB(2)  = VALMAT(6)
  733.             KKBB(1,1)= VALMAT(7)
  734.             KKBB(1,2)= VALMAT(8)
  735.             KKBB(2,1)= VALMAT(9)
  736.             KKBB(2,2)= VALMAT(10)
  737.           ELSE IF(MFR.EQ.59) THEN
  738.             COBB(1)  = VALMAT(3)
  739.             COBB(2)  = VALMAT(4)
  740.             COBB(3)  = VALMAT(5)
  741.             CPBB(1)  = VALMAT(6)
  742.             CPBB(2)  = VALMAT(7)
  743.             CPBB(3)  = VALMAT(8)
  744.             KKBB(1,1)= VALMAT(9)
  745.             KKBB(1,2)= VALMAT(10)
  746.             KKBB(1,3)= VALMAT(11)
  747.             KKBB(2,1)= VALMAT(12)
  748.             KKBB(2,2)= VALMAT(13)
  749.             KKBB(2,3)= VALMAT(14)
  750.             KKBB(3,1)= VALMAT(15)
  751.             KKBB(3,2)= VALMAT(16)
  752.             KKBB(3,3)= VALMAT(17)
  753.           ENDIF
  754. c
  755.           CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  756. c
  757. c     calcul des eps 2
  758. c
  759.           IF (IREPS2.EQ.1)
  760.      &      CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,IGAU,
  761.      &                XDPGE,YDPGE,UDPGE,NHRM)
  762. c
  763. c       contribution de epsi a msr0
  764. c
  765.           TRACEP=XSTRS(1)+XSTRS(2)+XSTRS(3)
  766.           DO K=1,IDECAP
  767.             XSTRS(NSTRS-IDECAP+K)=CPBB(K)*TRACEP
  768.           ENDDO
  769.           DO KA=1,LHOOK
  770.             XWRK(KA)=XSTRS(KA)
  771.           ENDDO
  772.           DO KA=1,LHOOK
  773.             r_z = 0.D0
  774.             DO KB=1,LHOOK
  775.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  776.             ENDDO
  777.             XSTRS(KA) = r_z
  778.           ENDDO
  779. c
  780. c     calcul de l'effet de la pression
  781. c
  782.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  783.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  784. c
  785. c     remplissage du segment contenant les contraintes
  786. c
  787.           MPTVAL=IVASTR
  788.           DO ICOMP=1,NSTRS
  789.             MELVAL=IVAL(ICOMP)
  790.             IBMN=MIN(IB  ,VELCHE(/2))
  791.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  792.           ENDDO
  793. c
  794.  5173   CONTINUE
  795. c
  796.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  797.          if (inoer.eq.0) then
  798.           INTERR(1)=IB
  799.           CALL ERREUR(195)
  800.           GOTO 9973
  801.          else
  802.           call soucis(195)
  803.          ENDIF
  804.         ENDIF
  805. c
  806.  3173 CONTINUE
  807. c
  808.       IF (I19.NE.0) CALL ERREUR(19)
  809.       IF (IRTD.EQ.0) THEN
  810.         MOTERR(1:8)=CMATE
  811.         MOTERR(9:12)=NOMFR(MFR/2+1)
  812.         INTERR(1)=IFOUR
  813.         CALL ERREUR(81)
  814.       ENDIF
  815.  9973 CONTINUE
  816.       SEGSUP WRK2,WRK5
  817.       IF (IREPS2.EQ.1) SEGSUP MTRACE
  818.       GOTO 510
  819.  
  820. c____________________________________________________________________
  821. c
  822. c     joints poreux
  823. c____________________________________________________________________
  824. c
  825.  80   CONTINUE
  826. c  Ces cas ne sont pas prevus actuellement !
  827.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  828. c
  829. c    pour ces elements  nbbb = nombre de noeuds
  830. c                       nbno = nombre de fonctions de forme
  831. c
  832.       NBNO=IPORE
  833.       NSTN=1
  834.       NSTMU=2
  835.       IF (IFOUR.EQ.2) NSTMU=3
  836.       LRN=(NBNO-NBBB)*3/2
  837.       LRB=LRE-LRN
  838.       NFAC=(3*NBBB-NBNO)/2
  839. c
  840.       SEGINI WRK2,WRK3,WRK5
  841. c
  842.       I19 =0
  843. c
  844.       DO 3080  IB=1,NBELEM
  845. c
  846. c     on cherche d'abord les deplacements
  847. c
  848.         MPTVAL=IVADEP
  849.         IE=1
  850.         DO 4180 IGAU=1,NFAC
  851.           DO 4280 ICOMP=1,NDEP-1
  852.             MELVAL=IVAL(ICOMP)
  853.             IGMN=MIN(IGAU,VELCHE(/1))
  854.             IBMN=MIN(IB  ,VELCHE(/2))
  855.             XDDL(IE)=VELCHE(IGMN,IBMN)
  856.             IE=IE+1
  857.  4280     CONTINUE
  858.  4180   CONTINUE
  859. c
  860. c     puis les pressions
  861. c
  862.         MELVAL=IVAL(NDEP)
  863.         DO 4080 IGAU=1,NBNN
  864.           DO 4190 INSOM=1,NBSOM(IELE)
  865.             IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GOTO 4191
  866. 4190      CONTINUE
  867.           IF (IGAU.GT.NFAC) GOTO 4191
  868.           GOTO 4080
  869. 4191      CONTINUE
  870.           IBMN=MIN(IB  ,VELCHE(/2))
  871.           IGMN=MIN(IGAU,VELCHE(/1))
  872.           XDDL(IE)=VELCHE(IGMN,IBMN)
  873.           IE=IE+1
  874.  4080   CONTINUE
  875. c
  876. c     on cherche  les coordonnees des noeuds de l element ib
  877. c
  878.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  879. c
  880. c     calcul des exes locaux et des coordonnees locales
  881. c
  882.         CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  883. c
  884. c     boucle sur les points de gauss
  885. c
  886.         ISDJC=0
  887.         CALL ZERO(COBMA,LHOOK,1)
  888. c
  889.         DO 5080  IGAU=1,NBPTEL
  890. c
  891.           CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  892.      .                SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  893. c
  894.           IF (DJAC.EQ.0.D0) THEN
  895.             INTERR(1)=IB
  896.             CALL ERREUR(259)
  897.             GOTO 9980
  898.           ELSE IF (DJAC.LT.0.D0) THEN
  899.             ISDJC=ISDJC+1
  900.           ENDIF
  901. c
  902.           MPTVAL=IVAMAT
  903. C*D       IF (IMAT.EQ.2) THEN
  904. C*D         GO TO 99
  905. C*D       ELSE IF (IMAT.EQ.1) THEN
  906.             DO 9080 IM=1,NMATT
  907.               IF (IVAL(IM).NE.0) THEN
  908.                 MELVAL=IVAL(IM)
  909.                 IBMN=MIN(IB  ,VELCHE(/2))
  910.                 IGMN=MIN(IGAU,VELCHE(/1))
  911.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  912.               ELSE
  913.                 VALMAT(IM)=0.D0
  914.               ENDIF
  915.  9080       CONTINUE
  916. C*D         IF (MATE.EQ.1) THEN
  917.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  918.      &          CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  919. C*D         ELSE
  920. C*D           GO TO 99
  921. C*D         ENDIF
  922. C*D       ENDIF
  923. c
  924.           CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  925. c
  926. c       contribution de epsi a msr0
  927. c
  928.           IF (IMAT.EQ.1) THEN
  929.             COBMA(NSTMU)=VALMAT(3)
  930.             XMOB=VALMAT(4)
  931.           ENDIF
  932.           XSTRS(NSTRS)=COBMA(NSTMU)*XSTRS(NSTMU)
  933.  
  934.           DO 4887 KA=1,LHOOK
  935.             XWRK(KA)=XSTRS(KA)
  936.  4887     CONTINUE
  937.  
  938.           DO 4886 KA=1,LHOOK
  939.             r_z = 0.D0
  940.             DO KB=1,LHOOK
  941.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  942.             ENDDO
  943.             XSTRS(KA)= r_z
  944.  4886     CONTINUE
  945. c
  946. c     calcul de l'effet de la pression
  947. c
  948.           IF (XMOB.EQ.0.D0) THEN
  949.             UNSURM=0.D0
  950.           ELSE
  951.             UNSURM=1.D0 / XMOB
  952.           ENDIF
  953. c
  954.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  955.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  956. c
  957. c     remplissage du segment contenant les contraintes
  958. c
  959.           MPTVAL=IVASTR
  960.           DO 7080 ICOMP=1,NSTRS
  961.             MELVAL=IVAL(ICOMP)
  962.             IBMN=MIN(IB  ,VELCHE(/2))
  963.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  964.  7080     CONTINUE
  965. c
  966.  5080   CONTINUE
  967. c
  968.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  969.          if (inoer.eq.0) then
  970.           INTERR(1)=IB
  971.           CALL ERREUR(195)
  972.           GOTO 9980
  973.          else
  974.           call soucis(195)
  975.          ENDIF
  976.         ENDIF
  977. c
  978.  3080 CONTINUE
  979. c
  980.       IF (IRTD.EQ.0) THEN
  981.         MOTERR(1:8)=CMATE
  982.         MOTERR(9:12)=NOMFR(MFR/2+1)
  983.         INTERR(1)=IFOUR
  984.         CALL ERREUR(81)
  985.       ENDIF
  986.       IF (I19.NE.0) CALL ERREUR(19)
  987.  9980 CONTINUE
  988.       SEGSUP,WRK2,WRK3,WRK5
  989.       GOTO 510
  990.  
  991.  
  992. c____________________________________________________________________
  993. c
  994. c     joints poreux  - SUITE
  995. c____________________________________________________________________
  996. c
  997. 185   CONTINUE
  998. c  Ces cas ne sont pas prevus actuellement !
  999.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  1000. c
  1001. c    pour ces elements  nbbb = nombre de noeuds
  1002. c                       nbno = nombre de fonctions de forme
  1003. c
  1004.       IF (MELE.GE.185.AND.MELE.LE.187) THEN
  1005.         IDECAP = 2
  1006.       ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  1007.         IDECAP = 3
  1008.       ENDIF
  1009.  
  1010.       NBNO=IPORE
  1011.       NSTN=IDECAP
  1012.       NSTMU=2
  1013.       IF (IFOUR.EQ.2) NSTMU=3
  1014.       NSTB=NSTMU
  1015.       LPP=(NBNO-NBBB)*3/2
  1016.       LRN=IDECAP*LPP
  1017.       LRB=LRE-LRN
  1018.  
  1019.       UNSURM = 0.
  1020.  
  1021.       NFAC=(3*NBBB-NBNO)/2
  1022. c
  1023.       SEGINI WRK2,WRK3,WRK5
  1024. c
  1025.       I19 =0
  1026. c
  1027.       DO 3185  IB=1,NBELEM
  1028. c
  1029. c     on cherche d'abord les deplacements
  1030. c
  1031.         MPTVAL=IVADEP
  1032.         IE=1
  1033.         DO 4185 IGAU=1,NFAC
  1034.           DO 4285 ICOMP=1,NDEP-1
  1035.             MELVAL=IVAL(ICOMP)
  1036.             IGMN=MIN(IGAU,VELCHE(/1))
  1037.             IBMN=MIN(IB  ,VELCHE(/2))
  1038.             XDDL(IE)=VELCHE(IGMN,IBMN)
  1039.             IE=IE+1
  1040.  4285     CONTINUE
  1041.  4185   CONTINUE
  1042. c
  1043. c     puis les pressions
  1044. c
  1045.         DO 4585 IPR=1,IDECAP
  1046.           MELVAL=IVAL(NDEP-IDECAP+IPR)
  1047.           DO 4085 IGAU=1,NBNN
  1048.             DO 4195 INSOM=1,NBSOM(IELE)
  1049.               IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GOTO 4995
  1050. 4195        CONTINUE
  1051.             IF (IGAU.GT.NFAC) GOTO 4995
  1052.             GOTO 4085
  1053. 4995        CONTINUE
  1054.             IBMN=MIN(IB  ,VELCHE(/2))
  1055.             IGMN=MIN(IGAU,VELCHE(/1))
  1056.             XDDL(IE)=VELCHE(IGMN,IBMN)
  1057.             IE=IE+1
  1058.  4085     CONTINUE
  1059.  4585   CONTINUE
  1060. c
  1061. c     on cherche  les coordonnees des noeuds de l element ib
  1062. c
  1063.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1064. c
  1065. c     calcul des exes locaux et des coordonnees locales
  1066. c
  1067.         CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1068. c
  1069. c     boucle sur les points de gauss
  1070. c
  1071.         ISDJC=0
  1072.         CALL ZERO (COBB,IDECAP,1)
  1073.         CALL ZERO (CPBB,IDECAP,1)
  1074.         CALL ZERO (KKBB,IDECAP,IDECAP)
  1075. c
  1076.         DO 5185  IGAU=1,NBPTEL
  1077. c
  1078.           CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1079.      &         SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1080. c
  1081.           IF (DJAC.EQ.0.D0) THEN
  1082.             INTERR(1)=IB
  1083.             CALL ERREUR(259)
  1084.             GOTO 9980
  1085.           ELSE IF (DJAC.LT.0.D0) THEN
  1086.             ISDJC=ISDJC+1
  1087.           ENDIF
  1088. c
  1089.           MPTVAL=IVAMAT
  1090. C*D       IF (IMAT.EQ.2) THEN
  1091. C*D         GO TO 99
  1092. C*D       ELSE IF (IMAT.EQ.1) THEN
  1093.             DO 9185 IM=1,NMATT
  1094.               IF (IVAL(IM).NE.0) THEN
  1095.                 MELVAL=IVAL(IM)
  1096.                 IBMN=MIN(IB  ,VELCHE(/2))
  1097.                 IGMN=MIN(IGAU,VELCHE(/1))
  1098.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  1099.               ELSE
  1100.                 VALMAT(IM)=0.D0
  1101.               ENDIF
  1102.  9185       CONTINUE
  1103. C*D         IF (MATE.EQ.1) THEN
  1104.  
  1105. *ZZZZZZZZZZZZZ   VOIR SI LHOOK POSE PB A CE NIVEAU ????
  1106.  
  1107.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1108.      &          CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1109. C*D         ELSE
  1110. C*D           GO TO 99
  1111. C*D         ENDIF
  1112. C*D       ENDIF
  1113. c
  1114.           CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  1115. c
  1116. c       contribution de epsi a msr0
  1117. c
  1118.           IF (MFR.EQ.57) THEN
  1119.             COBB(1)  = VALMAT(3)
  1120.             COBB(2)  = VALMAT(4)
  1121.             CPBB(1)  = VALMAT(5)
  1122.             CPBB(2)  = VALMAT(6)
  1123.             KKBB(1,1)= VALMAT(7)
  1124.             KKBB(1,2)= VALMAT(8)
  1125.             KKBB(2,1)= VALMAT(9)
  1126.             KKBB(2,2)= VALMAT(10)
  1127.           ELSE IF(MFR.EQ.59) THEN
  1128.             COBB(1)  = VALMAT(3)
  1129.             COBB(2)  = VALMAT(4)
  1130.             COBB(3)  = VALMAT(5)
  1131.             CPBB(1)  = VALMAT(6)
  1132.             CPBB(2)  = VALMAT(7)
  1133.             CPBB(3)  = VALMAT(8)
  1134.             KKBB(1,1)= VALMAT(9)
  1135.             KKBB(1,2)= VALMAT(10)
  1136.             KKBB(1,3)= VALMAT(11)
  1137.             KKBB(2,1)= VALMAT(12)
  1138.             KKBB(2,2)= VALMAT(13)
  1139.             KKBB(2,3)= VALMAT(14)
  1140.             KKBB(3,1)= VALMAT(15)
  1141.             KKBB(3,2)= VALMAT(16)
  1142.             KKBB(3,3)= VALMAT(17)
  1143.           ENDIF
  1144. c
  1145. CCCCC  ICI  A FINIR   PENSER A BNQORE AUSSI A CORRIGER
  1146.  
  1147.  
  1148.           XSTRS(NSTRS)=COBMA(NSTMU)*XSTRS(NSTMU)
  1149.  
  1150.           DO 4885 KA=1,LHOOK
  1151.             XWRK(KA)=XSTRS(KA)
  1152.  4885     CONTINUE
  1153.  
  1154.           DO 4785 KA=1,LHOOK
  1155.             r_z = 0.D0
  1156.             DO KB=1,LHOOK
  1157.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  1158.             ENDDO
  1159.             XSTRS(KA)= r_z
  1160.  4785     CONTINUE
  1161. c
  1162. c     calcul de l'effet de la pression
  1163. c
  1164.           IF (XMOB.EQ.0.D0) THEN
  1165.             UNSURM=0.D0
  1166.           ELSE
  1167.             UNSURM=1.D0 / XMOB
  1168.           ENDIF
  1169. c
  1170.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  1171.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  1172. c
  1173. c     remplissage du segment contenant les contraintes
  1174. c
  1175.           MPTVAL=IVASTR
  1176.           DO 7185 ICOMP=1,NSTRS
  1177.             MELVAL=IVAL(ICOMP)
  1178.             IBMN=MIN(IB  ,VELCHE(/2))
  1179.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1180.  7185     CONTINUE
  1181. c
  1182.  5185   CONTINUE
  1183. c
  1184.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1185.          if (inoer.eq.0) then
  1186.           INTERR(1)=IB
  1187.           CALL ERREUR(195)
  1188.           GOTO 9985
  1189.          else
  1190.           call soucis(195)
  1191.          ENDIF
  1192.         ENDIF
  1193. c
  1194.  3185 CONTINUE
  1195. c
  1196.       IF (IRTD.EQ.0) THEN
  1197.         MOTERR(1:8)=CMATE
  1198.         MOTERR(9:12)=NOMFR(MFR/2+1)
  1199.         INTERR(1)=IFOUR
  1200.         CALL ERREUR(81)
  1201.       ENDIF
  1202.       IF (I19.NE.0) CALL ERREUR(19)
  1203.  9985 CONTINUE
  1204.       SEGSUP,WRK2,WRK3,WRK5
  1205.       GOTO 510
  1206.  
  1207. c____________________________________________________________________
  1208.   99  CONTINUE
  1209.       MOTERR(1:4)=NOMTP(MELE)
  1210.       MOTERR(9:12)='SIGM'
  1211.       CALL ERREUR(86)
  1212.  
  1213. C- Fin du sous-programme
  1214.  510  CONTINUE
  1215.       SEGSUP,MVELCH,WRK1
  1216.  
  1217.       RETURN
  1218.       END
  1219.  
  1220.  
  1221.  
  1222.  

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