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

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