Télécharger la plaquette Cast3M


fr en

Télécharger sigma3.eso

Retour à la liste

Numérotation des lignes : 

sigma3

  1. C SIGMA3    SOURCE    OF166741  25/02/21    21:18:36     12166          
  2.       SUBROUTINE SIGMA3(IPMAIL,IVADEP,NDEP,IVACAR,NCARR,IPMINT,
  3.      &    IVECT,IVAMAT,MELE,IMAT,NELMAT,NBGMAT,LHOOK,CMATE,IREPS2,
  4.      &    NBPTEL,NSTRS,MFR,NMATT,NBPGAU,ISOUS,LRE,LW,IVASTR,UZDPG,
  5.      &    RYDPG,RXDPG,IIPDPG,inoer)
  6. *---------------------------------------------------------------------*
  7. *        __________________________                                   *
  8. *        |                        |                                   *
  9. *        |  CALCUL DES CONTRAINTES|                                   *
  10. *        |________________________|                                   *
  11. *                                                                     *
  12. *      poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo,shb8    *
  13. *                                                                     *
  14. *                                                                     *
  15. *---------------------------------------------------------------------*
  16. *                                                                     *
  17. *   ENTREES :                                                         *
  18. *   ________                                                          *
  19. *                                                                     *
  20. *        IPMAIL   Pointeur sur un segment  MELEME                     *
  21. *        IVADEP   Pointeur sur le chamelem de deplacements            *
  22. *        NDEP     Nombre de composantes de deplacements               *
  23. *        IVACAR   Pointeur sur les chamelems de caracteristiques      *
  24. *        NCARR    Nombre de caracteristiques geometriques             *
  25. *        IVECT    Flag indiquant si on a entree les axes locaux       *
  26. *        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  27. *        MELE     Numero de l'element fini                            *
  28. *        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  29. *        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  30. *        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  31. *        LHOOK    Dimension de la matrice de Hooke                    *
  32. *        CMATE    Nom du materiau                                     *
  33. *        IRESP2   Flag pour indiquer si on veut les contraintes       *
  34. *                  de Piola-Kirchhoff                                 *
  35. *        NBPTEL   Nombre de points par element                        *
  36. *        NSTRS    Nombre de composante de contraintes/deformations    *
  37. *        MFR      Numero de formulation de l'element fini             *
  38. *        NMATT    Nombre de composante de materiau (IMAT=1)           *
  39. *                 pour une matrice de hooke                           *
  40. *        NBPGAU   Nombre de point d'integration pour la rigidite      *
  41. *        ISOUS    NUMERO DE LA SOUS-ZONE                              *
  42. *        LRE      Nombre de ddl dans la matrice de rigidite           *
  43. *        LW       Dimension du tableau de travail de l'element        *
  44. *                                                                     *
  45. *   SORTIES :                                                         *
  46. *   ________                                                          *
  47. *                                                                     *
  48. *        IVASTR   pointeur sur un segment MPTVAL contenant les        *
  49. *                 les melvals de contraints                           *
  50. *                                                                     *
  51. *---------------------------------------------------------------------*
  52.       IMPLICIT INTEGER(I-N)
  53.       IMPLICIT REAL*8(A-H,O-Z)
  54.  
  55. -INC PPARAM
  56. -INC CCOPTIO
  57. -INC CCHAMP
  58. -INC CCREEL
  59.  
  60. -INC SMCHAML
  61. -INC SMINTE
  62. -INC SMELEME
  63. -INC SMCOORD
  64. -INC SMLREEL
  65.  
  66. -INC TMPTVAL
  67.  
  68.       SEGMENT WRK1
  69.        REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS)
  70.        REAL*8 XE(3,NBBB) ,DDHOMU(NSTRS,NSTRS)
  71.       ENDSEGMENT
  72. *
  73.       SEGMENT WRK2
  74.        REAL*8 BPSS(3,3) ,BGENE(LHOOK,LRE)
  75.       ENDSEGMENT
  76. *
  77.       SEGMENT WRK3
  78.        REAL*8 WORK(LW)
  79.       ENDSEGMENT
  80. *
  81.       SEGMENT WRK5
  82.        REAL*8 XGENE(NSTN,LRN)
  83.       ENDSEGMENT
  84. *
  85.        SEGMENT WRK7
  86.         REAL*8 PROPEL(45)
  87.         REAL*8 OUT(30),rel(1,1),work1(24)
  88.        ENDSEGMENT
  89. *
  90.       SEGMENT,MVELCH
  91.          REAL*8 VALMAT(NV1)
  92.       ENDSEGMENT
  93.  
  94.       DIMENSION CRIGI(12),CMASS(12)
  95.       CHARACTER*4 CMOT
  96.       CHARACTER*8 CMATE
  97.  
  98.       KERRE=0
  99. *
  100. *    INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  101. *    EN DEFORMATION PLANE GENERALISEE
  102. *
  103.       IF (IFOUR.EQ.-3) THEN
  104.         IP=IIPDPG
  105.         SEGACT MCOORD
  106.         IREF=(IP-1)*(IDIM+1)
  107.         XDPGE=XCOOR(IREF+1)
  108.         YDPGE=XCOOR(IREF+2)
  109.       ELSE
  110.         XDPGE=0.D0
  111.         YDPGE=0.D0
  112.       ENDIF
  113. *
  114.       MELEME=IPMAIL
  115.       NBNN=NUM(/1)
  116.       NBELEM=NUM(/2)
  117. *
  118.       NV1=NMATT
  119.       SEGINI,MVELCH
  120. *
  121.       NHRM=NIFOUR
  122.       MINTE=IPMINT
  123. *
  124.       IRTD=1
  125.       NBBB=NBNN
  126.       SEGINI WRK1
  127. C_______________________________________________________________________
  128. C
  129. C     NUMERO DES ETIQUETTES      :
  130. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  131. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  132. C     5  CONTINUE
  133. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  134. C     44 CONTINUE
  135. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  136. C_______________________________________________________________________
  137. C
  138.       IF (MELE.LE.100)
  139.      &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  140.      1      99,99,99,99,99,99,99,99,29,30,99,99,99,99,99,99,99,99,99,99,
  141.      2      99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99,
  142.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  143.      4      99,99,99,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99
  144.      5      ),MELE
  145.       IF (MELE.LE.200)
  146.      &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  147.      1      99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  148.      2      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  149.      3      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  150.      4      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  151.      5      34),MELE-100
  152.       IF (MELE.LE.300)
  153.      &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  154.      1      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  155.      2      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,258,34,
  156.      3      260,34,34,34,34,265),MELE-200
  157. C
  158.  34   CONTINUE
  159. C
  160.       GOTO 99
  161. C_______________________________________________________________________
  162. CC
  163. C____________________________________________________________________
  164. C
  165. C     ELEMENTS  POUTRES TUYAUX
  166. C____________________________________________________________________
  167. C
  168.   29  CONTINUE
  169.       SEGINI WRK3
  170. C
  171. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  172. C
  173.       DO  3029 IB=1,NBELEM
  174. C
  175. C     ON CHERCHE LES DEPLACEMENTS
  176. C
  177.       IE=1
  178.       NCARR1=NCARR
  179.       IF(IVECT.EQ.1) NCARR1=NCARR-3
  180.       CALL ZERO(WORK,NCARR1,1)
  181.       DO 4029 IGAU=1,NBNN
  182.       MPTVAL=IVADEP
  183.       DO 4039 ICOMP=1,NDEP
  184.         MELVAL=IVAL(ICOMP)
  185.         IGMN=MIN(IGAU,VELCHE(/1))
  186.         IBMN=MIN(IB  ,VELCHE(/2))
  187.         XDDL(IE)=VELCHE(IGMN,IBMN)
  188.         IE=IE+1
  189.  4039 CONTINUE
  190. C
  191. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  192. C
  193.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  194. C
  195. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  196. C     SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  197. C
  198.       MPTVAL=IVACAR
  199.       DO 6029 IC=1,NCARR1
  200.         IF (IVAL(IC).NE.0) THEN
  201.           MELVAL=IVAL(IC)
  202.           IBMN=MIN(IB,VELCHE(/2))
  203.           IGMN=MIN(IGAU,VELCHE(/1))
  204.           WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  205.         ELSE
  206.           WORK(IC)=0.D0
  207.         ENDIF
  208. C
  209.           IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  210.  6029 CONTINUE
  211.  4029 CONTINUE
  212. C
  213. C  CAS OU ON A LU LE MOT VECTEUR
  214. C
  215. C
  216.       IF ((IVECT.EQ.1).AND.(IFOUR.EQ.2)) THEN
  217. C
  218.           DO 6129 IC=1,IDIM
  219.             MELVAL=IVAL(NCARR+IC-3)
  220.             IF (MELVAL.NE.0) THEN
  221.               IBMN=MIN(IB,VELCHE(/2))
  222.               WORK(NCARR+IC-3)=VELCHE(1,IBMN)
  223.             ELSE
  224.               WORK(NCARR+IC-3)=0.D0
  225.             ENDIF
  226.  6129     CONTINUE
  227.       ENDIF
  228. C
  229. C    TRAITEMENT DU MATERIAU
  230. C
  231.       MPTVAL=IVAMAT
  232.       MELVAL=IVAL(1)
  233. *
  234.       IF(CMATE.NE.'SECTION') THEN
  235.         IBMN=MIN(IB,VELCHE(/2))
  236.         YOUNG=VELCHE(1,IBMN)
  237. C
  238. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE  EQUIVA
  239. C
  240.         IF(MELE.EQ.42) THEN
  241.           PRES=WORK(4)
  242.           CISA=WORK(5)
  243.           WORK(4)=WORK(6)
  244.           WORK(5)=WORK(7)
  245.           WORK(6)=WORK(8)
  246.           WORK(7)=PRES
  247.           WORK(8)=CISA
  248.           CALL TUYKAR(WORK,KERRE,2,YOUNG)
  249.         ENDIF
  250.         IF (KERRE.EQ.77) THEN
  251.           CALL ERREUR(77)
  252.           GOTO 510
  253.         ENDIF
  254. C
  255. C     ON CHERCHE LES COEFF DES MAT DE HOOKE
  256. C
  257.         MPTVAL=IVAMAT
  258.         IF(IMAT.EQ.2) THEN
  259.           MELVAL=IVAL(1)
  260.           IBMN=MIN(IB  ,IELCHE(/2))
  261.           MLREEL=IELCHE(1,IBMN)
  262.           SEGACT MLREEL
  263.           IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  264.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  265.           SEGDES MLREEL
  266. C-------------
  267. C  PROVISOIRE
  268. C-------------
  269. *
  270. C
  271.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  272. C
  273.              WORK(4)=DDHOOK(1,1)/WORK(1)
  274.              WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1)))
  275.            ELSE
  276.              WORK(10)=DDHOOK(1,1)/WORK(4)
  277.              WORK(11)=DDHOOK(4,4)/WORK(1)
  278.            ENDIF
  279.         ELSE IF (IMAT.EQ.1) THEN
  280. *
  281.           DO 9029 IM=1,NMATT
  282.             IF (IVAL(IM).NE.0) THEN
  283.               MELVAL=IVAL(IM)
  284.               IBMN=MIN(IB  ,VELCHE(/2))
  285.               VALMAT(IM)=VELCHE(1,IBMN)
  286.             ELSE
  287.               VALMAT(IM)=0.D0
  288.             ENDIF
  289.  9029     CONTINUE
  290.           IF(MELE.EQ.84) THEN
  291. C
  292.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  293.             CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  294.            ELSE
  295. C
  296.             CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  297.            ENDIF
  298.           ELSE
  299. C
  300.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  301.             CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  302.            ELSE
  303. C
  304.              CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  305.            ENDIF
  306.           ENDIF
  307. C-------------
  308. C  PROVISOIRE
  309. C-------------
  310. C
  311.           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  312.             WORK(4)=VALMAT(1)
  313.             AUX=VALMAT(2)
  314.             WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  315.           ELSE
  316. C
  317.             WORK(10)=VALMAT(1)
  318.             AUX=VALMAT(2)
  319.             WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  320.           ENDIF
  321. C-------------
  322.         ENDIF
  323. *
  324. *  CAS DE LA FORMULATION SECTION
  325. *
  326.       ELSE
  327.         IF(IMAT.EQ.2) THEN
  328.           MELVAL=IVAL(1)
  329.           IBMN=MIN(IB  ,IELCHE(/2))
  330.           MLREEL=IELCHE(1,IBMN)
  331.           SEGACT MLREEL
  332.           IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  333.      $    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  334.           SEGDES MLREEL
  335.         ELSE IF (IMAT.EQ.1) THEN
  336. *
  337. *       ON REGARDE SI ON A LA COMPOSANTE MAHO
  338. *       SI OUI, ON LA PREND
  339. *
  340.           IF(IVAL(3).NE.0) THEN
  341.             MELVAL=IVAL(3)
  342.             IBMN=MIN(IB  ,IELCHE(/2))
  343.             MLREEL=IELCHE(1,IBMN)
  344.             SEGACT MLREEL
  345.             IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  346.      $      CALL DOHOOO(PROG,LHOOK,DDHOOK)
  347.             SEGDES MLREEL
  348.           ELSE
  349.             IBMN=MIN(IB,IELCHE(/2))
  350.             IPMODL=IELCHE(1,IBMN)
  351.             MELVAL=IVAL(2)
  352.             IBMN=MIN(IB,IELCHE(/2))
  353.             IPMAT=IELCHE(1,IBMN)
  354.             CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  355.             IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  356.      $      CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  357.           ENDIF
  358.         ENDIF
  359.       ENDIF
  360. C
  361. C  ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS
  362. C
  363.       IF(MELE.EQ.84) THEN
  364.         IF(CMATE.NE.'SECTION') THEN
  365. C
  366.           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  367.             CALL TIMST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  368.           ELSE
  369. C
  370.             CALL TIMSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  371.           ENDIF
  372.         ELSE
  373.           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  374.             CALL TIFST2(XE,XDDL,LHOOK,DDHOOK,
  375.      $                     WORK(12),WORK(25),IREPS2)
  376.           ELSE
  377.             CALL TIFSTR(XE,XDDL,LHOOK,DDHOOK,WORK,
  378.      $                     WORK(12),WORK(25),IREPS2)
  379.           ENDIF
  380.         ENDIF
  381.       ELSE
  382. C
  383.           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  384.              CALL POUST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  385.           ELSE
  386. C
  387.              CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  388.           ENDIF
  389.       ENDIF
  390. C
  391. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  392. C
  393.       ID=12
  394.       DO      IGAU=1,NBPTEL
  395.       MPTVAL=IVASTR
  396.       DO      ICOMP=1,NSTRS
  397.         MELVAL=IVAL(ICOMP)
  398.         IBMN=MIN(IB  ,VELCHE(/2))
  399.         VELCHE(IGAU,IBMN)=WORK(ID)
  400.         ID=ID+1
  401.       enddo    
  402.       enddo    
  403. C
  404.  3029 CONTINUE
  405.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  406.        MOTERR(1:8)=CMATE
  407.        MOTERR(9:12)=NOMFR(MFR/2+1)
  408.        INTERR(1)=IFOUR
  409.        CALL ERREUR(81)
  410.       ENDIF
  411.       SEGSUP MVELCH,WRK1,WRK3
  412.       GOTO 510
  413. C____________________________________________________________________
  414. C
  415. C     ELEMENT LINESPRING   LISP ET LISM
  416. C____________________________________________________________________
  417. C
  418.   30  CONTINUE
  419.       NSTR=NSTRS
  420.       NSTRS=2
  421. C                  ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1
  422. C
  423.       SEGINI WRK3
  424. C
  425. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELELEMTS
  426. C
  427.       DO 3030 IB=1,NBELEM
  428. C
  429. C     ON CHERCHE LES DEPLACEMENTS
  430. C
  431.       IE=1
  432.       DO      IGAU=1,NBNN
  433.       MPTVAL=IVADEP
  434.       DO      ICOMP=1,NDEP
  435.         MELVAL=IVAL(ICOMP)
  436.         IGMN=MIN(IGAU,VELCHE(/1))
  437.         IBMN=MIN(IB  ,VELCHE(/2))
  438.         XDDL(IE)=VELCHE(IGMN,IBMN)
  439.         IE=IE+1
  440.       enddo    
  441.       enddo    
  442. C
  443. C     ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE
  444. C
  445.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  446. C
  447. C     ON CHERCHE LA MATRICE DE HOOKE
  448. C
  449.         MPTVAL=IVAMAT
  450.         IF(IMAT.EQ.2) THEN
  451.           MELVAL=IVAL(1)
  452.           IBMN=MIN(IB  ,IELCHE(/2))
  453.           MLREEL=IELCHE(1,IBMN)
  454.           SEGACT MLREEL
  455.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  456.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  457.           SEGDES MLREEL
  458.         ELSE IF (IMAT.EQ.1) THEN
  459.           DO 9030 IM=1,NMATT
  460.             IF (IVAL(IM).NE.0) THEN
  461.               MELVAL=IVAL(IM)
  462.               IBMN=MIN(IB  ,VELCHE(/2))
  463.               VALMAT(IM)=VELCHE(1,IBMN)
  464.             ELSE
  465.               VALMAT(IM)=0.D0
  466.             ENDIF
  467. 9030      CONTINUE
  468.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  469.      1    CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  470.         ENDIF
  471. C
  472. C     ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS
  473. C
  474.       IE=1
  475.       DO      IC=1,3,2
  476.       MPTVAL=IVACAR
  477.       DO      ICOMP=1,NCARR
  478.         MELVAL=IVAL(ICOMP)
  479.         IF (MELVAL.NE.0) THEN
  480.           IGMN=MIN(IC,VELCHE(/1))
  481.           IBMN=MIN(IB,VELCHE(/2))
  482.           WORK(IE)=VELCHE(IGMN,IBMN)
  483.         ELSE
  484.           WORK(IE)=0.D0
  485.         ENDIF
  486.         IE=IE+1
  487.       enddo    
  488.       enddo    
  489. C
  490. C     CALCUL DES CONTRAINTES
  491. C
  492.       CALL LISPST(XE,WORK,DDHOOK,XDDL,WORK(11),NBPGAU,MELE,WORK(53),
  493.      1 I69,I70,I195,I157)
  494. C
  495.       IF(I69.NE.0) THEN
  496.          CALL ERREUR( 69)
  497. *         RETURN
  498.       ENDIF
  499.       IF(I70.NE.0) THEN
  500.          CALL ERREUR( 70)
  501. *         RETURN
  502.       ENDIF
  503.       IF(I195.NE.0) THEN
  504.         if (inoer.eq.0) then
  505.          CALL ERREUR( 195)
  506. *         RETURN
  507.         else
  508.          call soucis(195)
  509.         endif
  510.       ENDIF
  511.       IF(I157.NE.0) THEN
  512.          CALL ERREUR( 157)
  513. *         RETURN
  514.       ENDIF
  515.       IE=1
  516.       DO      IGAU=1,NBPTEL
  517.       MPTVAL=IVASTR
  518.       DO      ICOMP=1,NSTR
  519.         MELVAL=IVAL(ICOMP)
  520.         IBMN=MIN(IB  ,VELCHE(/2))
  521.         VELCHE(IGAU,IBMN)=WORK(52+IE)
  522.         IE=IE+1
  523.       enddo    
  524.       enddo    
  525.  3030 CONTINUE
  526.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  527.        MOTERR(1:8)=CMATE
  528.        MOTERR(9:12)=NOMFR(MFR/2+1)
  529.        INTERR(1)=IFOUR
  530.        CALL ERREUR(81)
  531.       ENDIF
  532.       SEGSUP MVELCH,WRK1,WRK3
  533.       GOTO 510
  534. C____________________________________________________________________
  535. C____________________________________________________________________
  536. C
  537. C     ELEMENT  TUYAU FISSURE
  538. C____________________________________________________________________
  539. C
  540.   43  CONTINUE
  541. C                  ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1
  542. C
  543.       SEGINI WRK3
  544. C
  545. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  546. C
  547.       DO  3043 IB=1,NBELEM
  548. C
  549. C     ON CHERCHE LES DEPLACEMENTS
  550. C
  551.       IE=1
  552.       DO      IGAU=1,NBNN
  553.       MPTVAL=IVADEP
  554.       DO      ICOMP=1,NDEP
  555.         MELVAL=IVAL(ICOMP)
  556.         IGMN=MIN(IGAU,VELCHE(/1))
  557.         IBMN=MIN(IB  ,VELCHE(/2))
  558.         XDDL(IE)=VELCHE(IGMN,IBMN)
  559.         IE=IE+1
  560.       enddo    
  561.       enddo    
  562. C
  563. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  564. C
  565.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  566. C
  567. C     ON CHERCHE LES CARACTERISTIQUES
  568. C
  569.       MPTVAL=IVACAR
  570.       DO 7043 IC=1,9
  571.         MELVAL=IVAL(IC)
  572.         IF (MELVAL.NE.0) THEN
  573.           IBMN=MIN(IB,VELCHE(/2))
  574.           WORK(IC)=VELCHE(1,IBMN)
  575.         ELSE
  576.           WORK(IC)=0.D0
  577.         ENDIF
  578.  7043 CONTINUE
  579. C
  580. C     ON CHERCHE LES COEFF DES MAT DE HOOKE
  581. C
  582.         MPTVAL=IVAMAT
  583.         IF(IMAT.EQ.2) THEN
  584.           MELVAL=IVAL(1)
  585.           IBMN=MIN(IB  ,IELCHE(/2))
  586.           MLREEL=IELCHE(1,IBMN)
  587.           SEGACT MLREEL
  588.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  589.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  590.           SEGDES MLREEL
  591.         ELSE IF (IMAT.EQ.1) THEN
  592.           DO 9043 IM=1,NMATT
  593.             IF (IVAL(IM).NE.0) THEN
  594.               MELVAL=IVAL(IM)
  595.               IBMN=MIN(IB  ,VELCHE(/2))
  596.               VALMAT(IM)=VELCHE(1,IBMN)
  597.             ELSE
  598.               VALMAT(IM)=0.D0
  599.             ENDIF
  600.  9043     CONTINUE
  601.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  602.      1   CALL DOHFIS1(VALMAT,WORK(1),CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  603.         ENDIF
  604. C
  605. C     ON CALCULE LES CONTRAINTES
  606. C
  607.       CALL TUFIST(VALMAT,XDDL,WORK(1),DDHOOK,WORK(10),
  608.      1                         WORK(20),WORK(31),I137)
  609.       IF(I137.NE.0) INTERR(1)=ISOUS
  610.       IF(I137.NE.0) INTERR(2)=IB
  611. C
  612.       MPTVAL=IVASTR
  613.       DO 6043 ICOMP=1,8
  614.         MELVAL=IVAL(ICOMP)
  615.         IBMN=MIN(IB,VELCHE(/2))
  616.         VELCHE(1,IBMN)=WORK(30+ICOMP)
  617.  6043 CONTINUE
  618. C
  619.  3043 CONTINUE
  620.       IF(I137.EQ.1) CALL ERREUR(137)
  621.       IF(I137.EQ.2) CALL ERREUR(123)
  622.       IF(I137.EQ.3) CALL ERREUR(266)
  623.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  624.        MOTERR(1:8)=CMATE
  625.        MOTERR(9:12)=NOMFR(MFR/2+1)
  626.        INTERR(1)=IFOUR
  627.        CALL ERREUR(81)
  628.       ENDIF
  629.       SEGSUP MVELCH,WRK1,WRK3
  630.       GOTO 510
  631. C____________________________________________________________________
  632. C
  633. C     ELEMENT POINT (POI1)
  634. C____________________________________________________________________
  635. C
  636.   45  CONTINUE
  637. *
  638.       IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  639.         GO TO 99
  640.       ENDIF
  641. *
  642.       SEGINI WRK3
  643. C
  644. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  645. C
  646.       DO  3045 IB=1,NBELEM
  647. C
  648. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  649. C
  650.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  651. C
  652. C  ON CALCULE LES DEFORMATIONS
  653. C
  654.       CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK)
  655. C
  656.       MPTVAL=IVACAR
  657.       MELVAL=IVAL(1)
  658.       IF (MELVAL.NE.0) THEN
  659.         IBMN=MIN(IB,VELCHE(/2))
  660.         SECT=VELCHE(1,IBMN)
  661.       ELSE
  662.         CALL ERREUR(5)
  663.         GO TO 3045
  664.       ENDIF
  665. C
  666. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  667. C
  668.       MPTVAL=IVADEP
  669.         MPTVAL=IVAMAT
  670.         IF(IMAT.EQ.2) THEN
  671.           MELVAL=IVAL(1)
  672.           IBMN=MIN(IB  ,IELCHE(/2))
  673.           MLREEL=IELCHE(1,IBMN)
  674.           SEGACT MLREEL
  675.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  676.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  677.           SEGDES MLREEL
  678.         ELSE IF (IMAT.EQ.1) THEN
  679.           DO 9045 IM=1,NMATT
  680.             IF (IVAL(IM).NE.0) THEN
  681.               MELVAL=IVAL(IM)
  682.               IBMN=MIN(IB  ,VELCHE(/2))
  683.               VALMAT(IM)=VELCHE(1,IBMN)
  684.             ELSE
  685.               VALMAT(IM)=0.D0
  686.             ENDIF
  687.  9045     CONTINUE
  688.           CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  689.         ENDIF
  690.       MPTVAL=IVADEP
  691. C
  692. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  693. C
  694.       ID=1
  695.       DO      IGAU=1,NBPTEL
  696.       MPTVAL=IVASTR
  697.       DO      ICOMP=1,NSTRS
  698.         MELVAL=IVAL(ICOMP)
  699.         IBMN=MIN(IB  ,VELCHE(/2))
  700.         VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1)
  701.         ID=ID+1
  702.       enddo    
  703.       enddo    
  704.       MPTVAL=IVADEP
  705. C
  706.  3045 CONTINUE
  707.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  708.        MOTERR(1:8)=CMATE
  709.        MOTERR(9:12)=NOMFR(MFR/2+1)
  710.        INTERR(1)=IFOUR
  711.        CALL ERREUR(81)
  712.       ENDIF
  713.       SEGSUP MVELCH,WRK1,WRK3
  714.       GOTO 510
  715. C____________________________________________________________________
  716. C
  717. C     BARRE ET CERCE
  718. C____________________________________________________________________
  719. C
  720.   46  CONTINUE
  721. *
  722.       IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  723.         GO TO 99
  724.       ENDIF
  725. *
  726.       SEGINI WRK3
  727. C
  728. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  729. C
  730.       DO  3046 IB=1,NBELEM
  731.       KERRE=0
  732. C
  733. C     ON CHERCHE LES DEPLACEMENTS
  734. C
  735.       NDDD=NDEP
  736.       IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3
  737.       IE=1
  738.       DO      IGAU=1,NBNN
  739.       MPTVAL=IVADEP
  740.       DO      ICOMP=1,NDDD
  741.         MELVAL=IVAL(ICOMP)
  742.         IGMN=MIN(IGAU,VELCHE(/1))
  743.         IBMN=MIN(IB  ,VELCHE(/2))
  744.         XDDL(IE)=VELCHE(IGMN,IBMN)
  745.         IE=IE+1
  746.       enddo    
  747.       enddo    
  748. C
  749. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  750. C
  751.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  752. C
  753. C  ON CALCULE LES DEFORMATIONS
  754. C
  755.       IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2)
  756.       IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE)
  757.       IF(MELE.EQ.123)CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,NBPGAU,IB)
  758.       IF(KERRE.NE.0) THEN
  759.         CALL ERREUR(601)
  760.         GO TO 3046
  761.       ENDIF
  762.       MPTVAL=IVACAR
  763.       MELVAL=IVAL(1)
  764.       IF (MELVAL.NE.0) THEN
  765.         IBMN=MIN(IB,VELCHE(/2))
  766.         SECT=VELCHE(1,IBMN)
  767.       ELSE
  768.         CALL ERREUR(5)
  769.         GO TO 3046
  770.       ENDIF
  771. C
  772. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  773. C
  774.       MPTVAL=IVADEP
  775.         MPTVAL=IVAMAT
  776.         IF(IMAT.EQ.2) THEN
  777.           MELVAL=IVAL(1)
  778.           IBMN=MIN(IB  ,IELCHE(/2))
  779.           MLREEL=IELCHE(1,IBMN)
  780.           SEGACT MLREEL
  781.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  782.      1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
  783.           SEGDES MLREEL
  784.         ELSE IF (IMAT.EQ.1) THEN
  785.           DO 9046 IM=1,NMATT
  786.             IF (IVAL(IM).NE.0) THEN
  787.               MELVAL=IVAL(IM)
  788.               IBMN=MIN(IB  ,VELCHE(/2))
  789.               VALMAT(IM)=VELCHE(1,IBMN)
  790.             ELSE
  791.               VALMAT(IM)=0.D0
  792.             ENDIF
  793.  9046     CONTINUE
  794.           CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  795.         ENDIF
  796.       MPTVAL=IVADEP
  797. C
  798. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  799. C
  800.       ID=1
  801.       DO      IGAU=1,NBPTEL
  802.       MPTVAL=IVASTR
  803.       DO      ICOMP=1,NSTRS
  804.         MELVAL=IVAL(ICOMP)
  805.         IBMN=MIN(IB  ,VELCHE(/2))
  806.         VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1)
  807.         ID=ID+1
  808.       enddo    
  809.       enddo    
  810.       MPTVAL=IVADEP
  811. C
  812.  3046 CONTINUE
  813.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  814.        MOTERR(1:8)=CMATE
  815.        MOTERR(9:12)=NOMFR(MFR/2+1)
  816.        INTERR(1)=IFOUR
  817.        CALL ERREUR(81)
  818.       ENDIF
  819.       IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  820.       SEGSUP MVELCH,WRK1,WRK3
  821.       GOTO 510
  822. C
  823. C____________________________________________________________________
  824. C
  825. C     ELEMENT BARRE 3D EXCENTRE (BAEX)
  826. C____________________________________________________________________
  827. C
  828.  124  CONTINUE
  829.       NBBB=NBNN
  830.       NSTN=NBNN
  831.       LRN =LRE
  832.       SEGINI WRK1,WRK3,WRK5
  833. C
  834. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  835. C
  836.       DO  3108 IB=1,NBELEM
  837. C
  838. C  ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  839. C  ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  840. C  SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  841. C
  842.       MPTVAL=IVACAR
  843.       DO IC=1,NCARR
  844.         IF(IVAL(IC).NE.0) THEN
  845.           MELVAL=IVAL(IC)
  846.           IBMN=MIN(IB,VELCHE(/2))
  847.           WORK(IC)=VELCHE(1,IBMN)
  848.         ELSE
  849.           WORK(IC)=0.D0
  850.         ENDIF
  851.       END DO
  852.       SECT=WORK(1)
  853. C
  854. C   XGENE  STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  855. C
  856.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  857.       CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  858.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  859.       IF(KERRE.NE.0) INTERR(2)=IB
  860.       IF(KERRE.EQ.1) CALL ERREUR(128)
  861. C
  862. C     ON CHERCHE LES DEPLACEMENTS
  863. C
  864.       IE=1
  865.       DO      IGAU=1,NBNN
  866.       MPTVAL=IVADEP
  867.       DO      ICOMP=1,NDEP
  868.         MELVAL=IVAL(ICOMP)
  869.         IGMN=MIN(IGAU,VELCHE(/1))
  870.         IBMN=MIN(IB  ,VELCHE(/2))
  871.         XDDL(IE)=VELCHE(IGMN,IBMN)
  872.         IE=IE+1
  873.       enddo    
  874.       enddo    
  875. C
  876. C     ON CALCULE LES DEFORMATIONS
  877. C
  878.       CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE)
  879. C
  880. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  881. C
  882.       MPTVAL=IVAMAT
  883.       IF(IMAT.EQ.2) THEN
  884.          MELVAL=IVAL(1)
  885.          IBMN=MIN(IB  ,IELCHE(/2))
  886.          MLREEL=IELCHE(1,IBMN)
  887.          SEGACT MLREEL
  888.          IF(IB.LE.NELMAT.OR.NBGMAT.GT.1) CALL DOHOOO(PROG,LHOOK,DDHOOK)
  889.          SEGDES MLREEL
  890.       ELSE IF (IMAT.EQ.1) THEN
  891.          DO 9124 IM=1,NMATT
  892.            IF (IVAL(IM).NE.0) THEN
  893.               MELVAL=IVAL(IM)
  894.               IBMN=MIN(IB  ,VELCHE(/2))
  895.               VALMAT(IM)=VELCHE(1,IBMN)
  896.            ELSE
  897.               VALMAT(IM)=0.D0
  898.            ENDIF
  899.  9124    CONTINUE
  900.          CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  901.       ENDIF
  902. C
  903. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  904. C
  905.       ID=1
  906.       DO      IGAU=1,NBPTEL
  907.       MPTVAL=IVASTR
  908.       DO      ICOMP=1,NSTRS
  909.         MELVAL=IVAL(ICOMP)
  910.         IBMN=MIN(IB  ,VELCHE(/2))
  911.         VELCHE(IGAU,IBMN)=XSTRS(ID)*DDHOOK(1,1)
  912.         ID=ID+1
  913.       enddo    
  914.       enddo    
  915. C
  916.  3108 CONTINUE
  917.       SEGSUP WRK1,WRK3,WRK5,MVELCH
  918.       GOTO 510
  919. C_______________________________________________________________________
  920. C
  921. C     LIA2 : element de liaison a 2 noeuds (6 ddl par
  922. C        noeuds)
  923. C_______________________________________________________________________
  924. C
  925.  125  CONTINUE
  926.       NBBB=NBNN
  927.       NSTN=3
  928.       LRN =3
  929.       SEGINI WRK1,WRK3,WRK5
  930. C
  931. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  932. C
  933.       DO  3109 IB=1,NBELEM
  934. C
  935. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  936. C
  937.       MPTVAL=IVACAR
  938.       DO IC=1,NCARR
  939.         IF(IVAL(IC).NE.0) THEN
  940.           MELVAL=IVAL(IC)
  941.           IBMN=MIN(IB,VELCHE(/2))
  942.           WORK(IC)=VELCHE(1,IBMN)
  943.         ELSE
  944.           WORK(IC)=0.D0
  945.         ENDIF
  946.       END DO
  947. C
  948.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  949.       CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  950.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  951.       IF(KERRE.NE.0) INTERR(2)=IB
  952.       IF(KERRE.EQ.1) CALL ERREUR(128)
  953. C
  954. C     ON CHERCHE LES DEPLACEMENTS
  955. C
  956.       IE=1
  957.       DO      IGAU=1,NBNN
  958.       MPTVAL=IVADEP
  959.       DO      ICOMP=1,NDEP
  960.         MELVAL=IVAL(ICOMP)
  961.         IGMN=MIN(IGAU,VELCHE(/1))
  962.         IBMN=MIN(IB  ,VELCHE(/2))
  963.         XDDL(IE)=VELCHE(IGMN,IBMN)
  964.         IE=IE+1
  965.       enddo    
  966.       enddo    
  967. C
  968. C  ON CALCULE LES CONTRAINTES  (EFFORTS : F = K * U)
  969. C
  970.       CALL SIGLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS)
  971. C
  972. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  973. C
  974.       ID=1
  975.       DO      IGAU=1,NBPTEL
  976.       MPTVAL=IVASTR
  977.       DO      ICOMP=1,NSTRS
  978.         MELVAL=IVAL(ICOMP)
  979.         IBMN=MIN(IB  ,VELCHE(/2))
  980.         VELCHE(IGAU,IBMN)=XSTRS(ID)
  981.         ID=ID+1
  982.       enddo    
  983.       enddo    
  984. C
  985.  3109 CONTINUE
  986.       SEGSUP MVELCH,WRK1,WRK3,WRK5
  987.       GOTO 510
  988. C_______________________________________________________________________
  989. C
  990. C     JOI1 : element de liaison a 2 noeuds (6 ddl par
  991. C        noeuds)
  992. C_______________________________________________________________________
  993. C
  994.  265  CONTINUE
  995.       NBBB=NBNN
  996.       NSTN=3
  997.       LRN =3
  998.       SEGINI WRK1,WRK3,WRK2
  999. C
  1000. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1001. C
  1002.       DO  3110 IB=1,NBELEM
  1003. C
  1004. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  1005. C
  1006.       MPTVAL=IVAMAT
  1007.       DO IC=1,NMATT
  1008.         IF(IVAL(IC).NE.0) THEN
  1009.           MELVAL=IVAL(IC)
  1010.           IBMN=MIN(IB,VELCHE(/2))
  1011.           WORK(IC)=VELCHE(1,IBMN)
  1012.         ELSE
  1013.           WORK(IC)=0.D0
  1014.         ENDIF
  1015.       END DO
  1016. C
  1017.       CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1018. C
  1019. C     ON CHERCHE LES DEPLACEMENTS
  1020. C
  1021.       IE=1
  1022.       DO      IGAU=1,NBNN
  1023.       MPTVAL=IVADEP
  1024.       DO      ICOMP=1,NDEP
  1025.         MELVAL=IVAL(ICOMP)
  1026.         IGMN=MIN(IGAU,VELCHE(/1))
  1027.         IBMN=MIN(IB  ,VELCHE(/2))
  1028.         XDDL(IE)=VELCHE(IGMN,IBMN)
  1029.         IE=IE+1
  1030.       enddo    
  1031.       enddo    
  1032. C
  1033. C  CALCUL DES DEPLACEMENTS LOCAUX
  1034. C
  1035.       IAW1 = 101
  1036.       IAW2 = IAW1 + LRE
  1037.       CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1038. C
  1039. C  ON CALCULE LES CONTRAINTES  (EFFORTS : F = K * U)
  1040. C
  1041.       CALL ZERO(XSTRS,NSTRS,1)
  1042. *
  1043.       CALL SIGJOI(NMATT,XDDL,WORK,LRE,XSTRS,IDIM,NSTRS,CMATE)
  1044. C
  1045. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  1046. C
  1047.       ID=1
  1048.       DO      IGAU=1,NBPTEL
  1049.       MPTVAL=IVASTR
  1050.       DO      ICOMP=1,NSTRS
  1051.         MELVAL=IVAL(ICOMP)
  1052.         IBMN=MIN(IB  ,VELCHE(/2))
  1053.         VELCHE(IGAU,IBMN)=XSTRS(ID)
  1054.         ID=ID+1
  1055.       enddo    
  1056.       enddo    
  1057. C
  1058.  3110 CONTINUE
  1059.       SEGSUP MVELCH,WRK1,WRK3,WRK2
  1060.       GOTO 510
  1061. C____________________________________________________________________
  1062. C
  1063. C     ELEMENT TUYO
  1064. C____________________________________________________________________
  1065. C
  1066.   96  CONTINUE
  1067.       SEGINI WRK3
  1068. C
  1069. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1070. C
  1071.       DO  3096 IB=1,NBELEM
  1072. C
  1073. C     ON CHERCHE LES DEPLACEMENTS
  1074. C
  1075.       IE=1
  1076.       DO      IGAU=1,NBNN
  1077.       MPTVAL=IVADEP
  1078.       DO      ICOMP=1,NDEP
  1079.         MELVAL=IVAL(ICOMP)
  1080.         IGMN=MIN(IGAU,VELCHE(/1))
  1081.         IBMN=MIN(IB  ,VELCHE(/2))
  1082.         XDDL(IE)=VELCHE(IGMN,IBMN)
  1083.         IE=IE+1
  1084.       enddo    
  1085.       enddo    
  1086. C
  1087. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1088. C
  1089.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1090. C
  1091. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  1092. C
  1093.       MPTVAL=IVACAR
  1094.       DO 6096 IC=1,NCARR
  1095.         IF (IVAL(IC).NE.0) THEN
  1096.           MELVAL=IVAL(IC)
  1097.           IBMN=MIN(IB,VELCHE(/2))
  1098.           WORK(IC)=VELCHE(1,IBMN)
  1099.         ELSE
  1100.           WORK(IC)=0.D0
  1101.         ENDIF
  1102.  6096 CONTINUE
  1103. C
  1104. C  CAS OU ON A LU LE MOT VECTEUR
  1105. C
  1106. C
  1107.       IF (IVECT.EQ.1) THEN
  1108.           DO 6196 IC=1,IDIM
  1109.             MELVAL=IVAL(NCARR+IC-3)
  1110.             IF (MELVAL.NE.0) THEN
  1111.               IBMN=MIN(IB,VELCHE(/2))
  1112.               WORK(NCARR+IC-3)=VELCHE(1,IBMN)
  1113.             ELSE
  1114.               WORK(NCARR+IC-3)=0.D0
  1115.             ENDIF
  1116.  6196     CONTINUE
  1117. C
  1118. C  CAS DU CHAMELEM COMVERTI
  1119. C
  1120.       ELSE IF (IVECT.EQ.2) THEN
  1121.           DO 6496 IC=1,IDIM
  1122.             MELVAL=IVAL(NCARR+IC-3)
  1123.             IF (MELVAL.NE.0) THEN
  1124.               IBMN=MIN(IB,VELCHE(/2))
  1125.               WORK(NCARR+IC-3)=VELCHE(1,IBMN)
  1126.             ELSE
  1127.               WORK(NCARR+IC-3)=0.D0
  1128.             ENDIF
  1129.  6496     CONTINUE
  1130.       ENDIF
  1131. C
  1132.       MPTVAL=IVAMAT
  1133.       MELVAL=IVAL(1)
  1134.       IBMN=MIN(IB,VELCHE(/2))
  1135.       YOUNG=VELCHE(1,IBMN)
  1136. C
  1137. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE  EQUIVA
  1138. C
  1139.       IF(MELE.EQ.42) THEN
  1140.         PRES=WORK(4)
  1141.         WORK(4)=WORK(5)
  1142.         WORK(5)=WORK(6)
  1143.         WORK(6)=WORK(7)
  1144.         WORK(7)=PRES
  1145.         CALL TUYKAR(WORK,KERRE,2,YOUNG)
  1146.       ENDIF
  1147.       IF (KERRE.EQ.77) THEN
  1148.         CALL ERREUR(77)
  1149.         GOTO 510
  1150.       ENDIF
  1151. C
  1152. C     ON CHERCHE LES COEFF DES MAT DE HOOKE
  1153. C
  1154.       MPTVAL=IVAMAT
  1155.       IF(IMAT.EQ.2) THEN
  1156.         MELVAL=IVAL(1)
  1157.         IBMN=MIN(IB  ,IELCHE(/2))
  1158.         MLREEL=IELCHE(1,IBMN)
  1159.         SEGACT MLREEL
  1160.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1161.      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1162.         SEGDES MLREEL
  1163. C-------------
  1164. C  PROVISOIRE
  1165. C-------------
  1166.         WORK(10)=DDHOOK(1,1)/WORK(4)
  1167.         WORK(11)=DDHOOK(2,2)/WORK(5)
  1168.       ELSE IF (IMAT.EQ.1) THEN
  1169. *
  1170.         DO 9096 IM=1,NMATT
  1171.           MELVAL=IVAL(IM)
  1172.           IF (MELVAL.NE.0) THEN
  1173.             IBMN=MIN(IB  ,VELCHE(/2))
  1174.             VALMAT(IM)=VELCHE(1,IBMN)
  1175.           ELSE
  1176.             VALMAT(IM)=0.D0
  1177.           ENDIF
  1178.  9096   CONTINUE
  1179.         CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  1180. C-------------
  1181. C  PROVISOIRE
  1182. C-------------
  1183.         WORK(10)=VALMAT(1)
  1184.         AUX=VALMAT(2)
  1185.         WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  1186. C-------------
  1187.       ENDIF
  1188. C
  1189. C  ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS
  1190. C
  1191.       CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  1192. C
  1193. C  REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  1194. C
  1195.       MPTVAL=IVASTR
  1196.       ID=12
  1197.       DO      IGAU=1,NBPTEL
  1198.       DO      ICOMP=1,NSTRS
  1199.         MELVAL=IVAL(ICOMP)
  1200.         IBMN=MIN(IB  ,VELCHE(/2))
  1201.         VELCHE(IGAU,IBMN)=WORK(ID)
  1202.         ID=ID+1
  1203.       enddo    
  1204.       enddo    
  1205. C
  1206.  3096 CONTINUE
  1207.       IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  1208.        MOTERR(1:8)=CMATE
  1209.        MOTERR(9:12)=NOMFR(MFR/2+1)
  1210.        INTERR(1)=IFOUR
  1211.        CALL ERREUR(81)
  1212.       ENDIF
  1213.       SEGSUP MVELCH,WRK1,WRK3
  1214.       GOTO 510
  1215.  
  1216. c_______________________________________________________________________
  1217. c
  1218. c     ELEMENTS  CIFL   MACRO ELEMENT CISAILLEMENT FLEXION
  1219. c____________________________________________________________________
  1220. c
  1221.  258  CONTINUE
  1222.       NBNO=NBNN
  1223.       SEGINI WRK2,WRK3
  1224. c
  1225.       DO IB=1,NBELEM
  1226. C
  1227. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1228. C
  1229.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1230. C
  1231. C     ON CHERCHE LES DEPLACEMENTS (UX1,UY1,RZ1,UX2,UY2,RZ2,UM,RM)
  1232. C
  1233.          MPTVAL=IVADEP
  1234.          MELVAL=IVAL(1)
  1235.          XDDL(1)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1236.          XDDL(4)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1237.          MELVAL=IVAL(2)
  1238.          XDDL(2)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1239.          XDDL(5)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1240.          MELVAL=IVAL(3)
  1241.          XDDL(3)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1242.          XDDL(6)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1243.          MELVAL=IVAL(4)
  1244.          XDDL(7)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1245.          MELVAL=IVAL(5)
  1246.          XDDL(8)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB  ,VELCHE(/2)))
  1247. C
  1248. C     PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  1249. C
  1250.          CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
  1251. c
  1252. c     matrice de hooke
  1253. c
  1254.          MPTVAL=IVAMAT
  1255.          IF(IMAT.EQ.2) THEN
  1256.             MELVAL=IVAL(1)
  1257.             IBMN=MIN(IB  ,IELCHE(/2))
  1258.             MLREEL=IELCHE(1,IBMN)
  1259.             SEGACT MLREEL
  1260.             IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1261.      1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1262.             SEGDES MLREEL
  1263.          ELSE IF (IMAT.EQ.1) THEN
  1264. C
  1265.             DO IM=1,NMATT
  1266.               IF (IVAL(IM).NE.0) THEN
  1267.                 MELVAL=IVAL(IM)
  1268.                 IBMN=MIN(IB  ,VELCHE(/2))
  1269.                 VALMAT(IM)=VELCHE(1,IBMN)
  1270.               ELSE
  1271.                 VALMAT(IM)=0.D0
  1272.               ENDIF
  1273.             ENDDO
  1274. C
  1275.             MPTVAL=IVACAR
  1276.             DO IC=1,NCARR
  1277.               IF (IVAL(IC).NE.0) THEN
  1278.                 MELVAL=IVAL(IC)
  1279.                 IBMN=MIN(IB,VELCHE(/2))
  1280.                 WORK(IC)=VELCHE(1,IBMN)
  1281.               ELSE
  1282.                 WORK(IC)=0.D0
  1283.               ENDIF
  1284.             ENDDO
  1285. C
  1286.             CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  1287.          ENDIF
  1288. c
  1289.          DDHOOK(1,1)=DDHOOK(1,1)/(XH/2)
  1290.          DDHOOK(2,2)=DDHOOK(2,2)/(XH/2)
  1291.          DDHOOK(3,3)=DDHOOK(3,3)/ XH
  1292.          DDHOOK(4,4)=DDHOOK(4,4)/(XH/2)
  1293.          DDHOOK(5,5)=DDHOOK(5,5)/(XH/2)
  1294.          CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS)
  1295. c
  1296. c
  1297. c     remplissage du segment contenant les contraintes
  1298. c
  1299.          MPTVAL=IVASTR
  1300.          DO ICOMP=1,NSTRS
  1301.            MELVAL=IVAL(ICOMP)
  1302.            IBMN=MIN(IB  ,VELCHE(/2))
  1303.            VELCHE(1,IBMN)=XSTRS(ICOMP)
  1304.          ENDDO
  1305.       ENDDO
  1306. C
  1307.       IF(IRTD.EQ.0) THEN
  1308.        MOTERR(1:8)=CMATE
  1309.        MOTERR(9:12)=NOMFR(MFR/2+1)
  1310.        INTERR(1)=IFOUR
  1311.        CALL ERREUR(81)
  1312.       ENDIF
  1313.       SEGSUP MVELCH,WRK1,WRK2,WRK3
  1314.       GOTO 510
  1315. C_______________________________________________________________________
  1316. C
  1317. C   ELEMENT DE COQUE VOLUMIQUE SHB8
  1318. C_______________________________________________________________________
  1319. C
  1320.   260 CONTINUE
  1321.       NBNO=NBNN
  1322.       NBBB=NBNN
  1323.       SEGINI WRK1,WRK7,MVELCH
  1324. C
  1325. C     BOUCLE POUR TOUS LES ELEMENTS
  1326. C
  1327.        DO IB=1,NBELEM
  1328. C
  1329. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1330. C
  1331.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1332. C
  1333. C on cherche les deplacements
  1334. C
  1335.         MPTVAL=IVADEP
  1336.         IE=1
  1337.         DO  IGAU=1,NBNN
  1338.         DO ICOMP=1,3
  1339.           MELVAL=IVAL(ICOMP)
  1340.           IGMN=MIN(IGAU,VELCHE(/1))
  1341.           IBMN=MIN(IB  ,VELCHE(/2))
  1342.           WORK1(IE)=VELCHE(IGMN,IBMN)
  1343.           IE=IE+1
  1344.         enddo
  1345.         enddo
  1346.  
  1347.          MPTVAL=IVAMAT
  1348.          DO 9070 IM=1,NMATT
  1349.             MELVAL=IVAL(IM)
  1350.           IF (MELVAL.NE.0) THEN
  1351.             IBMN=MIN(IB  ,VELCHE(/2))
  1352.             VALMAT(IM)=VELCHE(1,IBMN)
  1353.           ELSE
  1354.             VALMAT(IM)=0.D0
  1355.           ENDIF
  1356.  9070   CONTINUE
  1357.  
  1358.          PROPEL(1)=VALMAT(1)
  1359.          PROPEL(2)=VALMAT(2)
  1360.          DO IM=3,12
  1361.           PROPEL(IM)=VALMAT(1)
  1362.          ENDDO
  1363.          PROPEL(3)=ireps2
  1364.          PROPEL(14)=VALMAT(1)
  1365. C
  1366. C     CALCUL DES CONTRAINTES
  1367. C
  1368.          call SHB8 (7,XE,DDHOOK,PROPEL,WORK1,REL,OUT)
  1369.          MPTVAL=IVASTR
  1370.          IE=1
  1371.          DO ICOMP=1,NSTRS
  1372.          MELVAL=IVAL(ICOMP)
  1373.           DO IBG=1,5
  1374.            IBMN=MIN(IB  ,VELCHE(/2))
  1375.            VELCHE(IBG,IBMN)=out(ICOMP+ (IBG-1)*NSTRS)
  1376.          ENDDO
  1377.          ENDDO
  1378.       ENDDO
  1379.       SEGSUP WRK1,WRK7,MVELCH
  1380.       GO TO 510
  1381. *____________________________________________________________________
  1382.    99 CONTINUE
  1383.       SEGSUP MVELCH,WRK1
  1384.       MOTERR(1:4)=NOMTP(MELE)
  1385.       MOTERR(9:12)='SIGM'
  1386.       CALL ERREUR(86)
  1387. *
  1388.   510 CONTINUE
  1389.       RETURN
  1390.       END
  1391.  
  1392.  
  1393.  

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