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

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