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

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