Télécharger la plaquette Cast3M


fr en

Télécharger epsi3.eso

Retour à la liste

Numérotation des lignes : 

epsi3

  1. C EPSI3     SOURCE    JK148537  26/06/23    21:15:02     12579          
  2.       SUBROUTINE EPSI3(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT,
  3.      &     IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NSTRS,MFR,IPMINT,
  4.      &     NCARR,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,IVAEPS,
  5.      &     IPMIN1,UZDPG,RYDPG,RXDPG,NPINT,IIPDPG)
  6. C---------------------------------------------------------------------*
  7. C                                                                     *
  8. C           CALCUL DES DEFORMATIONS                                   *
  9. C                                                                     *
  10. C  poutres,tuyaux,coq3,dkt,coq4,coq8,coq2 ,dst,joint 3D,joints 2D     *
  11. C                                                                     *
  12. C---------------------------------------------------------------------*
  13. C                                                                     *
  14. C   ENTREES :                                                         *
  15. C   ________                                                          *
  16. C                                                                     *
  17. C        IPMAIL   Pointeur sur un segment  MELEME                     *
  18. C        IVADEP   Pointeur sur le chamelem de deplacements            *
  19. C        IVACAR   Pointeur sur les chamelems de caracteristiques      *
  20. C        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  21. C        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  22. C        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  23. C        LHOOK    Dimension de la matrice de Hooke                    *
  24. C        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  25. C        MATE     Numero du materiau                                  *
  26. C        CMATE    Nom du materiau                                     *
  27. C        NMATT    Nombre de composante de materiau (IMAT=1)           *
  28. C        NSTRS    Nombre de composante de contraintes/deformations    *
  29. C                 pour une matrice de hooke                           *
  30. C        MFR      Numero de formulation de l'element fini             *
  31. C        IPMINT   Pointeur sur un segment MINTE                       *
  32. C        IPMIN1   Pointeur sur un segment MINTE                       *
  33. C        NDEP     Nombre de composantes de deplacements               *
  34. C        NBPGAU   Nombre de point d'integration pour la rigidite      *
  35. C        NBPTEL   Nombre de points par element                        *
  36. C        MELE     Numero de l'element fini                            *
  37. C        LRE      Nombre de ddl dans la matrice de rigidite           *
  38. C        LW       Dimension du tableau de travail de l'element        *
  39. C        IRESP2   Flag pour indiquer si on veut les contraintes       *
  40. C                  de Piola-Kirchhoff                                 *
  41. C                 dans le cas des elements de coque integres          *
  42. C                                                                     *
  43. C   SORTIES :                                                         *
  44. C   ________                                                          *
  45. C                                                                     *
  46. C        IVAEPS   pointeur sur un segment MPTVAL contenant les        *
  47. C                 les melvals de déformations
  48. C                                                                     *
  49. C---------------------------------------------------------------------*
  50.       IMPLICIT INTEGER(I-N)
  51.       IMPLICIT REAL*8(A-H,O-Z)
  52.  
  53. -INC PPARAM
  54. -INC CCOPTIO
  55. -INC CCHAMP
  56.  
  57. -INC SMCHAML
  58. -INC SMCHPOI
  59. -INC SMELEME
  60. -INC SMCOORD
  61. -INC SMMODEL
  62. -INC SMINTE
  63. -INC SMLREEL
  64.  
  65. -INC TMPTVAL
  66.  
  67.       SEGMENT WRK1
  68.        REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS)
  69.        REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS)
  70.       ENDSEGMENT
  71.  
  72.       SEGMENT WRK2
  73.        REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  74.       ENDSEGMENT
  75.  
  76.       SEGMENT WRK3
  77.        REAL*8 WORK(LW)
  78.       ENDSEGMENT
  79.  
  80.       SEGMENT WRK4
  81.        REAL*8 BPSS(3,3) ,XEL(3,NBBB) ,XDDLOC(LRE)
  82.       ENDSEGMENT
  83.  
  84.       SEGMENT WRK5
  85.        REAL*8   XSTRS1(NSTRS1)
  86.       ENDSEGMENT
  87.       segment wrk7
  88.        real*8 out(30),propel(45),wk7d(1),wk7rel(1)
  89.       endsegment
  90.  
  91.       SEGMENT,MVELCH
  92.          REAL*8 VALMAT(NV1)
  93.       ENDSEGMENT
  94.  
  95.       CHARACTER*8 CMATE
  96.       CHARACTER*(NCONCH) CONM
  97.       PARAMETER (NINF=3)
  98.       INTEGER INFOS(NINF)
  99.       dimension rel(18,18)
  100.  
  101. C  initialisation pour l'optimiseur
  102.       MELVAL=0
  103.  
  104. C   INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  105. C   DE LA SECTION EN DEFO PLANE GENERALISEE
  106.       IF (IIPDPG.GT.0) THEN
  107. C <- test equivalent ici a IFOUR.EQ.-3
  108.         IREF=(IIPDPG-1)*(IDIM+1)
  109.         XDPGE=XCOOR(IREF+1)
  110.         YDPGE=XCOOR(IREF+2)
  111.       ELSE
  112.         XDPGE=0.D0
  113.         YDPGE=0.D0
  114.       ENDIF
  115. C
  116.       MELEME = IPMAIL
  117.       NBNN   = NUM(/1)
  118.       NBELEM = NUM(/2)
  119. C
  120.       NHRM=NIFOUR
  121. C
  122.       MINTE=IPMINT
  123.       NBBB=NBNN
  124.  
  125. C Petite verification prealable (normalement inutile)
  126.       mptval = IVAEPS
  127.       if (NSTRS.ne.ival(/1)) then
  128.         write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  129.         call erreur(5)
  130.         return
  131.       endif
  132.       do icomp = 1, NSTRS
  133.         melval = IVAL(ICOMP)
  134.         if (melval.le.0) then
  135.           write(ioimp,*) 'EPSI3 : incoherence IVAEPS ival(',icomp,')=0'
  136.           call erreur(5)
  137.           return
  138.         endif
  139.         if (NBPTEL.NE.melval.velche(/1)) then
  140.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  141.           call erreur(5)
  142.           return
  143.         endif
  144.         if (NBELEM .NE. melval.velche(/2)) then
  145.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  146.           call erreur(5)
  147.           return
  148.         endif
  149.       enddo
  150. C_______________________________________________________________________
  151. C
  152. C     NUMERO DES ETIQUETTES      :
  153. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  154. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  155. C     5  CONTINUE
  156. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  157. C     44 CONTINUE
  158. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  159. C_______________________________________________________________________
  160. C
  161.       GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  162.      1      99,99,99,99,99,99,27,28,27,99,99,99,99,99,99,99,99,99,99,99,
  163.      2      41,27,99,44,99,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99,
  164.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  165.      4      99,99,99,27,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE
  166. C
  167.       GOTO(168,169,170,171,172),MELE-167
  168.       if(mele.eq.260) go to 260
  169. C
  170.       GOTO 99
  171. C_______________________________________________________________________
  172. C ELEMENT SHB8
  173. C_______________________________________________________________________
  174.   260 continue
  175.       SEGINI WRK1,WRK7
  176.        DO  3260 IB=1,NBELEM
  177. C
  178. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  179. C
  180.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  181. C
  182. C     ON CHERCHE LES DEPLACEMENTS
  183. C
  184.          IE=1
  185.          MPTVAL=IVADEP
  186.          DO      IGAU=1,NBNN
  187.             DO      ICOMP=1,NDEP
  188.                MELVAL=IVAL(ICOMP)
  189.                IGMN=MIN(IGAU,VELCHE(/1))
  190.                IBMN=MIN(IB  ,VELCHE(/2))
  191.                XDDL(IE)=VELCHE(IGMN,IBMN)
  192.                IE=IE+1
  193.             enddo
  194.          enddo
  195.  
  196.         propel(1)=1
  197.         propel(2)=0.3
  198.         propel(3)=ireps2
  199.         call shb8(11,xe,wk7d,propel,xddl,wk7rel,out)
  200.  
  201. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  202. C
  203.          MPTVAL=IVAEPS
  204.          IE=1
  205.          DO IGAU=1,NBPTEL
  206.            DO ICOMP=1,NSTRS
  207.             MELVAL=IVAL(ICOMP)
  208.             VELCHE(IGAU,IB)=out(IE)
  209.             IE=IE+1
  210.            enddo
  211.          enddo
  212. C
  213.  3260 CONTINUE
  214.       SEGSUP WRK1,WRK7
  215.       GOTO 510
  216. C
  217. C_______________________________________________________________________
  218. C
  219. C     ELEMENTS  COQ3   POUTRE ET TUYAU ET POUTRE TIMOSCHENKO
  220. C_______________________________________________________________________
  221. C
  222.   27  CONTINUE
  223.       SEGINI WRK1,WRK3
  224. C
  225. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  226. C
  227.       DO  3027 IB=1,NBELEM
  228. C
  229. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  230. C
  231.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  232. C
  233. C     ON CHERCHE LES DEPLACEMENTS
  234. C
  235.          MPTVAL=IVADEP
  236.          IE=1
  237.          DO      IGAU=1,NBNN
  238.             DO      ICOMP=1,NDEP
  239.                MELVAL=IVAL(ICOMP)
  240.                IGMN=MIN(IGAU,VELCHE(/1))
  241.                IBMN=MIN(IB  ,VELCHE(/2))
  242.                XDDL(IE)=VELCHE(IGMN,IBMN)
  243.                IE=IE+1
  244.             enddo
  245.          enddo
  246.          IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.84) GO TO 5029
  247. C     CAS DES COQ3
  248. C
  249. C     ON MET LA MATRICE DE HOOKE A L IDENTITE
  250. C
  251.          CALL HOOKID(DDHOOK,NSTRS)
  252.          CALL COQ3ST(XE,XDDL,XSTRS,DDHOOK)
  253. C
  254.          IF(IREPS2.EQ.1)
  255.      1     CALL DBCO32(XE,DDHOOK,XDDL,WORK,XSTRS)
  256. C
  257.          MPTVAL=IVAEPS
  258.          DO 6027 ICOMP=1,NSTRS
  259.             MELVAL=IVAL(ICOMP)
  260.             VELCHE(1,IB)=XSTRS(ICOMP)
  261.  6027    CONTINUE
  262. C
  263.          GOTO 3027
  264. C
  265. C        CAS DES POUTRES ET DES TUYAUX
  266. C  ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES DANS WORK
  267. C
  268.  5029    CONTINUE
  269. C
  270. C  pour les poutres et tuyaux on cherche le module d'young et nu si
  271. C  section reduite
  272.        If( mele.eq.29.or.mele.eq.42) then
  273.          mptval = ivamat
  274.          melval=ival(1)
  275.          IGMN=MIN(IGAU,VELCHE(/1))
  276.          ibmn= MIN(IB,VELCHE(/2))
  277.          youtc=VELCHE(IGMN,IBMN)
  278.          melval=ival(2)
  279.          IGMN=MIN(IGAU,VELCHE(/1))
  280.          ibmn= MIN(IB,VELCHE(/2))
  281.          xnutc=VELCHE(IGMN,IBMN)
  282.        endif
  283.  
  284. C
  285. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  286. C
  287.          MPTVAL=IVACAR
  288.          DO 6029 IC=1,NCARR
  289.            MELVAL = IVAL(IC)
  290.            IF (MELVAL.NE.0) THEN
  291.              I2MN = VELCHE(/2)
  292.              I1MN = VELCHE(/1)
  293.              IF (I1MN.GT.0.AND.I2MN.GT.0) THEN
  294.                IBMN = MIN(IB,I2MN)
  295.                r_z = 0.D0
  296.                DO 4029 IGAU=1,NBNN
  297.                  IGMN = MIN(IGAU,I1MN)
  298.                  r_z = r_z + VELCHE(IGMN,IBMN)
  299.  4029          CONTINUE
  300.                WORK(IC) = r_z / NBNN
  301.              ELSE
  302.                WORK(IC) = 0.D0
  303.              ENDIF
  304.            ELSE
  305.              WORK(IC) = 0.D0
  306.            ENDIF
  307.  6029    CONTINUE
  308. C
  309. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  310. C                   EQUIVALENTE
  311.          IF(MELE.EQ.42) THEN
  312.            CISA=WORK(4)
  313.            VX=WORK(5)
  314.            VY=WORK(6)
  315.            VZ=WORK(7)
  316.            CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  317.          ENDIF
  318. C
  319. C  ON CALCULE LES DEFORMATIONS
  320. C
  321.          IF(MELE.EQ.84) THEN
  322. C
  323.           IF(CMATE.EQ.'SECTION') THEN
  324.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  325.               CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2)
  326.             ELSE
  327.               CALL TIMEPS(XE,XDDL,WORK(1),WORK(12),WORK(25),IREPS2)
  328.             ENDIF
  329.           ELSE
  330. C
  331.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  332.               CALL TIMEP2(XE,XDDL,WORK(12),WORK(25),IREPS2)
  333. C
  334.             ELSE
  335.               CALL TIMEPS(XE,XDDL,WORK(7),WORK(12),WORK(25),IREPS2)
  336.             ENDIF
  337.           ENDIF
  338.          ELSE
  339. C
  340.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  341.               CALL POUEP2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2
  342.      $         ,youtc,xnutc)
  343.             ELSE
  344. C
  345.               CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2
  346.      $        , youtc,xnutc)
  347.             ENDIF
  348.          ENDIF
  349. C
  350. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  351. C
  352.            IE=12
  353. C
  354.          MPTVAL=IVAEPS
  355.          DO IGAU=1,NBPTEL
  356.            DO ICOMP=1,NSTRS
  357.              MELVAL=IVAL(ICOMP)
  358.              VELCHE(IGAU,IB)=WORK(IE)
  359.              IE=IE+1
  360.            enddo
  361.          enddo
  362. C
  363.  3027 CONTINUE
  364.       SEGSUP WRK1,WRK3
  365.       GOTO 510
  366. C_______________________________________________________________________
  367. C
  368. C     ELEMENT DKT
  369. C_______________________________________________________________________
  370. C
  371.   28  CONTINUE
  372.       NBNO=NBNN
  373.       SEGINI WRK1,WRK2,WRK4
  374.       IF(NPINT.NE.0)THEN
  375.         NSTRS1=6
  376.         SEGINI WRK5
  377.       ENDIF
  378.       DO 3028  IB=1,NBELEM
  379. C
  380. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  381. C
  382.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  383. C
  384. C     ON CHERCHE LES DEPLACEMENTS
  385. C
  386.          MPTVAL=IVADEP
  387.          IE=1
  388.          DO      IGAU=1,NBNN
  389.             DO      ICOMP=1,NDEP
  390.                MELVAL=IVAL(ICOMP)
  391.                IGMN=MIN(IGAU,VELCHE(/1))
  392.                IBMN=MIN(IB  ,VELCHE(/2))
  393.                XDDL(IE)=VELCHE(IGMN,IBMN)
  394.                IE=IE+1
  395.             enddo
  396.          enddo
  397. C
  398. C     ON CHERCHE L EPAISSEUR ET L EXCENTREMENT
  399. C
  400.             MPTVAL=IVACAR
  401.             MELVAL=IVAL(1)
  402.             IF (MELVAL.NE.0) THEN
  403.                IBMN=MIN(IB,VELCHE(/2))
  404.                EPAIST=VELCHE(1,IBMN)
  405.             ELSE
  406.                EPAIST=0.D0
  407.             ENDIF
  408.             MELVAL=IVAL(2)
  409.             IF (MELVAL.NE.0) THEN
  410.                IBMN=MIN(IB,VELCHE(/2))
  411.                EXCEN=VELCHE(1,IBMN)
  412.             ELSE
  413.                EXCEN=0.D0
  414.             ENDIF
  415. C
  416.          CALL VPAST(XE,BPSS)
  417. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  418.          CALL VCORLC (XE,XEL,BPSS)
  419.          CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  420. C
  421.       IF(NPINT.EQ.0)THEN
  422. C
  423. C     COQUE GLOBAL
  424. C
  425. C     BOUCLE SUR LES POINTS DE GAUSS
  426. C
  427.          DO 5028  IGAU=1,NBPTEL
  428.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  429.      &           MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL,
  430.      &          SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  431. C
  432. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  433. C
  434.           IF (EXCEN.NE.0.) THEN
  435.             DO      IJL=1,3
  436.                DO      IJC=1,LRE
  437.                   BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  438.                enddo
  439.             enddo
  440.           ENDIF
  441. C
  442.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  443. C
  444. C     CALCUL DES EPS 2
  445. C
  446.             IF(IREPS2.EQ.1)
  447.      1       CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS)
  448. C
  449. C     RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  450. C
  451.             MPTVAL=IVAEPS
  452.             DO 9028 ICOMP=1,NSTRS
  453.                MELVAL=IVAL(ICOMP)
  454.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  455.  9028       CONTINUE
  456.  5028    CONTINUE
  457. C
  458.       ELSE
  459. C
  460. C    COQUE INTEGREE
  461. C
  462.       NBPGA1=NBPGAU/NPINT
  463. C
  464. C     BOUCLE SUR LES POINTS DE GAUSS DE LA SURFACE
  465. C
  466.       DO 5001 IGAU=1, NBPGA1
  467.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  468.      &          MELE,MFR,NBNO,LRE,IFOUR,NSTRS1,0,1.D0,XEL,
  469.      &          SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  470. C
  471. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  472. C
  473.           IF (EXCEN.NE.0.) THEN
  474.       DO      IJL=1,3
  475.       DO      IJC=1,LRE
  476.         BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  477.       enddo
  478.       enddo
  479.           ENDIF
  480. C
  481. C   BOUCLE SUR LES NAPPES
  482. C
  483.       DO 5002 INAP=1,NPINT
  484.       IGAU1=(INAP-1)*NBPGA1+IGAU
  485. C
  486.       CALL BST(BGENE,XDDLOC,LRE,NSTRS1,XSTRS1)
  487. C
  488. C     CALCUL DES EPS 2
  489. C
  490.       IF(IREPS2.EQ.1)
  491.      1  CALL BDKT2(XEL,XDDLOC,IGAU,BGENE,XSTRS1)
  492. C
  493.       ZZZ=DZEGAU(IGAU1)*(0.5D0*EPAIST)
  494.       XSTRS(1)=XSTRS1(1)+ZZZ*XSTRS1(4)
  495.       XSTRS(2)=XSTRS1(2)+ZZZ*XSTRS1(5)
  496.       XSTRS(3)=0.D0
  497.       XSTRS(4)=XSTRS1(3)+ZZZ*XSTRS1(6)
  498. C
  499. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  500. C
  501.       MPTVAL=IVAEPS
  502.       DO 9001 ICOMP=1,NSTRS
  503.         MELVAL=IVAL(ICOMP)
  504.         VELCHE(IGAU1,IB)=XSTRS(ICOMP)
  505.  9001 CONTINUE
  506. C
  507. C FIN DE BOUCLE SUR LES NAPPES DE POINTS
  508.  5002 CONTINUE
  509. C FIN DE BOUCLE SUR  LES POINTS DANS CHAQUE NAPPE
  510.  5001 CONTINUE
  511. C FIN DE BOUCLE SUR LES POINTS D'INTEGRATION
  512.       ENDIF
  513. C FIN DE BOUCLE SUR LES ELEMENTS
  514.  3028 CONTINUE
  515.       SEGSUP WRK1,WRK2,WRK4
  516.       IF(NPINT.NE.0) SEGSUP WRK5
  517. C
  518.       GOTO 510
  519. C_______________________________________________________________________
  520. C
  521. C     ELEMENTS COQ8  ET COQ6
  522. C_______________________________________________________________________
  523. C
  524.   41  CONTINUE
  525.       SEGINI WRK1,WRK3
  526.       MINTE1=IPMIN1
  527.       SEGACT MINTE1
  528.       NBPGA1=MINTE1.SHPTOT(/3)
  529. C      NBN1  =MINTE1.SHPTOT(/2)
  530. C
  531. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  532. C
  533.       DO  3041 IB=1,NBELEM
  534. C
  535. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  536. C
  537.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  538. C
  539. C     ON CHERCHE LES DEPLACEMENTS
  540. C
  541.          MPTVAL=IVADEP
  542.          IE=1
  543.          DO      IGAU=1,NBNN
  544.             DO      ICOMP=1,NDEP
  545.                MELVAL=IVAL(ICOMP)
  546.                IGMN=MIN(IGAU,VELCHE(/1))
  547.                IBMN=MIN(IB  ,VELCHE(/2))
  548.                XDDL(IE)=VELCHE(IGMN,IBMN)
  549.                IE=IE+1
  550.             enddo
  551.          enddo
  552. C
  553. C     ON CHERCHE LES EPAISSEURS ET LES EXCENTREMENTS,
  554. C     ON LES MOYENNE SUR L'ELEMENT.
  555. C
  556.          MPTVAL=IVACAR
  557.          MELVAL=IVAL(1)
  558.          EPAIST=0.D0
  559.          IF (MELVAL.NE.0) THEN
  560.            IBMN=MIN(IB  ,VELCHE(/2))
  561.            DO  IGAU=1,NBPGAU
  562.                IGMN=MIN(IGAU,VELCHE(/1))
  563.                EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  564.            ENDDO
  565.            EPAIST=EPAIST/NBPGAU
  566.          ENDIF
  567. C
  568.          MELVAL=IVAL(2)
  569.          EXCEN=0.D0
  570.          IF (MELVAL.NE.0) THEN
  571.            IBMN=MIN(IB  ,VELCHE(/2))
  572.            DO  IGAU=1,NBPGAU
  573.                IGMN=MIN(IGAU,VELCHE(/1))
  574.                EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  575.            ENDDO
  576.            EXCEN=EXCEN/NBPGAU
  577.          ENDIF
  578. C
  579. C     ON CALCULE LES DEFORMATIONS
  580. C
  581.          CALL COQ8EP(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,EXCEN,
  582.      1      DZEGAU,SHPTOT,MINTE1.SHPTOT,XDDL,WORK,IRR)
  583. C
  584. C     ON REMPLIT LES DEFORMATIONS
  585. C
  586.          MPTVAL=IVAEPS
  587.          IE=1
  588.          DO      IGAU=1,NBPGAU
  589.             DO      ICOMP=1,NSTRS
  590.                MELVAL=IVAL(ICOMP)
  591.                VELCHE(IGAU,IB)=WORK(IE)
  592.                IE=IE+1
  593.             enddo
  594.          enddo
  595. C
  596.  3041 CONTINUE
  597.       SEGSUP WRK1,WRK3
  598.       GOTO 510
  599. C_______________________________________________________________________
  600. C
  601. C     ELEMENT COQ2
  602. C_______________________________________________________________________
  603. C
  604.    44 CONTINUE
  605.       NBNO=NBNN
  606.       SEGINI WRK1,WRK2
  607. C
  608.       NDDD=NDEP
  609.       IF (IFOUR.EQ.-3) NDDD=NDEP-3
  610.       DO 3044 IB=1,NBELEM
  611. C
  612. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  613. C
  614.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  615.  
  616.        IF (IFOUR.EQ.1.AND.IDIM.EQ.3) THEN
  617. c jk148537 assume 1->r 3->z 
  618.          do in=1,nbnn
  619.            xe(2,in) = xe(3,in)
  620.          enddo
  621.        ENDIF
  622. C
  623. C     ON CHERCHE LES DEPLACEMENTS
  624. C
  625.          MPTVAL=IVADEP
  626.          IE=1
  627.          DO      IGAU=1,NBNN
  628.             DO      ICOMP=1,NDDD
  629.                MELVAL=IVAL(ICOMP)
  630.                IGMN=MIN(IGAU,VELCHE(/1))
  631.                IBMN=MIN(IB  ,VELCHE(/2))
  632.                XDDL(IE)=VELCHE(IGMN,IBMN)
  633.                IE=IE+1
  634.             enddo
  635.          enddo
  636.          IF (IFOUR.EQ.-3) THEN
  637.                XDDL(IE)=UZDPG
  638.                XDDL(IE+1)=RYDPG
  639.                XDDL(IE+2)=RXDPG
  640.          ENDIF
  641. C
  642. C     BOUCLE SUR LES POINTS DE GAUSS
  643. C
  644.             DO 4044 IGAU=1,NBPGAU
  645.                MPTVAL=IVACAR
  646.                MELVAL=IVAL(2)
  647.                IF (MELVAL.NE.0) THEN
  648.                   IBMN=MIN(IB,VELCHE(/2))
  649.                   EXCEN=VELCHE(1,IBMN)
  650.                 ELSE
  651.                   EXCEN=0.D0
  652.                 ENDIF
  653. C     APPEL A BCOQ2
  654. C
  655.       CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  656.      .           EXCEN,1.D0,IRR,XDPGE,YDPGE)
  657. C
  658. C     GESTION D'ERREUR
  659. C
  660.             IF (IRR.EQ.1) THEN
  661.               INTERR(1)=IB
  662.               CALL ERREUR(255)
  663.               GOTO 9944
  664.             ELSE IF(IRR.EQ.2) THEN
  665.               INTERR(1)=IB
  666.               CALL ERREUR(256)
  667.               GOTO 9944
  668.             ENDIF
  669. C
  670.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  671.  
  672.             IF(IREPS2.EQ.1)
  673.      +call b2coq2(xstrs,nstrs,xddl,nbnn*ndep,xe,nbnn,QSIGAU,POIGAU,igau)
  674. C
  675. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  676. C
  677.             MPTVAL=IVAEPS
  678.             DO 9044 ICOMP=1,NSTRS
  679.                MELVAL=IVAL(ICOMP)
  680.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  681.  9044       CONTINUE
  682.  4044    CONTINUE
  683.  3044 CONTINUE
  684. C
  685.  9944 CONTINUE
  686.       SEGSUP WRK1,WRK2
  687.       GOTO 510
  688. C_______________________________________________________________________
  689. C
  690. C     ELEMENT COQ4
  691. C_______________________________________________________________________
  692. C
  693.    49 CONTINUE
  694.       NBNO=NBNN
  695.       SEGINI WRK1,WRK2,WRK4
  696. C
  697.       DO 3049 IB=1,NBELEM
  698. C
  699. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  700. C
  701.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  702. C
  703.          CALL CQ4LOC(XE,XEL,BPSS,IERT,1)
  704. C        IERT=1 NODI  TROPPO VICINI
  705.          IF (IERT.EQ.1) THEN
  706.            INTERR(1)=IB
  707.            CALL ERREUR(323)
  708.            GOTO 9949
  709.          ELSE IF(IERT.EQ.3) THEN
  710.             IERT = 0
  711.             NOPLAN = 1
  712.          ELSE
  713.             NOPLAN = 0
  714.          END IF
  715. C
  716. C     ON CHERCHE LES DEPLACEMENTS
  717. C
  718.          IE=1
  719.          DO      IGAU=1,NBNN
  720.             MPTVAL=IVADEP
  721.             DO      ICOMP=1,NDEP
  722.                MELVAL=IVAL(ICOMP)
  723.                IGMN=MIN(IGAU,VELCHE(/1))
  724.                IBMN=MIN(IB  ,VELCHE(/2))
  725.                XDDL(IE)=VELCHE(IGMN,IBMN)
  726.                IE=IE+1
  727.             enddo
  728.          enddo
  729.          CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  730. C
  731. C     BOUCLE SUR LES POINTS DE GAUSS
  732. C
  733.          MPTVAL=IVACAR
  734.          MELVAL=IVAL(1)
  735.          IF (MELVAL.NE.0) THEN
  736.             IBMN=MIN(IB,VELCHE(/2))
  737.             EPAIST=VELCHE(1,IBMN)
  738.          ELSE
  739.             EPAIST=0.D0
  740.          ENDIF
  741. C
  742.          MELVAL=IVAL(2)
  743.          IF (MELVAL.NE.0) THEN
  744.             IBMN=MIN(IB,VELCHE(/2))
  745.             EXCEN=VELCHE(1,IBMN)
  746.          ELSE
  747.             EXCEN=0.D0
  748.          ENDIF
  749. C
  750.          DO 4049 IGAU=1,NBPGAU
  751. C
  752.             if(cmate.eq.'ISOTROPE') then
  753.             CALL BCOQ4
  754.      &      (IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1)
  755.             else
  756.             CALL BCOQ4O
  757.      &      (IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1)
  758.             endif
  759. C           IERT=1 JACOBIANO <= 0
  760.             IF(IERT.EQ.1) THEN
  761.               INTERR(1)=IB
  762.               CALL ERREUR(321)
  763.               GOTO 9949
  764.             ENDIF
  765. C
  766.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  767. C
  768. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  769. C
  770.             MPTVAL=IVAEPS
  771.             DO 9049 ICOMP=1,NSTRS
  772.                MELVAL=IVAL(ICOMP)
  773.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  774.  9049       CONTINUE
  775.  4049    CONTINUE
  776.  3049 CONTINUE
  777. C
  778.  9949 CONTINUE
  779.       SEGSUP WRK1,WRK2,WRK4
  780.       GOTO 510
  781. C_______________________________________________________________________
  782. C
  783. C     ELEMENT JOINT (JOI2)
  784. C_______________________________________________________________________
  785. C
  786.    85 CONTINUE
  787.       NBNO=NBNN
  788.       SEGINI WRK1,WRK2,WRK4
  789. C
  790.       DO 3085 IB=1,NBELEM
  791. C
  792. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  793. C
  794.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  795. C
  796.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  797. C
  798. C     ON CHERCHE LES DEPLACEMENTS
  799. C
  800.          MPTVAL=IVADEP
  801.          IE=1
  802.          DO      IGAU=1,NBNN
  803.             DO      ICOMP=1,NDEP
  804.                MELVAL=IVAL(ICOMP)
  805.                IGMN=MIN(IGAU,VELCHE(/1))
  806.                IBMN=MIN(IB  ,VELCHE(/2))
  807.                XDDL(IE)=VELCHE(IGMN,IBMN)
  808.                IE=IE+1
  809.             enddo
  810.          enddo
  811. C
  812. C     BOUCLE SUR LES POINTS DE GAUSS
  813. C
  814.          DO 4085 IGAU=1,NBPGAU
  815. C
  816.             CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  817.      .                                       BGENE,DJAC,IRRT)
  818. C           IRRT.NE.0 JACOBIEN <= 0
  819.             IF(IRRT.NE.0) THEN
  820.               INTERR(1)=IB
  821.               CALL ERREUR(612)
  822.               GOTO 9985
  823.             ENDIF
  824. C
  825.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  826. C
  827. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  828. C
  829.             MPTVAL=IVAEPS
  830.             DO 9085 ICOMP=1,NSTRS
  831.                MELVAL=IVAL(ICOMP)
  832.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  833.  9085       CONTINUE
  834.  4085    CONTINUE
  835.  3085 CONTINUE
  836. C
  837.  9985 CONTINUE
  838.       SEGSUP WRK1,WRK2,WRK4
  839.       GOTO 510
  840. C_______________________________________________________________________
  841. C
  842. C     ELEMENT JOINT (JGI2)
  843. C_______________________________________________________________________
  844. C
  845.   170 CONTINUE
  846.       NBNO=NBNN
  847.       SEGINI WRK1,WRK2,WRK4
  848. C
  849.       NDDD=NDEP
  850.       IF (IFOUR.EQ.-3) NDDD=NDEP-3
  851. C
  852.       DO IB=1,NBELEM
  853. C
  854. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  855. C
  856.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  857. C
  858.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  859. C
  860. C     ON CHERCHE LES DEPLACEMENTS
  861. C
  862.          MPTVAL=IVADEP
  863.          IE=1
  864.          DO IGAU=1,NBNN
  865.             DO ICOMP=1,NDDD
  866.                MELVAL=IVAL(ICOMP)
  867.                IGMN=MIN(IGAU,VELCHE(/1))
  868.                IBMN=MIN(IB  ,VELCHE(/2))
  869.                XDDL(IE)=VELCHE(IGMN,IBMN)
  870.                IE=IE+1
  871.             ENDDO
  872.          ENDDO
  873.          IF (IFOUR.EQ.-3) THEN
  874.                XDDL(IE)=UZDPG
  875.                XDDL(IE+1)=RYDPG
  876.                XDDL(IE+2)=RXDPG
  877.          ENDIF
  878. C
  879. C     BOUCLE SUR LES POINTS DE GAUSS
  880. C
  881.          DO IGAU=1,NBPGAU
  882. C
  883. C        ON CHERCHE L EPAISSEUR DU JOINT
  884. C
  885.             MPTVAL=IVACAR
  886.             MELVAL=IVAL(1)
  887.             IF (MELVAL.NE.0) THEN
  888.               IGMN=MIN(IGAU,VELCHE(/1))
  889.               IBMN=MIN(IB,VELCHE(/2))
  890.               EPAIST=VELCHE(IGMN,IBMN)
  891.             ELSE
  892.               EPAIST=0.D0
  893.             ENDIF
  894. C
  895. CcPPj       CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  896. CcPPj.                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  897.             CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  898.      .                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  899. C           IRRT.NE.0 JACOBIEN <= 0
  900.             IF (IRRT.NE.0) THEN
  901.               INTERR(1)=IB
  902.               CALL ERREUR(612)
  903.               GOTO 9970
  904.             ENDIF
  905. C
  906.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  907. C
  908. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  909. C
  910.             MPTVAL=IVAEPS
  911.             DO ICOMP=1,NSTRS
  912.                MELVAL=IVAL(ICOMP)
  913.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  914.             ENDDO
  915.          ENDDO
  916.       ENDDO
  917. C
  918.  9970 CONTINUE
  919.       SEGSUP WRK1,WRK2,WRK4
  920.       GOTO 510
  921. C_______________________________________________________________________
  922. C
  923. C     ELEMENT JOINT (JCT3) en 2D cisaillement
  924. C_______________________________________________________________________
  925. C
  926.   168 CONTINUE
  927.       NBNO=NBNN
  928.       SEGINI WRK1,WRK2,WRK4
  929. C
  930.       DO IB=1,NBELEM
  931. C
  932. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  933. C
  934.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  935. C
  936.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  937. C
  938. C     ON CHERCHE LES DEPLACEMENTS
  939. C
  940.          IE=1
  941.          MPTVAL=IVADEP
  942.          DO IGAU=1,NBNN
  943.             DO ICOMP=1,NDEP
  944.                MELVAL=IVAL(ICOMP)
  945.                IGMN=MIN(IGAU,VELCHE(/1))
  946.                IBMN=MIN(IB  ,VELCHE(/2))
  947.                XDDL(IE)=VELCHE(IGMN,IBMN)
  948.                IE=IE+1
  949.             END DO
  950.          END DO
  951. C
  952. C     BOUCLE SUR LES POINTS DE GAUSS
  953. C
  954.          DO IGAU=1,NBPGAU
  955. C
  956.             CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  957.      .                                       BGENE,DJAC,IRRT)
  958. C           IRRT.NE.0 JACOBIEN <= 0
  959.             IF(IRRT.NE.0) THEN
  960.               INTERR(1)=IB
  961.               GOTO 9968
  962.             ENDIF
  963. C
  964.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  965. C
  966. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  967. C
  968.             MPTVAL=IVAEPS
  969.             DO ICOMP=1,NSTRS
  970.                MELVAL=IVAL(ICOMP)
  971.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  972.             END DO
  973.          END DO
  974.       END DO
  975. C
  976.  9968 CONTINUE
  977.       SEGSUP WRK1,WRK2,WRK4
  978.       GOTO 510
  979. C_______________________________________________________________________
  980. C
  981. C     ELEMENT JOINT (JGT3) GENERALISE
  982. C_______________________________________________________________________
  983. C
  984.   171 CONTINUE
  985.       NBNO=NBNN
  986.       SEGINI WRK1,WRK2,WRK4
  987. C
  988.       DO IB=1,NBELEM
  989. C
  990. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  991. C
  992.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  993. C
  994.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  995. C
  996. C     ON CHERCHE LES DEPLACEMENTS
  997. C
  998.          MPTVAL=IVADEP
  999.          IE=1
  1000.          DO IGAU=1,NBNN
  1001.             DO ICOMP=1,NDEP
  1002.                MELVAL=IVAL(ICOMP)
  1003.                IGMN=MIN(IGAU,VELCHE(/1))
  1004.                IBMN=MIN(IB  ,VELCHE(/2))
  1005.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1006.                IE=IE+1
  1007.             END DO
  1008.          END DO
  1009. C
  1010. C     BOUCLE SUR LES POINTS DE GAUSS
  1011. C
  1012.          DO IGAU=1,NBPGAU
  1013. C
  1014. C        ON CHERCHE L'EPAISSEUR DU JOINT
  1015. C
  1016.             MPTVAL=IVACAR
  1017.             MELVAL=IVAL(1)
  1018.             IF (MELVAL.NE.0) THEN
  1019.               IGMN=MIN(IGAU,VELCHE(/1))
  1020.               IBMN=MIN(IB,VELCHE(/2))
  1021.               EPAIST=VELCHE(IGMN,IBMN)
  1022.             ELSE
  1023.               EPAIST=0.D0
  1024.             ENDIF
  1025. C
  1026. C     ON CALCULE B
  1027. C
  1028. CcPPj       CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1029.             CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1030.      .                                EPAIST,BGENE,DJAC,IRRT)
  1031. C           IRRT.NE.0 JACOBIEN <= 0
  1032.             IF (IRRT.NE.0) THEN
  1033.               INTERR(1)=IB
  1034.               CALL ERREUR(611)
  1035.               GOTO 9971
  1036.             ENDIF
  1037. C
  1038.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1039. C
  1040. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1041. C
  1042.             MPTVAL=IVAEPS
  1043.             DO ICOMP=1,NSTRS
  1044.                MELVAL=IVAL(ICOMP)
  1045.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1046.             END DO
  1047.          END DO
  1048.       END DO
  1049. C
  1050.  9971 CONTINUE
  1051.       SEGSUP WRK1,WRK2,WRK4
  1052.       GOTO 510
  1053. C_______________________________________________________________________
  1054. C
  1055. C     ELEMENT JOINT (JCI4) en 2D cisaillement
  1056. C_______________________________________________________________________
  1057. C
  1058.   169 CONTINUE
  1059.       NBNO=NBNN
  1060.       SEGINI WRK1,WRK2,WRK4
  1061. C
  1062.       DO IB=1,NBELEM
  1063. C
  1064. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1065. C
  1066.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1067. C
  1068.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1069. C
  1070. C     ON CHERCHE LES DEPLACEMENTS
  1071. C
  1072.          MPTVAL=IVADEP
  1073.          IE=1
  1074.          DO IGAU=1,NBNN
  1075.             DO ICOMP=1,NDEP
  1076.                MELVAL=IVAL(ICOMP)
  1077.                IGMN=MIN(IGAU,VELCHE(/1))
  1078.                IBMN=MIN(IB  ,VELCHE(/2))
  1079.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1080.                IE=IE+1
  1081.             ENDDO
  1082.          ENDDO
  1083. C
  1084. C     BOUCLE SUR LES POINTS DE GAUSS
  1085. C
  1086.          DO IGAU=1,NBPGAU
  1087. C
  1088.             CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1089. C           IRRT.NE.0 JACOBIEN <= 0
  1090.             IF(IRRT.NE.0) THEN
  1091.               INTERR(1)=IB
  1092.               CALL ERREUR(611)
  1093.               GOTO 9969
  1094.             ENDIF
  1095. C
  1096.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1097. C
  1098. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1099. C
  1100.             MPTVAL=IVAEPS
  1101.             DO ICOMP=1,NSTRS
  1102.                MELVAL=IVAL(ICOMP)
  1103.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1104.             ENDDO
  1105.          ENDDO
  1106.       ENDDO
  1107. C
  1108.  9969 CONTINUE
  1109.       SEGSUP WRK1,WRK2,WRK4
  1110.       GOTO 510
  1111. C_______________________________________________________________________
  1112. C
  1113. C     ELEMENT JOINT (JGI4) GENERALISE
  1114. C_______________________________________________________________________
  1115. C
  1116.   172 CONTINUE
  1117.       NBNO=NBNN
  1118.       SEGINI WRK1,WRK2,WRK4
  1119. C
  1120.       DO IB=1,NBELEM
  1121. C
  1122. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1123. C
  1124.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1125. C
  1126.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1127. C
  1128. C     ON CHERCHE LES DEPLACEMENTS
  1129. C
  1130.          MPTVAL=IVADEP
  1131.          IE=1
  1132.          DO IGAU=1,NBNN
  1133.             DO ICOMP=1,NDEP
  1134.                MELVAL=IVAL(ICOMP)
  1135.                IGMN=MIN(IGAU,VELCHE(/1))
  1136.                IBMN=MIN(IB  ,VELCHE(/2))
  1137.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1138.                IE=IE+1
  1139.             ENDDO
  1140.          ENDDO
  1141. C
  1142. C     BOUCLE SUR LES POINTS DE GAUSS
  1143. C
  1144.          DO IGAU=1,NBPGAU
  1145. C
  1146. C        ON CHERCHE L'EPAISSEUR DU JOINT
  1147. C
  1148.             MPTVAL=IVACAR
  1149.             MELVAL=IVAL(1)
  1150.             IF (MELVAL.NE.0) THEN
  1151.               IGMN=MIN(IGAU,VELCHE(/1))
  1152.               IBMN=MIN(IB,VELCHE(/2))
  1153.               EPAIST=VELCHE(IGMN,IBMN)
  1154.             ELSE
  1155.               EPAIST=0.D0
  1156.             ENDIF
  1157. C
  1158. CcPPj       CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1159.             CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1160.      >                 BGENE,DJAC,IRRT)
  1161. C           IRRT.NE.0 JACOBIEN <= 0
  1162.             IF (IRRT.NE.0) THEN
  1163.               INTERR(1)=IB
  1164.               CALL ERREUR(611)
  1165.               GOTO 9972
  1166.             ENDIF
  1167. C
  1168.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1169. C
  1170. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1171. C
  1172.             MPTVAL=IVAEPS
  1173.             DO ICOMP=1,NSTRS
  1174.                MELVAL=IVAL(ICOMP)
  1175.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1176.             ENDDO
  1177.          ENDDO
  1178.       ENDDO
  1179. C
  1180.  9972 CONTINUE
  1181.       SEGSUP WRK1,WRK2,WRK4
  1182.       GOTO 510
  1183.  
  1184. C_______________________________________________________________________
  1185. C
  1186. C     ELEMENT JOINT (JOI3) IMPLEMENTATION SANS TEST DE PLANEITE
  1187. C                                         ET SANS REPERE LOCAL
  1188. C_______________________________________________________________________
  1189. C
  1190.    86 CONTINUE
  1191.       NBNO=NBNN
  1192.       SEGINI WRK1,WRK2,WRK4
  1193. C
  1194.       DO 3086 IB=1,NBELEM
  1195. C
  1196. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1197. C
  1198.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1199. C
  1200. C     ON CHERCHE LES DEPLACEMENTS
  1201. C
  1202.          MPTVAL=IVADEP
  1203.          IE=1
  1204.          DO      IGAU=1,NBNN
  1205.             DO      ICOMP=1,NDEP
  1206.                MELVAL=IVAL(ICOMP)
  1207.                IGMN=MIN(IGAU,VELCHE(/1))
  1208.                IBMN=MIN(IB  ,VELCHE(/2))
  1209.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1210.                IE=IE+1
  1211.             enddo
  1212.          enddo
  1213. C
  1214. C     BOUCLE SUR LES POINTS DE GAUSS
  1215. C
  1216.          DO 4086 IGAU=1,NBPGAU
  1217. C
  1218.             CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS)
  1219. C
  1220.             CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  1221.      .                                     BGENE,DJAC,IRRT)
  1222. C           IRRT.NE.0 JACOBIEN <= 0
  1223.             IF (IRRT.NE.0) THEN
  1224.               INTERR(1)=IB
  1225.               CALL ERREUR(612)
  1226.               GOTO 9986
  1227.             ENDIF
  1228. C
  1229.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1230. C
  1231. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1232. C
  1233.             MPTVAL=IVAEPS
  1234.             DO 9086 ICOMP=1,NSTRS
  1235.                MELVAL=IVAL(ICOMP)
  1236.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1237.  9086       CONTINUE
  1238.  4086    CONTINUE
  1239.  3086 CONTINUE
  1240. C
  1241. C     IMPRESSION D'UN MESSAGE D'ERREUR
  1242. C
  1243.  9986 CONTINUE
  1244.       SEGSUP WRK1,WRK2,WRK4
  1245.       GOTO 510
  1246. C_______________________________________________________________________
  1247. C
  1248. C     ELEMENT JOINT (JOT3)
  1249. C_______________________________________________________________________
  1250. C
  1251.    87 CONTINUE
  1252.       NBNO=NBNN
  1253.       SEGINI WRK1,WRK2,WRK4
  1254. C
  1255.       DO 3087 IB=1,NBELEM
  1256. C
  1257. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1258. C
  1259.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1260. C
  1261.          CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1262. C
  1263. C     ON CHERCHE LES DEPLACEMENTS
  1264. C
  1265.          MPTVAL=IVADEP
  1266.          IE=1
  1267.          DO      IGAU=1,NBNN
  1268.             DO      ICOMP=1,NDEP
  1269.                MELVAL=IVAL(ICOMP)
  1270.                IGMN=MIN(IGAU,VELCHE(/1))
  1271.                IBMN=MIN(IB  ,VELCHE(/2))
  1272.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1273.                IE=IE+1
  1274.             enddo
  1275.          enddo
  1276. C
  1277. C     BOUCLE SUR LES POINTS DE GAUSS
  1278. C
  1279.          DO 4087 IGAU=1,NBPGAU
  1280. C
  1281.             CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1282.      .                                       BGENE,DJAC,IRRT)
  1283. C           IRRT.NE.0 JACOBIEN <= 0
  1284.             IF (IRRT.NE.0) THEN
  1285.               INTERR(1)=IB
  1286.               CALL ERREUR(611)
  1287.               GOTO 9987
  1288.             ENDIF
  1289. C
  1290.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1291. C
  1292. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1293. C
  1294.             MPTVAL=IVAEPS
  1295.             DO 9087 ICOMP=1,NSTRS
  1296.                MELVAL=IVAL(ICOMP)
  1297.                VELCHE(IGAU,IBMN)=XSTRS(ICOMP)
  1298.  9087       CONTINUE
  1299.  4087    CONTINUE
  1300.  3087 CONTINUE
  1301. C
  1302.  9987 CONTINUE
  1303.       SEGSUP WRK1,WRK2,WRK4
  1304.       GOTO 510
  1305. C_______________________________________________________________________
  1306. C
  1307. C     ELEMENT JOINT (JOI4)
  1308. C_______________________________________________________________________
  1309. C
  1310.    88 CONTINUE
  1311.       NBNO=NBNN
  1312.       SEGINI WRK1,WRK2,WRK4
  1313. C
  1314.       DO 3088 IB=1,NBELEM
  1315. C
  1316. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1317. C
  1318.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1319. C
  1320.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1321. C
  1322. C     ON CHERCHE LES DEPLACEMENTS
  1323. C
  1324.          MPTVAL=IVADEP
  1325.          IE=1
  1326.          DO      IGAU=1,NBNN
  1327.             DO      ICOMP=1,NDEP
  1328.                MELVAL=IVAL(ICOMP)
  1329.                IGMN=MIN(IGAU,VELCHE(/1))
  1330.                IBMN=MIN(IB  ,VELCHE(/2))
  1331.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1332.                IE=IE+1
  1333.             enddo
  1334.          enddo
  1335. C
  1336. C     BOUCLE SUR LES POINTS DE GAUSS
  1337. C
  1338.          DO 4088 IGAU=1,NBPGAU
  1339. C
  1340.             CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1341. C           IRRT.NE.0 JACOBIEN <= 0
  1342.             IF (IRRT.NE.0) THEN
  1343.               INTERR(1)=IB
  1344.               CALL ERREUR(611)
  1345.               GOTO 9988
  1346.             ENDIF
  1347. C
  1348.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  1349. C
  1350. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1351. C
  1352.             MPTVAL=IVAEPS
  1353.             DO 9088 ICOMP=1,NSTRS
  1354.                MELVAL=IVAL(ICOMP)
  1355.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  1356.  9088       CONTINUE
  1357.  4088    CONTINUE
  1358.  3088 CONTINUE
  1359. C
  1360.  9988 CONTINUE
  1361.       SEGSUP WRK1,WRK2,WRK4
  1362.       GOTO 510
  1363. C_______________________________________________________________________
  1364. C
  1365. C     ELEMENT DST
  1366. C_______________________________________________________________________
  1367. C
  1368.   93  CONTINUE
  1369.       NBNO=NBNN
  1370.       NV1=NMATT
  1371.       SEGINI WRK1,WRK2,WRK3,WRK4,MVELCH
  1372.       IF(CMATE.NE.'ISOTROPE')THEN
  1373.          MPTVAL=IVAMAT
  1374.          IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN
  1375.             MELVAL=IVAL(7)
  1376.          ELSE
  1377.             MELVAL=IVAL(2)
  1378.          ENDIF
  1379.          NBGCOS=VELCHE(/1)
  1380.       ENDIF
  1381.       IRTD = 1
  1382.       DO 3093  IB=1,NBELEM
  1383. C
  1384. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1385. C
  1386.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1387. C
  1388. C     ON CHERCHE LES DEPLACEMENTS
  1389. C
  1390.          MPTVAL=IVADEP
  1391.          IE=1
  1392.          DO      IGAU=1,NBNN
  1393.             DO      ICOMP=1,NDEP
  1394.                MELVAL=IVAL(ICOMP)
  1395.                IGMN=MIN(IGAU,VELCHE(/1))
  1396.                IBMN=MIN(IB  ,VELCHE(/2))
  1397.                XDDL(IE)=VELCHE(IGMN,IBMN)
  1398.                IE=IE+1
  1399.             enddo
  1400.          enddo
  1401.          CALL VPAST(XE,BPSS)
  1402. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  1403.          CALL VCORLC (XE,XEL,BPSS)
  1404.          CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  1405. C
  1406. C     ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  1407. C                LES EXCENTREMENTS ET ON LES MOYENNE.
  1408. C
  1409.         MPTVAL=IVACAR
  1410.         EPAIST=0.D0
  1411.         MELVAL=IVAL(1)
  1412.         IF (MELVAL.NE.0) THEN
  1413.            IBMN=MIN(IB,VELCHE(/2))
  1414.         DO IGAU=1,NBPGAU
  1415.            IGMN=MIN(IGAU,VELCHE(/1))
  1416.            EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  1417.         ENDDO
  1418.         EPAIST=EPAIST/NBPGAU
  1419.         ENDIF
  1420. C
  1421.         EXCEN=0.D0
  1422.         MELVAL=IVAL(2)
  1423.         IF (MELVAL.NE.0) THEN
  1424.            IBMN=MIN(IB,VELCHE(/2))
  1425.         DO IGAU=1,NBPGAU
  1426.            IGMN=MIN(IGAU,VELCHE(/1))
  1427.            EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  1428.         ENDDO
  1429.         EXCEN=EXCEN/NBPGAU
  1430.         ENDIF
  1431. C
  1432. C     BOUCLE SUR LES POINTS DE GAUSS
  1433. C
  1434.          DO 5093  IGAU=1,NBPTEL
  1435. C
  1436. C Dans le cas des matériaux orthotropes, les déformations sont d'abord
  1437. C calculées dans le repère d'orthotropie (les formules utilisées par les
  1438. C routines RCDST et BMFDST ne sont valables que dans ce repère); elles
  1439. C sont ensuite exprimées dans le repère local de l'élément.
  1440. C
  1441. C     ON CHERCHE LA MATRICE DE HOOKE
  1442. C
  1443.       MPTVAL=IVAMAT
  1444.       IF(IMAT.EQ.2) THEN
  1445.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  1446.           MELVAL=IVAL(1)
  1447.           IBMN=MIN(IB  ,IELCHE(/2))
  1448.           IGMN=MIN(IGAU,IELCHE(/1))
  1449.           MLREEL=IELCHE(IGMN,IBMN)
  1450.           SEGACT MLREEL
  1451.           CALL DOHOOO(PROG,LHOOK,DDHOMU)
  1452.           SEGDES MLREEL
  1453.         ENDIF
  1454.       ELSE IF (IMAT.EQ.1) THEN
  1455.           DO 9193 IM=1,NMATT
  1456.             MELVAL=IVAL(IM)
  1457.             IF (MELVAL.NE.0) THEN
  1458.               IBMN=MIN(IB  ,VELCHE(/2))
  1459.               IGMN=MIN(IGAU,VELCHE(/1))
  1460.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  1461.             ELSE
  1462.               VALMAT(IM)=0.D0
  1463.             ENDIF
  1464.  9193     CONTINUE
  1465.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1466.      1     CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD)
  1467.         CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  1468.       ENDIF
  1469.       CALL ZERO(BGENE,NSTRS,LRE)
  1470.       IF(CMATE.NE.'ISOTROPE')THEN
  1471.         IF(IGAU.LE.NBGCOS)THEN
  1472.           IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN
  1473.             COSA=VALMAT(7)
  1474.             SINA=VALMAT(8)
  1475.           ELSE
  1476.             MPTVAL=IVAMAT
  1477.             MELVAL=IVAL(2)
  1478.             IBMN=MIN(IB  ,VELCHE(/2))
  1479.             IGMN=MIN(IGAU,VELCHE(/1))
  1480.             COSA=VELCHE(IGMN,IBMN)
  1481.             MELVAL=IVAL(3)
  1482.             IBMN=MIN(IB  ,VELCHE(/2))
  1483.             IGMN=MIN(IGAU,VELCHE(/1))
  1484.             SINA=VELCHE(IGMN,IBMN)
  1485.           ENDIF
  1486.           DO 1393 INO=1,NBNN
  1487.            XX=COSA*XEL(1,INO)+SINA*XEL(2,INO)
  1488.            YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO)
  1489.            XE(1,INO)=XX
  1490.            XE(2,INO)=YY
  1491.  1393     CONTINUE
  1492.         ENDIF
  1493. C
  1494. C     TERMES DE LA MATRICE DE RIGIDITE RELATIFS
  1495. C      AUX CISAILLEMENTS TRANSVERSES
  1496. C
  1497.         CALL RCDST(XE,NSTRS,LRE,DDHOMU,
  1498.      1                WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1499. C
  1500. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1501. C        DE MEMBRANE ET DE FLEXION
  1502. C
  1503.          CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1504.      1            WORK(1),WORK(10),WORK(19),BGENE,DUM)
  1505. C
  1506.          CALL ROTB(BGENE,NSTRS,COSA,SINA)
  1507.       ELSE
  1508. C
  1509. C     TERMES DE LA MATRICE B RELATIFS AUX CISAILLEMENTS TRANSVERSES
  1510. C
  1511.         CALL RCDST(XEL,NSTRS,LRE,DDHOMU,
  1512.      1          WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1513. C
  1514. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1515. C        DE MEMBRANE ET DE FLEXION
  1516. C
  1517.         CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1518.      1            WORK(1),WORK(10),WORK(19),BGENE,DJAC)
  1519.       ENDIF
  1520. C
  1521. C  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  1522. C
  1523.           IF (EXCEN.NE.0.) THEN
  1524.             DO      IJL=1,3
  1525.                DO      IJC=1,LRE
  1526.                   BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  1527.                enddo
  1528.             enddo
  1529.           ENDIF
  1530. C
  1531.             CALL BST(BGENE,XDDLOC,LRE,NSTRS,XSTRS)
  1532. C
  1533. C     CALCUL DES EPS 2
  1534. C
  1535.          IF(IREPS2.EQ.1)THEN
  1536.            IF(CMATE.EQ.'ORTHOTRO')THEN
  1537.              CALL BDST2(XE,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS)
  1538.             ELSE
  1539.              CALL BDST2(XEL,XDDLOC,IGAU,BGENE,CMATE,COSA,SINA,XSTRS)
  1540.             ENDIF
  1541.          ENDIF
  1542. C
  1543. C    CHANGEMENT DE REPERE: ORTHO -> LOCAL
  1544. C
  1545.          IF(CMATE.EQ.'ORTHOTRO')
  1546.      1          CALL CHGREP2(COSA,SINA,XSTRS,0,0)
  1547. C
  1548. C     RMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  1549. C
  1550.             MPTVAL=IVAEPS
  1551.             DO 9093 ICOMP=1,NSTRS
  1552.                MELVAL=IVAL(ICOMP)
  1553.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  1554.  9093       CONTINUE
  1555.  5093    CONTINUE
  1556.  3093 CONTINUE
  1557.  
  1558. C     ERREUR LE MATERIAU PAS ENCORE IMPLEMENTER POUR
  1559. C     LA FORMULATION MFR ET L OPTION IFOUR
  1560.       IF (IRTD.EQ.0) THEN
  1561.          MOTERR(1:8)=CMATE
  1562.          MOTERR(9:12)=NOMFR(MFR/2+1)
  1563.          INTERR(1)=IFOUR
  1564.          CALL ERREUR(81)
  1565.       ENDIF
  1566.  
  1567.       SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH
  1568.       GOTO 510
  1569. C____________________________________________________________________
  1570.    99 CONTINUE
  1571.       MOTERR(1:4)=NOMTP(MELE)
  1572.       MOTERR(9:12)='EPSI'
  1573.       CALL ERREUR(86)
  1574.  
  1575.   510 CONTINUE
  1576.       RETURN
  1577.       END
  1578.  
  1579.  
  1580.  
  1581.  

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