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    OF166741  25/02/21    21:18:34     12166          
  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)
  255.         ENDIF
  256.  
  257. c     boucle sur les points de gauss
  258. c
  259.         ISDJC=0
  260. c
  261.         DO 5004  IGAU=1,NBPTEL
  262. c
  263.           CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  264.      1                MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,1.D0,XE,
  265.      2                SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  266. c
  267.           IF (DJAC.EQ.0.D0) THEN
  268.             INTERR(1)=IB
  269.             CALL ERREUR(259)
  270.             GOTO 9904
  271.           ELSE IF (DJAC.LT.0.D0) THEN
  272.             ISDJC=ISDJC+1
  273.           ENDIF
  274.  
  275. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  276.           IF (MFR.EQ.31) THEN
  277.             CALL BBAR(IGAU,NBPGAU, POIGAU,QSIGAU,ETAGAU,DZEGAU,
  278.      &                MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  279.           ENDIF
  280. c
  281. c       on cherche les matrices de Hooke
  282. c
  283.           MPTVAL=IVAMAT
  284.           IF (IMAT.EQ.2) THEN
  285.             MELVAL=IVAL(1)
  286.             IBMN=MIN(IB  ,IELCHE(/2))
  287.             IGMN=MIN(IGAU,IELCHE(/1))
  288.             MLREEL=IELCHE(IGMN,IBMN)
  289.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  290.               SEGACT MLREEL
  291.               CALL DOHOOO(PROG,LHOOK,DDHOOK)
  292.               SEGDES MLREEL
  293.             ENDIF
  294.           ELSE IF (IMAT.EQ.1) THEN
  295.             DO IM=1,NMATT
  296.               IF (IVAL(IM).NE.0) THEN
  297.                 MELVAL=IVAL(IM)
  298.                 IBMN=MIN(IB  ,VELCHE(/2))
  299.                 IGMN=MIN(IGAU,VELCHE(/1))
  300.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  301.               ELSE
  302.                 VALMAT(IM)=0.D0
  303.               ENDIF
  304.             ENDDO
  305. c
  306.             IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  307.               IF (IGAU.LE.NBGMAT)
  308.      1          CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  309.      2                      ROTH,DDHOOK,LHOOK,1,IRTD)
  310.             ELSE
  311.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  312.      1          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  313.             ENDIF
  314.           ENDIF
  315. c
  316.           CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS)
  317. c
  318. c       calcul des eps 2
  319. c
  320.           IF (IREPS2.EQ.1)
  321.      1      CALL DBST2(SHPWRK,DDHOOK,XDDL,XE,NBNO,IFOUR,NSTRS,XSTRS,
  322.      2                 TRACE,IGAU,XDPGE,YDPGE,UDPGE,NHRM)
  323. c
  324. c       remplissage du segment contenant les contraintes
  325. c
  326.           MPTVAL=IVASTR
  327.           DO ICOMP=1,NSTRS
  328.             MELVAL=IVAL(ICOMP)
  329.             IBMN=MIN(IB,VELCHE(/2))
  330.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  331.           ENDDO
  332. c
  333.  5004   CONTINUE
  334. c
  335.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  336.          if (inoer.eq.0) then
  337.           INTERR(1)=IB
  338.           CALL ERREUR(195)
  339.           GOTO 9904
  340.          else
  341.           call soucis(195)
  342.          ENDIF
  343.         ENDIF
  344. c
  345. c   Correction sur la partie quadratique de la contrainte dans le cas
  346. c   des elements incompressibles
  347. c
  348.         IF (IREPS2.EQ.1) THEN
  349.           IF (MFR.EQ.31) THEN
  350.             CALL DBBST2(TRACE,NBPTEL,IFOUR,MELE,POIGAU,QSIGAU,
  351.      &                  ETAGAU,DZEGAU,SHPTOT,NBNO,SHPWRK,XE,PP)
  352.             L=2
  353.             IF (IDIM.EQ.3 .OR. IFOUR .EQ. 0) L=3
  354.             DO ICOMP=1,L
  355.               MELVAL=IVAL(ICOMP)
  356.               IBMN=MIN(IB  ,VELCHE(/2))
  357.               DO IGAU=1,NBPTEL
  358.                 VELCHE(IGAU,IBMN)=VELCHE(IGAU,IBMN)+TRACE(1,IGAU)
  359.               ENDDO
  360.             ENDDO
  361.             IF (L.EQ.2) THEN
  362.               MELVAL=IVAL(3)
  363.               IBMN=MIN(IB  ,VELCHE(/2))
  364.               DO IGAU=1,NBPTEL
  365.                 VELCHE(IGAU,IBMN) = VELCHE(IGAU,IBMN)
  366.      &              + (TRACE(1,IGAU)/TRACE(2,IGAU)*TRACE(3,IGAU))
  367.               ENDDO
  368.             ENDIF
  369.           ENDIF
  370.         ENDIF
  371.  
  372.  3004 CONTINUE
  373. c
  374.       IF (IRTD.EQ.0) THEN
  375.         MOTERR(1:8)=CMATE
  376.         MOTERR(9:12)=NOMFR(MFR/2+1)
  377.         INTERR(1)=IFOUR
  378.         CALL ERREUR(81)
  379.       ENDIF
  380. c
  381.  9904 CONTINUE
  382.       SEGSUP WRK2
  383.       IF (IREPS2.EQ.1) SEGSUP,MTRACE
  384. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  385.       IF (IPMIN2.NE.0) THEN
  386.         SEGDES MINTE2
  387.         SEGSUP WRK8
  388.       ENDIF
  389.       GOTO 510
  390.  
  391. c____________________________________________________________________
  392. c
  393. c     milieux poreux
  394. c____________________________________________________________________
  395. c
  396.  79   CONTINUE
  397. c
  398. c  Ces cas ne sont pas prevus actuellement !
  399.       IF ( IMAT.EQ.2 .OR.
  400.      &     (IMAT.EQ.1.AND.(MATE.LT.1.OR.MATE.GT.4))
  401.      &   )  GOTO 99
  402.  
  403. c    pour ces elements  nbbb = nombre de noeuds
  404. c                       nbno = nombre de fonctions de forme
  405. c
  406.       NBNO=IPORE
  407.       NSTN=1
  408.       LPP=0
  409. c*****************   AM 08/01/01
  410. c*    NSTMU=2
  411. c*    IF (IFOUR.GE.0) NSTMU=3
  412.       NSTMU=3
  413.       LRN=NBNO-NBBB
  414.       LRB=LRE-LRN
  415. c
  416. c     Cas non isotropes :
  417. c     recuperation des fonctions de forme et leurs derivees
  418. c     au centre de l'element pour le calcul des axes locaux
  419. c
  420.       IPMIN2 = 0
  421.       IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  422.         CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  423.         MINTE2=IPMIN2
  424.         SEGACT MINTE2
  425.         SEGINI WRK8
  426.         NSTMU=LHOOK
  427.       ENDIF
  428. c
  429.       SEGINI WRK2,WRK5
  430. c Segment MTRACE initialise ici, necessaire mais inutilise
  431.       IF (IREPS2.EQ.1) SEGINI MTRACE
  432. c
  433.       I19 =0
  434. c
  435.       DO 3079  IB=1,NBELEM
  436. c
  437. c     on cherche d'abord les deplacements
  438. c
  439.         MPTVAL=IVADEP
  440.         IE=1
  441.         DO IGAU=1,NBNN
  442.           DO ICOMP=1,NDEP-1
  443.             MELVAL=IVAL(ICOMP)
  444.             IGMN=MIN(IGAU,VELCHE(/1))
  445.             IBMN=MIN(IB  ,VELCHE(/2))
  446.             XDDL(IE)=VELCHE(IGMN,IBMN)
  447.             IE=IE+1
  448.           ENDDO
  449.         ENDDO
  450. c
  451. c     puis les pressions
  452. c
  453.         MELVAL=IVAL(NDEP)
  454.         DO IGAU=1,LRN
  455.           IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  456.           IBMN=MIN(IB  ,VELCHE(/2))
  457.           IGMN=MIN(IGAUSO,VELCHE(/1))
  458.           XDDL(IE)=VELCHE(IGMN,IBMN)
  459.           IE=IE+1
  460.         ENDDO
  461. c
  462. c     on cherche  les coordonnees des noeuds de l element ib
  463. c
  464.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  465. c
  466. c     calcul des axes locaux dans le cas des materiaux orthotropes,
  467. c     anisotropes et unidirectionnels
  468. c
  469. C*      IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  470.         IF (IPMIN2.NE.0) THEN
  471.           NBSH=MINTE2.SHPTOT(/2)
  472.           CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  473.           if (nbsh.eq.-1) then
  474.             call erreur(525)
  475.             GOTO 9979
  476.           endif
  477.         ENDIF
  478. c
  479. c     boucle sur les points de gauss
  480. c
  481.         ISDJC=0
  482.         CALL ZERO(COBMA,LHOOK,1)
  483.         DO 5079  IGAU=1,NBPTEL
  484. c
  485.           CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  486.      .                1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  487. c
  488.           IF (DJAC.EQ.0.D0) THEN
  489.             INTERR(1)=IB
  490.             CALL ERREUR(259)
  491.             GOTO 9979
  492.           ELSE IF (DJAC.LT.0.D0) THEN
  493.             ISDJC=ISDJC+1
  494.           ENDIF
  495. c
  496.           MPTVAL=IVAMAT
  497. C*D       IF (IMAT.EQ.2) THEN
  498. C*D cas non prevu
  499. C*D         GO TO 99
  500. C*D       ELSE IF (IMAT.EQ.1) THEN
  501.             DO 9079 IM=1,NMATT
  502.               IF (IVAL(IM).NE.0) THEN
  503.                 MELVAL=IVAL(IM)
  504.                 IBMN=MIN(IB  ,VELCHE(/2))
  505.                 IGMN=MIN(IGAU,VELCHE(/1))
  506.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  507.               ELSE
  508.                 VALMAT(IM)=0.D0
  509.               ENDIF
  510.  9079       CONTINUE
  511.             IF (MATE.EQ.1) THEN
  512.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  513.      .          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  514.             ELSE IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  515.               IF (IGAU.LE.NBGMAT)
  516.      .          CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  517.      .                      ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  518. C*D         ELSE
  519. C*D           GOTO 99
  520.             ENDIF
  521. C*D       ENDIF
  522. c
  523.           CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  524. c
  525. c     calcul des eps 2
  526. c
  527.           IF (IREPS2.EQ.1)
  528.      &      CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,IGAU,
  529.      &                XDPGE,YDPGE,UDPGE,NHRM)
  530. *
  531. *       contribution de epsi a msr0
  532. *
  533.           IF (MATE.EQ.1) THEN
  534. C*D         IF (IMAT.EQ.1) THEN
  535.               DO 4879 I=1,NSTMU
  536.                 COBMA(I)=VALMAT(3)
  537.  4879         CONTINUE
  538.               XMOB=VALMAT(4)
  539. C*D         ELSE IF (IMAT.EQ.2) THEN
  540. C*D           GO TO 99
  541. C*D         ENDIF
  542.           ENDIF
  543. *
  544.           r_z=0.D0
  545.           DO K=1,NSTMU
  546.             r_z = r_z +COBMA(K)*XSTRS(K)
  547.           ENDDO
  548.           XSTRS(NSTRS)=r_z
  549.           DO KA=1,LHOOK
  550.             XWRK(KA)=XSTRS(KA)
  551.          ENDDO
  552. *
  553.           DO 4876 KA=1,LHOOK
  554.             r_z =0.D0
  555.             DO KB=1,LHOOK
  556.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  557.             ENDDO
  558.             XSTRS(KA)=r_z
  559.  4876     CONTINUE
  560. c
  561. c     calcul de l'effet de la pression
  562. c
  563.           IF (XMOB.EQ.0.D0) THEN
  564.             UNSURM=0.D0
  565.           ELSE
  566.             UNSURM=1.D0 / XMOB
  567.           ENDIF
  568. *
  569.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  570.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  571. c
  572. c     remplissage du segment contenant les contraintes
  573. c
  574.           MPTVAL=IVASTR
  575.           DO 7079 ICOMP=1,NSTRS
  576.             MELVAL=IVAL(ICOMP)
  577.             IBMN=MIN(IB  ,VELCHE(/2))
  578.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  579.  7079     CONTINUE
  580. c
  581.  5079   CONTINUE
  582. c
  583.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  584.          if (inoer.eq.0) then
  585.           INTERR(1)=IB
  586.           CALL ERREUR(195)
  587.           GOTO 9979
  588.          else
  589.           call soucis(195)
  590.          ENDIF
  591.         ENDIF
  592. c
  593.  3079 CONTINUE
  594. c
  595.       IF (IRTD.EQ.0) THEN
  596.         MOTERR(1:8)=CMATE
  597.         MOTERR(9:12)=NOMFR(MFR/2+1)
  598.         INTERR(1)=IFOUR
  599.         CALL ERREUR(81)
  600.       ENDIF
  601.       IF (I19.NE.0) CALL ERREUR(19)
  602. c
  603.  9979 CONTINUE
  604.       SEGSUP WRK2,WRK5
  605.       IF (IREPS2.EQ.1) SEGSUP MTRACE
  606. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  607.       IF (IPMIN2.NE.0) THEN
  608.         SEGDES MINTE2
  609.         SEGSUP WRK8
  610.       ENDIF
  611.       GOTO 510
  612.  
  613. c____________________________________________________________________
  614. c
  615. c     milieux poreux  SUITE
  616. c____________________________________________________________________
  617. c
  618.  173  CONTINUE
  619. c
  620. c  Ces cas ne sont pas prevus actuellement !
  621.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  622. c
  623. c    pour ces elements  nbbb = nombre de noeuds
  624. c                       nbno = nombre de fonctions de forme
  625. c
  626.       IF (MELE.GE.173.AND.MELE.LE.177) THEN
  627.         IDECAP = 2
  628.       ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  629.         IDECAP = 3
  630.       ENDIF
  631. *
  632.       NBNO=IPORE
  633.       NSTN=IDECAP
  634.       NSTB=4
  635.       IF(IFOUR.EQ.2) NSTB=6
  636.  
  637.       LPP=NBNO-NBBB
  638.       LRN=IDECAP*LPP
  639.       LRB=LRE-LRN
  640.  
  641.       UNSURM = 0.
  642.  
  643.       SEGINI WRK2,WRK5
  644. c Segment MTRACE initialise ici (necessaire mais inutilise)
  645.       IF (IREPS2.EQ.1) SEGINI MTRACE
  646.  
  647.       I19 =0
  648. c
  649.       DO 3173  IB=1,NBELEM
  650. c
  651. c     on cherche d'abord les deplacements
  652. c
  653.         IE=1
  654.         MPTVAL=IVADEP
  655.         DO IGAU=1,NBNN
  656.           DO ICOMP=1,NDEP-IDECAP
  657.             MELVAL=IVAL(ICOMP)
  658.             IGMN=MIN(IGAU,VELCHE(/1))
  659.             IBMN=MIN(IB  ,VELCHE(/2))
  660.             XDDL(IE)=VELCHE(IGMN,IBMN)
  661.             IE=IE+1
  662.           ENDDO
  663.         ENDDO
  664. c
  665. c     puis les pressions
  666. c
  667.         DO IPR = 1,IDECAP
  668.           MELVAL=IVAL(NDEP-IDECAP+IPR)
  669.           DO IGAU=1,LPP
  670.             IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  671.             IBMN=MIN(IB  ,VELCHE(/2))
  672.             IGMN=MIN(IGAUSO,VELCHE(/1))
  673.             XDDL(IE)=VELCHE(IGMN,IBMN)
  674.             IE=IE+1
  675.           ENDDO
  676.         ENDDO
  677. c
  678. c     on cherche  les coordonnees des noeuds de l element ib
  679. c
  680.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  681. c
  682. c     boucle sur les points de gauss
  683. c
  684.         ISDJC=0
  685.         CALL ZERO (COBB,IDECAP,1)
  686.         CALL ZERO (CPBB,IDECAP,1)
  687.         CALL ZERO (KKBB,IDECAP,IDECAP)
  688. c
  689.         DO 5173  IGAU=1,NBPTEL
  690. c
  691.           CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  692.      &        1.D0,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  693. c
  694.           IF (DJAC.EQ.0.D0) THEN
  695.             INTERR(1)=IB
  696.             CALL ERREUR(259)
  697.             GOTO 9973
  698.           ELSE IF (DJAC.LT.0.D0) THEN
  699.             ISDJC=ISDJC+1
  700.           ENDIF
  701. c
  702.           MPTVAL=IVAMAT
  703. C*D       IF (IMAT.EQ.2) THEN
  704. C*D         GO TO 99
  705. C*D       ELSE IF (IMAT.EQ.1) THEN
  706.             DO 6173 IM=1,NMATT
  707.               IF (IVAL(IM).NE.0) THEN
  708.                 MELVAL=IVAL(IM)
  709.                 IBMN=MIN(IB  ,VELCHE(/2))
  710.                 IGMN=MIN(IGAU,VELCHE(/1))
  711.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  712.               ELSE
  713.                 VALMAT(IM)=0.D0
  714.               ENDIF
  715.  6173       CONTINUE
  716. C*D         IF (MATE.EQ.1) THEN
  717.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  718.      .          CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  719. C*D         ELSE
  720. C*D           GOTO 99
  721. C*D         ENDIF
  722. C*D       ENDIF
  723. c
  724.           IF (MFR.EQ.57) THEN
  725.             COBB(1)  = VALMAT(3)
  726.             COBB(2)  = VALMAT(4)
  727.             CPBB(1)  = VALMAT(5)
  728.             CPBB(2)  = VALMAT(6)
  729.             KKBB(1,1)= VALMAT(7)
  730.             KKBB(1,2)= VALMAT(8)
  731.             KKBB(2,1)= VALMAT(9)
  732.             KKBB(2,2)= VALMAT(10)
  733.           ELSE IF(MFR.EQ.59) THEN
  734.             COBB(1)  = VALMAT(3)
  735.             COBB(2)  = VALMAT(4)
  736.             COBB(3)  = VALMAT(5)
  737.             CPBB(1)  = VALMAT(6)
  738.             CPBB(2)  = VALMAT(7)
  739.             CPBB(3)  = VALMAT(8)
  740.             KKBB(1,1)= VALMAT(9)
  741.             KKBB(1,2)= VALMAT(10)
  742.             KKBB(1,3)= VALMAT(11)
  743.             KKBB(2,1)= VALMAT(12)
  744.             KKBB(2,2)= VALMAT(13)
  745.             KKBB(2,3)= VALMAT(14)
  746.             KKBB(3,1)= VALMAT(15)
  747.             KKBB(3,2)= VALMAT(16)
  748.             KKBB(3,3)= VALMAT(17)
  749.           ENDIF
  750. c
  751.           CALL BST(BGENE,XDDL,LRE,LHOOK,XSTRS)
  752. c
  753. c     calcul des eps 2
  754. c
  755.           IF (IREPS2.EQ.1)
  756.      &      CALL BST2(SHPWRK,XDDL,XE,NBNN,IFOUR,XSTRS,TRACE,IGAU,
  757.      &                XDPGE,YDPGE,UDPGE,NHRM)
  758. c
  759. c       contribution de epsi a msr0
  760. c
  761.           TRACEP=XSTRS(1)+XSTRS(2)+XSTRS(3)
  762.           DO K=1,IDECAP
  763.             XSTRS(NSTRS-IDECAP+K)=CPBB(K)*TRACEP
  764.           ENDDO
  765.           DO KA=1,LHOOK
  766.             XWRK(KA)=XSTRS(KA)
  767.           ENDDO
  768.           DO KA=1,LHOOK
  769.             r_z = 0.D0
  770.             DO KB=1,LHOOK
  771.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  772.             ENDDO
  773.             XSTRS(KA) = r_z
  774.           ENDDO
  775. c
  776. c     calcul de l'effet de la pression
  777. c
  778.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  779.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  780. c
  781. c     remplissage du segment contenant les contraintes
  782. c
  783.           MPTVAL=IVASTR
  784.           DO ICOMP=1,NSTRS
  785.             MELVAL=IVAL(ICOMP)
  786.             IBMN=MIN(IB  ,VELCHE(/2))
  787.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  788.           ENDDO
  789. c
  790.  5173   CONTINUE
  791. c
  792.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  793.          if (inoer.eq.0) then
  794.           INTERR(1)=IB
  795.           CALL ERREUR(195)
  796.           GOTO 9973
  797.          else
  798.           call soucis(195)
  799.          ENDIF
  800.         ENDIF
  801. c
  802.  3173 CONTINUE
  803. c
  804.       IF (I19.NE.0) CALL ERREUR(19)
  805.       IF (IRTD.EQ.0) THEN
  806.         MOTERR(1:8)=CMATE
  807.         MOTERR(9:12)=NOMFR(MFR/2+1)
  808.         INTERR(1)=IFOUR
  809.         CALL ERREUR(81)
  810.       ENDIF
  811.  9973 CONTINUE
  812.       SEGSUP WRK2,WRK5
  813.       IF (IREPS2.EQ.1) SEGSUP MTRACE
  814.       GOTO 510
  815.  
  816. c____________________________________________________________________
  817. c
  818. c     joints poreux
  819. c____________________________________________________________________
  820. c
  821.  80   CONTINUE
  822. c  Ces cas ne sont pas prevus actuellement !
  823.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  824. c
  825. c    pour ces elements  nbbb = nombre de noeuds
  826. c                       nbno = nombre de fonctions de forme
  827. c
  828.       NBNO=IPORE
  829.       NSTN=1
  830.       NSTMU=2
  831.       IF (IFOUR.EQ.2) NSTMU=3
  832.       LRN=(NBNO-NBBB)*3/2
  833.       LRB=LRE-LRN
  834.       NFAC=(3*NBBB-NBNO)/2
  835. c
  836.       SEGINI WRK2,WRK3,WRK5
  837. c
  838.       I19 =0
  839. c
  840.       DO 3080  IB=1,NBELEM
  841. c
  842. c     on cherche d'abord les deplacements
  843. c
  844.         MPTVAL=IVADEP
  845.         IE=1
  846.         DO 4180 IGAU=1,NFAC
  847.           DO 4280 ICOMP=1,NDEP-1
  848.             MELVAL=IVAL(ICOMP)
  849.             IGMN=MIN(IGAU,VELCHE(/1))
  850.             IBMN=MIN(IB  ,VELCHE(/2))
  851.             XDDL(IE)=VELCHE(IGMN,IBMN)
  852.             IE=IE+1
  853.  4280     CONTINUE
  854.  4180   CONTINUE
  855. c
  856. c     puis les pressions
  857. c
  858.         MELVAL=IVAL(NDEP)
  859.         DO 4080 IGAU=1,NBNN
  860.           DO 4190 INSOM=1,NBSOM(IELE)
  861.             IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GOTO 4191
  862. 4190      CONTINUE
  863.           IF (IGAU.GT.NFAC) GOTO 4191
  864.           GOTO 4080
  865. 4191      CONTINUE
  866.           IBMN=MIN(IB  ,VELCHE(/2))
  867.           IGMN=MIN(IGAU,VELCHE(/1))
  868.           XDDL(IE)=VELCHE(IGMN,IBMN)
  869.           IE=IE+1
  870.  4080   CONTINUE
  871. c
  872. c     on cherche  les coordonnees des noeuds de l element ib
  873. c
  874.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  875. c
  876. c     calcul des exes locaux et des coordonnees locales
  877. c
  878.         CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  879. c
  880. c     boucle sur les points de gauss
  881. c
  882.         ISDJC=0
  883.         CALL ZERO(COBMA,LHOOK,1)
  884. c
  885.         DO 5080  IGAU=1,NBPTEL
  886. c
  887.           CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  888.      .                SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  889. c
  890.           IF (DJAC.EQ.0.D0) THEN
  891.             INTERR(1)=IB
  892.             CALL ERREUR(259)
  893.             GOTO 9980
  894.           ELSE IF (DJAC.LT.0.D0) THEN
  895.             ISDJC=ISDJC+1
  896.           ENDIF
  897. c
  898.           MPTVAL=IVAMAT
  899. C*D       IF (IMAT.EQ.2) THEN
  900. C*D         GO TO 99
  901. C*D       ELSE IF (IMAT.EQ.1) THEN
  902.             DO 9080 IM=1,NMATT
  903.               IF (IVAL(IM).NE.0) THEN
  904.                 MELVAL=IVAL(IM)
  905.                 IBMN=MIN(IB  ,VELCHE(/2))
  906.                 IGMN=MIN(IGAU,VELCHE(/1))
  907.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  908.               ELSE
  909.                 VALMAT(IM)=0.D0
  910.               ENDIF
  911.  9080       CONTINUE
  912. C*D         IF (MATE.EQ.1) THEN
  913.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  914.      &          CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  915. C*D         ELSE
  916. C*D           GO TO 99
  917. C*D         ENDIF
  918. C*D       ENDIF
  919. c
  920.           CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  921. c
  922. c       contribution de epsi a msr0
  923. c
  924.           IF (IMAT.EQ.1) THEN
  925.             COBMA(NSTMU)=VALMAT(3)
  926.             XMOB=VALMAT(4)
  927.           ENDIF
  928.           XSTRS(NSTRS)=COBMA(NSTMU)*XSTRS(NSTMU)
  929.  
  930.           DO 4887 KA=1,LHOOK
  931.             XWRK(KA)=XSTRS(KA)
  932.  4887     CONTINUE
  933.  
  934.           DO 4886 KA=1,LHOOK
  935.             r_z = 0.D0
  936.             DO KB=1,LHOOK
  937.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  938.             ENDDO
  939.             XSTRS(KA)= r_z
  940.  4886     CONTINUE
  941. c
  942. c     calcul de l'effet de la pression
  943. c
  944.           IF (XMOB.EQ.0.D0) THEN
  945.             UNSURM=0.D0
  946.           ELSE
  947.             UNSURM=1.D0 / XMOB
  948.           ENDIF
  949. c
  950.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  951.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  952. c
  953. c     remplissage du segment contenant les contraintes
  954. c
  955.           MPTVAL=IVASTR
  956.           DO 7080 ICOMP=1,NSTRS
  957.             MELVAL=IVAL(ICOMP)
  958.             IBMN=MIN(IB  ,VELCHE(/2))
  959.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  960.  7080     CONTINUE
  961. c
  962.  5080   CONTINUE
  963. c
  964.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  965.          if (inoer.eq.0) then
  966.           INTERR(1)=IB
  967.           CALL ERREUR(195)
  968.           GOTO 9980
  969.          else
  970.           call soucis(195)
  971.          ENDIF
  972.         ENDIF
  973. c
  974.  3080 CONTINUE
  975. c
  976.       IF (IRTD.EQ.0) THEN
  977.         MOTERR(1:8)=CMATE
  978.         MOTERR(9:12)=NOMFR(MFR/2+1)
  979.         INTERR(1)=IFOUR
  980.         CALL ERREUR(81)
  981.       ENDIF
  982.       IF (I19.NE.0) CALL ERREUR(19)
  983.  9980 CONTINUE
  984.       SEGSUP,WRK2,WRK3,WRK5
  985.       GOTO 510
  986.  
  987.  
  988. c____________________________________________________________________
  989. c
  990. c     joints poreux  - SUITE
  991. c____________________________________________________________________
  992. c
  993. 185   CONTINUE
  994. c  Ces cas ne sont pas prevus actuellement !
  995.       IF ( IMAT.EQ.2 .OR. (IMAT.EQ.1.AND.MATE.NE.1) )  GOTO 99
  996. c
  997. c    pour ces elements  nbbb = nombre de noeuds
  998. c                       nbno = nombre de fonctions de forme
  999. c
  1000.       IF (MELE.GE.185.AND.MELE.LE.187) THEN
  1001.         IDECAP = 2
  1002.       ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  1003.         IDECAP = 3
  1004.       ENDIF
  1005.  
  1006.       NBNO=IPORE
  1007.       NSTN=IDECAP
  1008.       NSTMU=2
  1009.       IF (IFOUR.EQ.2) NSTMU=3
  1010.       NSTB=NSTMU
  1011.       LPP=(NBNO-NBBB)*3/2
  1012.       LRN=IDECAP*LPP
  1013.       LRB=LRE-LRN
  1014.  
  1015.       UNSURM = 0.
  1016.  
  1017.       NFAC=(3*NBBB-NBNO)/2
  1018. c
  1019.       SEGINI WRK2,WRK3,WRK5
  1020. c
  1021.       I19 =0
  1022. c
  1023.       DO 3185  IB=1,NBELEM
  1024. c
  1025. c     on cherche d'abord les deplacements
  1026. c
  1027.         MPTVAL=IVADEP
  1028.         IE=1
  1029.         DO 4185 IGAU=1,NFAC
  1030.           DO 4285 ICOMP=1,NDEP-1
  1031.             MELVAL=IVAL(ICOMP)
  1032.             IGMN=MIN(IGAU,VELCHE(/1))
  1033.             IBMN=MIN(IB  ,VELCHE(/2))
  1034.             XDDL(IE)=VELCHE(IGMN,IBMN)
  1035.             IE=IE+1
  1036.  4285     CONTINUE
  1037.  4185   CONTINUE
  1038. c
  1039. c     puis les pressions
  1040. c
  1041.         DO 4585 IPR=1,IDECAP
  1042.           MELVAL=IVAL(NDEP-IDECAP+IPR)
  1043.           DO 4085 IGAU=1,NBNN
  1044.             DO 4195 INSOM=1,NBSOM(IELE)
  1045.               IF (IGAU.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GOTO 4995
  1046. 4195        CONTINUE
  1047.             IF (IGAU.GT.NFAC) GOTO 4995
  1048.             GOTO 4085
  1049. 4995        CONTINUE
  1050.             IBMN=MIN(IB  ,VELCHE(/2))
  1051.             IGMN=MIN(IGAU,VELCHE(/1))
  1052.             XDDL(IE)=VELCHE(IGMN,IBMN)
  1053.             IE=IE+1
  1054.  4085     CONTINUE
  1055.  4585   CONTINUE
  1056. c
  1057. c     on cherche  les coordonnees des noeuds de l element ib
  1058. c
  1059.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1060. c
  1061. c     calcul des exes locaux et des coordonnees locales
  1062. c
  1063.         CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1064. c
  1065. c     boucle sur les points de gauss
  1066. c
  1067.         ISDJC=0
  1068.         CALL ZERO (COBB,IDECAP,1)
  1069.         CALL ZERO (CPBB,IDECAP,1)
  1070.         CALL ZERO (KKBB,IDECAP,IDECAP)
  1071. c
  1072.         DO 5185  IGAU=1,NBPTEL
  1073. c
  1074.           CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1075.      &         SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1076. c
  1077.           IF (DJAC.EQ.0.D0) THEN
  1078.             INTERR(1)=IB
  1079.             CALL ERREUR(259)
  1080.             GOTO 9980
  1081.           ELSE IF (DJAC.LT.0.D0) THEN
  1082.             ISDJC=ISDJC+1
  1083.           ENDIF
  1084. c
  1085.           MPTVAL=IVAMAT
  1086. C*D       IF (IMAT.EQ.2) THEN
  1087. C*D         GO TO 99
  1088. C*D       ELSE IF (IMAT.EQ.1) THEN
  1089.             DO 9185 IM=1,NMATT
  1090.               IF (IVAL(IM).NE.0) THEN
  1091.                 MELVAL=IVAL(IM)
  1092.                 IBMN=MIN(IB  ,VELCHE(/2))
  1093.                 IGMN=MIN(IGAU,VELCHE(/1))
  1094.                 VALMAT(IM)=VELCHE(IGMN,IBMN)
  1095.               ELSE
  1096.                 VALMAT(IM)=0.D0
  1097.               ENDIF
  1098.  9185       CONTINUE
  1099. C*D         IF (MATE.EQ.1) THEN
  1100.  
  1101. *ZZZZZZZZZZZZZ   VOIR SI LHOOK POSE PB A CE NIVEAU ????
  1102.  
  1103.               IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1104.      &          CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1105. C*D         ELSE
  1106. C*D           GO TO 99
  1107. C*D         ENDIF
  1108. C*D       ENDIF
  1109. c
  1110.           CALL BST(BGENE,XDDL,LRB,LHOOK,XSTRS)
  1111. c
  1112. c       contribution de epsi a msr0
  1113. c
  1114.           IF (MFR.EQ.57) THEN
  1115.             COBB(1)  = VALMAT(3)
  1116.             COBB(2)  = VALMAT(4)
  1117.             CPBB(1)  = VALMAT(5)
  1118.             CPBB(2)  = VALMAT(6)
  1119.             KKBB(1,1)= VALMAT(7)
  1120.             KKBB(1,2)= VALMAT(8)
  1121.             KKBB(2,1)= VALMAT(9)
  1122.             KKBB(2,2)= VALMAT(10)
  1123.           ELSE IF(MFR.EQ.59) THEN
  1124.             COBB(1)  = VALMAT(3)
  1125.             COBB(2)  = VALMAT(4)
  1126.             COBB(3)  = VALMAT(5)
  1127.             CPBB(1)  = VALMAT(6)
  1128.             CPBB(2)  = VALMAT(7)
  1129.             CPBB(3)  = VALMAT(8)
  1130.             KKBB(1,1)= VALMAT(9)
  1131.             KKBB(1,2)= VALMAT(10)
  1132.             KKBB(1,3)= VALMAT(11)
  1133.             KKBB(2,1)= VALMAT(12)
  1134.             KKBB(2,2)= VALMAT(13)
  1135.             KKBB(2,3)= VALMAT(14)
  1136.             KKBB(3,1)= VALMAT(15)
  1137.             KKBB(3,2)= VALMAT(16)
  1138.             KKBB(3,3)= VALMAT(17)
  1139.           ENDIF
  1140. c
  1141. CCCCC  ICI  A FINIR   PENSER A BNQORE AUSSI A CORRIGER
  1142.  
  1143.  
  1144.           XSTRS(NSTRS)=COBMA(NSTMU)*XSTRS(NSTMU)
  1145.  
  1146.           DO 4885 KA=1,LHOOK
  1147.             XWRK(KA)=XSTRS(KA)
  1148.  4885     CONTINUE
  1149.  
  1150.           DO 4785 KA=1,LHOOK
  1151.             r_z = 0.D0
  1152.             DO KB=1,LHOOK
  1153.               r_z = r_z + DDHOOK(KA,KB)*XWRK(KB)
  1154.             ENDDO
  1155.             XSTRS(KA)= r_z
  1156.  4785     CONTINUE
  1157. c
  1158. c     calcul de l'effet de la pression
  1159. c
  1160.           IF (XMOB.EQ.0.D0) THEN
  1161.             UNSURM=0.D0
  1162.           ELSE
  1163.             UNSURM=1.D0 / XMOB
  1164.           ENDIF
  1165. c
  1166.           CALL SIGPOR(COBMA,UNSURM,XGENE,NSTN,XDDL,IFOUR,NSTRS,
  1167.      .                XSTRS,LRB,LRN,LPP,MELE,I19,COBB,KKBB,IDECAP)
  1168. c
  1169. c     remplissage du segment contenant les contraintes
  1170. c
  1171.           MPTVAL=IVASTR
  1172.           DO 7185 ICOMP=1,NSTRS
  1173.             MELVAL=IVAL(ICOMP)
  1174.             IBMN=MIN(IB  ,VELCHE(/2))
  1175.             VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1176.  7185     CONTINUE
  1177. c
  1178.  5185   CONTINUE
  1179. c
  1180.         IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1181.          if (inoer.eq.0) then
  1182.           INTERR(1)=IB
  1183.           CALL ERREUR(195)
  1184.           GOTO 9985
  1185.          else
  1186.           call soucis(195)
  1187.          ENDIF
  1188.         ENDIF
  1189. c
  1190.  3185 CONTINUE
  1191. c
  1192.       IF (IRTD.EQ.0) THEN
  1193.         MOTERR(1:8)=CMATE
  1194.         MOTERR(9:12)=NOMFR(MFR/2+1)
  1195.         INTERR(1)=IFOUR
  1196.         CALL ERREUR(81)
  1197.       ENDIF
  1198.       IF (I19.NE.0) CALL ERREUR(19)
  1199.  9985 CONTINUE
  1200.       SEGSUP,WRK2,WRK3,WRK5
  1201.       GOTO 510
  1202.  
  1203. c____________________________________________________________________
  1204.   99  CONTINUE
  1205.       MOTERR(1:4)=NOMTP(MELE)
  1206.       MOTERR(9:12)='SIGM'
  1207.       CALL ERREUR(86)
  1208.  
  1209. C- Fin du sous-programme
  1210.  510  CONTINUE
  1211.       SEGSUP,MVELCH,WRK1
  1212.  
  1213.       RETURN
  1214.       END
  1215.  
  1216.  
  1217.  

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