Télécharger la plaquette Cast3M


fr en

Télécharger epsi4.eso

Retour à la liste

Numérotation des lignes : 

epsi4

  1. C EPSI4     SOURCE    OF166741  25/02/21    21:16:14     12166          
  2.       SUBROUTINE EPSI4(IPMAIL,IVADEP,NDEP,IVAMAT,NMATT,IVACAR,NCARR,
  3.      &    IPMINT,MELE,LHOOK,IREPS2,NBPTEL,NSTRS,MFR,
  4.      &    NBPGAU,LRE,LW,IVAEPS,UZDPG,RYDPG,RXDPG,ISOUS,IIPDPG,CMATE)
  5. C---------------------------------------------------------------------*
  6. C                                                                     *
  7. C           CALCUL DES DEFORMATIONS                                   *
  8. C                                                                     *
  9. C   linespring,tuyau fissure,barre,cerce,tuyo,poi1                    *
  10. C                                                                     *
  11. C---------------------------------------------------------------------*
  12. C                                                                     *
  13. C   ENTREES :                                                         *
  14. C   ________                                                          *
  15. C                                                                     *
  16. C        IPMAIL   Pointeur sur un segment  MELEME                     *
  17. C        IVADEP   Pointeur sur le chamelem de deplacements            *
  18. C        NDEP     Nombre de composantes de deplacements               *
  19. C        IVACAR   Pointeur sur les chamelems de caracteristiques      *
  20. C        NCARR    Nombre de caracteristiques geometriques             *
  21. C        MELE     Numero de l'element fini                            *
  22. C        LHOOK    Dimension de la matrice de Hooke                    *
  23. C        IRESP2   Flag pour indiquer si on veut les contraintes       *
  24. C                  de Piola-Kirchhoff                                 *
  25. C        NBPTEL   Nombre de points par element                        *
  26. C        NSTRS    Nombre de composante de contraintes/deformations    *
  27. C        MFR      Numero de formulation de l'element fini             *
  28. C                 pour une matrice de hooke                           *
  29. C        NBPGAU   Nombre de point d'integration pour la rigidite      *
  30. C        LRE      Nombre de ddl dans la matrice de rigidite           *
  31. C        LW       Dimension du tableau de travail de l'element        *
  32. C                                                                     *
  33. C   SORTIES :                                                         *
  34. C   ________                                                          *
  35. C                                                                     *
  36. C        IVAEPS   pointeur sur un segment MPTVAL contenant les        *
  37. C                 les melvals de deformations                         *
  38. C                                                                     *
  39. C---------------------------------------------------------------------*
  40.       IMPLICIT INTEGER(I-N)
  41.       IMPLICIT REAL*8(A-H,O-Z)
  42.  
  43. -INC PPARAM
  44. -INC CCOPTIO
  45. -INC CCHAMP
  46.  
  47. -INC SMCOORD
  48. -INC SMCHAML
  49. -INC SMCHPOI
  50. -INC SMELEME
  51. -INC SMMODEL
  52. -INC SMINTE
  53. -INC SMLREEL
  54.  
  55. -INC TMPTVAL
  56.  
  57.       SEGMENT MWRK1
  58.         REAL*8 DDHOOK(NSTR,NSTR),XDDL(LRE),XSTRS(NSTR)
  59.         REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTR)
  60.       ENDSEGMENT
  61.  
  62.       SEGMENT MWRK2
  63.         REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  64.       ENDSEGMENT
  65.  
  66.       SEGMENT MWRK4
  67.         REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  68.       ENDSEGMENT
  69.  
  70.       SEGMENT MWRK5
  71.         REAL*8 XGENE(NSTN,LRN)
  72.       ENDSEGMENT
  73.  
  74.       SEGMENT MWRK3
  75.         REAL*8 WORK(LW)
  76.       ENDSEGMENT
  77.  
  78.       SEGMENT MWRK6
  79.         REAL*8 YDDL(NYD2)
  80.       ENDSEGMENT
  81.  
  82.       CHARACTER*8 CMATE
  83.       logical dcmat2
  84.  
  85.       MWRK1 = 0
  86.       MWRK2 = 0
  87.       MWRK3 = 0
  88.       MWRK4 = 0
  89.       MWRK5 = 0
  90.       MWRK6 = 0
  91.       KERRE = 0
  92.  
  93. C   INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  94. C   DE LA SECTION EN DEFO PLANE GENERALISEE
  95. C
  96. C <- Ici test equivalent a IF (IIPDPG.GT.0) THEN
  97.       IF (IFOUR.EQ.-3)THEN
  98.         IREF=(IIPDPG-1)*(IDIM+1)
  99.         XDPGE=XCOOR(IREF+1)
  100.         YDPGE=XCOOR(IREF+2)
  101.       ELSE
  102.         XDPGE=0.D0
  103.         YDPGE=0.D0
  104.       ENDIF
  105. C
  106.       MELEME=IPMAIL
  107.       NBNN=NUM(/1)
  108.       NBELEM=NUM(/2)
  109. C
  110. C      NHRM=NIFOUR
  111.       MINTE=IPMINT
  112.       NBBB=NBNN
  113.  
  114.       dcmat2 = .false.
  115.  
  116. C Sauf cas particulier(s), pour dimensionner MWRK1, on a :
  117.       NSTR = NSTRS
  118.  
  119. C Petite verification prealable (normalement inutile)
  120.       mptval = IVAEPS
  121.       if (NSTRS.ne.ival(/1)) then
  122.         write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  123.         call erreur(5)
  124.         return
  125.       endif
  126.       do icomp = 1, NSTRS
  127.         melval = IVAL(ICOMP)
  128.         if (melval.le.0) then
  129.           write(ioimp,*) 'EPSI3 : incoherence IVAEPS ival(',icomp,')=0'
  130.           call erreur(5)
  131.           return
  132.         endif
  133.         if (NBPTEL.NE.melval.velche(/1)) then
  134.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  135.           call erreur(5)
  136.           return
  137.         endif
  138.         if (NBELEM .NE. melval.velche(/2)) then
  139.           write(ioimp,*) 'EPSI3 : incoherence NSTRS & IVAEPS'
  140.           call erreur(5)
  141.           return
  142.         endif
  143.       enddo
  144.  
  145. C_______________________________________________________________________
  146. C
  147. C     NUMERO DES ETIQUETTES      :
  148. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  149. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  150. C     5  CONTINUE
  151. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  152. C     44 CONTINUE
  153. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  154. C_______________________________________________________________________
  155. C
  156.       IF (MELE.LE.100)
  157.      &GOTO (99,2,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  158.      1      99,99,99,99,99,99,99,99,2,30,99,99,99,99,99,99,99,99,99,99,
  159.      2      99,99,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99,
  160.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  161.      4      99,99,99,99,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99
  162.      5      ),MELE
  163.       IF (MELE.LE.200)
  164.      &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  165.      1      99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  166.      2      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  167.      3      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  168.      4      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  169.      5      34),MELE-100
  170.       IF (MELE.LE.300)
  171.      &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  172.      1      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  173.      2      34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  174.      3      34,34,34,34,265,266,266,266,99,99,271,272),MELE-200
  175.  
  176.  34   CONTINUE
  177.  99   CONTINUE
  178.       MOTERR(1:4)=NOMTP(MELE)
  179.       MOTERR(9:12)='EPSI'
  180.       CALL ERREUR(86)
  181.       GOTO 510
  182. C____________________________________________________________________
  183. C
  184. C     ELEMENT SEG2 (pour IMPEDANCE)
  185. C____________________________________________________________________
  186. C
  187.   2   CONTINUE
  188.  
  189. C detecte une impedance hybridant des ddl
  190.       MPTVAL=IVADEP
  191.       if (ival(/1).eq.ndep*2) dcmat2 = .true.
  192.       NYD2 = NBNN*NDEP
  193.       SEGINI,MWRK6
  194.  
  195. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  196.  
  197.       DO  310 IB=1,NBELEM
  198. C
  199. C     ON CHERCHE LES DEPLACEMENTS
  200. C
  201.       MPTVAL=IVADEP
  202.       IE=1
  203.       DO     IGAU=1,NBNN
  204.        ico1 = 1
  205.        ico2 = ndep
  206.        if (dcmat2) then
  207.         if (igau.eq.2) then
  208.          ico1 = ndep + 1
  209.          ico2 = ndep*2
  210.         endif
  211.        endif
  212.       DO     ICOMP=ico1,ico2
  213.         MELVAL=IVAL(ICOMP)
  214.         IGMN=MIN(IGAU,VELCHE(/1))
  215.         IBMN=MIN(IB  ,VELCHE(/2))
  216.         YDDL(IE)=VELCHE(IGMN,IBMN)
  217.         IE=IE+1
  218.       enddo
  219.       enddo
  220.  
  221. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  222. C
  223.       MPTVAL=IVAEPS
  224.       IE=1
  225.       DO IGAU=1,NBPTEL
  226.         DO ICOMP=1,NSTRS
  227.           MELVAL=IVAL(ICOMP)
  228.           if (igau.lt.2) then
  229.             VELCHE(IGAU,IB)= YDDL(IE) - YDDL(IE+NDEP)
  230.           else
  231.             VELCHE(IGAU,IB)= YDDL(IE) - YDDL(IE-NDEP)
  232.           endif
  233.           IE=IE+1
  234.         enddo
  235.       enddo
  236.  
  237.  310  CONTINUE
  238.       GOTO 510
  239.  
  240. C____________________________________________________________________
  241. C
  242. C     ELEMENT LINESPRING   LISP ET LISM
  243. C____________________________________________________________________
  244. C
  245.   30  CONTINUE
  246. C On ne considere que les 2 premiers composantes pour ces elements
  247.       NSTR = 2
  248.       SEGINI,MWRK1,MWRK3
  249. C
  250. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  251. C
  252.       DO 3030 IB=1,NBELEM
  253. C
  254. C     ON CHERCHE LES DEPLACEMENTS
  255. C
  256.       MPTVAL=IVADEP
  257.       IE=1
  258.       DO      IGAU=1,NBNN
  259.       DO      ICOMP=1,NDEP
  260.         MELVAL=IVAL(ICOMP)
  261.         IGMN=MIN(IGAU,VELCHE(/1))
  262.         IBMN=MIN(IB  ,VELCHE(/2))
  263.         XDDL(IE)=VELCHE(IGMN,IBMN)
  264.         IE=IE+1
  265.       enddo
  266.       enddo
  267. C
  268. C     ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE
  269. C
  270.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  271. C
  272. C     ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS
  273. C
  274.       MPTVAL=IVACAR
  275.       IE=1
  276.       DO      IC=1,3,2
  277.       DO      ICOMP=1,NCARR
  278.         MELVAL=IVAL(ICOMP)
  279.         IF (MELVAL.NE.0) THEN
  280.           IGMN=MIN(IC,VELCHE(/1))
  281.           IBMN=MIN(IB,VELCHE(/2))
  282.           WORK(IE)=VELCHE(IGMN,IBMN)
  283.         ELSE
  284.           WORK(IE)=0.D0
  285.         ENDIF
  286.         IE=IE+1
  287.       enddo
  288.       enddo
  289. C
  290. C     CALCUL DES DEFORMATIONS
  291. C
  292.       CALL LISPEP(XE,WORK,XDDL,WORK(11),WORK(20),
  293.      1                   WORK(29),NBPGAU,WORK(53))
  294. C
  295.       MPTVAL=IVAEPS
  296.       IE=1
  297.       DO      IGAU=1,NBPTEL
  298.       DO      ICOMP=1,NSTRS
  299.         MELVAL=IVAL(ICOMP)
  300.         VELCHE(IGAU,IB)=WORK(52+IE)
  301.         IE=IE+1
  302.       enddo
  303.       enddo
  304.  3030 CONTINUE
  305.       GOTO 510
  306. C_______________________________________________________________________
  307. C
  308. C     TUYAU FISSURE
  309. C_______________________________________________________________________
  310. C
  311.   43  CONTINUE
  312.       SEGINI,MWRK1,MWRK3
  313. C
  314. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  315. C
  316.       DO  3043 IB=1,NBELEM
  317. C
  318. C     ON CHERCHE LES DEPLACEMENTS
  319. C
  320.          MPTVAL=IVADEP
  321.          IE=1
  322.          DO      IGAU=1,NBNN
  323.          DO      ICOMP=1,NDEP
  324.             MELVAL=IVAL(ICOMP)
  325.             IGMN=MIN(IGAU,VELCHE(/1))
  326.             IBMN=MIN(IB  ,VELCHE(/2))
  327.             XDDL(IE)=VELCHE(IGMN,IBMN)
  328.             IE=IE+1
  329.          enddo
  330.          enddo
  331. C
  332. C     ON CHERCHE LES CARACTERISTIQUES
  333. C
  334.          MPTVAL=IVACAR
  335.          DO 7043 IC=1,9
  336.             MELVAL=IVAL(IC)
  337.             IF (MELVAL.NE.0) THEN
  338.                IBMN=MIN(IB,VELCHE(/2))
  339.                WORK(IC)=VELCHE(1,IBMN)
  340.             ELSE
  341.                WORK(IC)=0.D0
  342.             ENDIF
  343.  7043    CONTINUE
  344. C
  345. C     ON CALCULE LES DEFORMATIONS
  346. C
  347.          CALL TUFEPS(XDDL,WORK,WORK(31),KERRE)
  348.          IF(KERRE.NE.0) THEN
  349.            INTERR(1)=IB
  350.            IF(KERRE.EQ.1) CALL ERREUR(137)
  351.            IF(KERRE.EQ.2) CALL ERREUR(123)
  352.            IF(KERRE.EQ.3) CALL ERREUR(266)
  353.             GOTO 5043
  354.          ENDIF
  355. C
  356. C     ON REMPLIT LES DEFORMATIONS
  357. C
  358.          MPTVAL=IVAEPS
  359.          DO 6043 ICOMP=1,NSTRS
  360.             MELVAL=IVAL(ICOMP)
  361.             VELCHE(1,IB)=WORK(30+ICOMP)
  362.  6043    CONTINUE
  363. C
  364.  3043 CONTINUE
  365.  5043 CONTINUE
  366.       GOTO 510
  367. C_______________________________________________________________________
  368. C
  369. C     ELEMENT POI1 / materiau IMPEDANCE
  370. C_______________________________________________________________________
  371. C
  372.   45  CONTINUE
  373.       IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR.
  374.      & (CMATE.eq.'IMPREUSS').OR.(CMATE.eq.'IMPCOMPL').OR.
  375.      & (MFR.EQ.26.OR.MFR.EQ.28)) THEN
  376.        mptva1 = ivadep
  377.        mptval = ivaeps
  378.        numstr = ival(/1)
  379.        do iv = 1,ival(/1)
  380.         melva1 = mptva1.ival(iv)
  381.         melval = ival(iv)
  382.  
  383.  
  384. Ctc les lignes ci dessous sont pour le compilateur
  385.          if( .not. dcmat2 ) then
  386.            melva2=melva1
  387.            inmbid=0
  388.            ICC2=1
  389.          else
  390.            inmbid=numstr
  391.            icc2=2
  392.          endif
  393. C
  394. C     ON CHERCHE LES DEPLACEMENTS
  395. C
  396.          DO IB=1,NBELEM
  397.             IGAU = 1
  398.             IGMN= 1
  399.             IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  400.             valalf = MELVA1.VELCHE(IGMN,IBMN)
  401.             VELCHE(IGMN,IBMN) = valalf
  402.          ENDDO
  403.  
  404.        enddo
  405.        GOTO 510
  406.       ENDIF
  407.  
  408.       IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  409.         GO TO 99
  410.       ENDIF
  411. C
  412.       SEGINI,MWRK1,MWRK3
  413. C
  414. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  415. C
  416.       DO  3045 IB=1,NBELEM
  417. C
  418. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  419. C
  420.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  421. C
  422. C  ON CALCULE LES DEFORMATIONS
  423. C
  424.          CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK)
  425. C
  426. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  427. C
  428.          MPTVAL=IVAEPS
  429.          IE=1
  430.          DO      IGAU=1,NBPTEL
  431.             DO      ICOMP=1,NSTRS
  432.                MELVAL=IVAL(ICOMP)
  433.                VELCHE(IGAU,IB)=WORK(IE)
  434.                IE=IE+1
  435.             enddo
  436.          enddo
  437.  3045 CONTINUE
  438.  
  439.       GOTO 510
  440. C_______________________________________________________________________
  441. C
  442. C     BARRE ET CERCE
  443. C_______________________________________________________________________
  444. C
  445.   46  CONTINUE
  446. C
  447.       IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  448.         GO TO 99
  449.       ENDIF
  450. C
  451.       SEGINI,MWRK1,MWRK3
  452. C
  453. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  454. C
  455.       DO  3046 IB=1,NBELEM
  456. C
  457. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  458. C
  459.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  460. C
  461. C     ON CHERCHE LES DEPLACEMENTS
  462. C
  463.          MPTVAL=IVADEP
  464.          NDDD=NDEP
  465.          IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3
  466.          IE=1
  467.          DO      IGAU=1,NBNN
  468.             DO      ICOMP=1,NDDD
  469.                MELVAL=IVAL(ICOMP)
  470.                IGMN=MIN(IGAU,VELCHE(/1))
  471.                IBMN=MIN(IB  ,VELCHE(/2))
  472.                XDDL(IE)=VELCHE(IGMN,IBMN)
  473.                IE=IE+1
  474.             enddo
  475.          enddo
  476. C
  477. C  ON CALCULE LES DEFORMATIONS
  478. C
  479.          IF(MELE.EQ.46)  CALL BAREPS(XE,XDDL,WORK,IREPS2)
  480.          IF(MELE.EQ.95)  CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE)
  481.          IF(MELE.EQ.123) CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,
  482.      &     NBPGAU,IB)
  483.          IF(KERRE.EQ.1) THEN
  484.            CALL ERREUR(601)
  485.            GO TO 3046
  486.          ENDIF
  487. C
  488. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  489. C
  490.          MPTVAL=IVAEPS
  491.          IE=1
  492.          DO      IGAU=1,NBPTEL
  493.             DO      ICOMP=1,NSTRS
  494.                MELVAL=IVAL(ICOMP)
  495.                VELCHE(IGAU,IB)=WORK(IE)
  496.                IE=IE+1
  497.             enddo
  498.          enddo
  499. C
  500.  3046 CONTINUE
  501.       GOTO 510
  502. C_______________________________________________________________________
  503. C
  504. C    element coaxial COS2 (3D pour liaison acier-beton)
  505. C
  506. C_______________________________________________________________________
  507.   271 continue
  508.       lW=20
  509.       SEGINI,MWRK1,MWRK3,MWRK4
  510.        DO  2711 IB=1,NBELEM
  511. C
  512. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  513. C
  514.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  515. C
  516. C     ON CHERCHE LES DEPLACEMENTS
  517. C
  518.          MPTVAL=IVADEP
  519.          NDDD=NDEP
  520.          IE=1
  521.          DO      IGAU=1,NBNN
  522.             DO      ICOMP=1,NDDD
  523.                MELVAL=IVAL(ICOMP)
  524.                IGMN=MIN(IGAU,VELCHE(/1))
  525.                IBMN=MIN(IB  ,VELCHE(/2))
  526.                XDDL(IE)=VELCHE(IGMN,IBMN)
  527.                IE=IE+1
  528.             enddo
  529.          enddo
  530.          CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  531.          ii = 0
  532.          do ia=1,4
  533.           xa=0.d0
  534.           xb=0.d0
  535.           xc=0.d0
  536.           do iu=1,idim
  537.            ii = ii + 1
  538.            xa =xa+ xddl(ia*idim - idim +iu)* bpss( 1,iu)
  539.            xb= xb+ xddl(ia*idim - idim +iu)* bpss( 2,iu)
  540.            if(idim.eq.3) xc=xc+xddl(ia*idim - idim +iu)* bpss( 3,iu)
  541.           enddo
  542.            xddl(ia*idim - idim +1)=xa
  543.            xddl(ia*idim - idim +2)=xb
  544.            if(idim.eq.3) xddl(ia*idim - idim +3)=xc
  545.          enddo
  546.          g11 = xddl(1) - xddl(3*idim +1)
  547.          g21 =  xddl(idim+1 ) - xddl( 2*idim + 1 )
  548.          ag = (1.d0-0.5773502691896257645d0) * 0.5d0
  549.          g1 = g11 + (g21 - g11)*ag
  550.          g2 = g21 + (g11 - g21)*ag
  551.          g12 = xddl(3*idim + 2) - xddl(2)
  552.          g22 = xddl(2*idim + 2) - xddl(idim+2 )
  553.          g3 =g12 + (g22 - g12)*ag
  554.          g4 =g22 + (g12 - g22)*ag
  555.  
  556.          if (idim.eq.3) then
  557.           g13 =xddl(3) - xddl(3*idim +3)
  558.           g23 =xddl(idim+3 ) - xddl( 2*idim + 3 )
  559.           g5 = g13 + (g23 - g13)*ag
  560.           g6 = g23 + (g13 - g23)*ag
  561.          endif
  562.  
  563.          mptval= ivaeps
  564.          melval=ival(1)
  565.          VELCHE(1,IB)= g1
  566.          VELCHE(2,IB)= g2
  567. C
  568.          melval=ival(2)
  569.          VELCHE(1,IB)= g3
  570.          VELCHE(2,IB)= g4
  571. C
  572.          if (idim.eq.3) then
  573.            melval=ival(3)
  574.            VELCHE(1,IB) = g5
  575.            velche(2,IB) = g6
  576.          endif
  577. C
  578.  2711    continue
  579.  
  580.          GOTO 510
  581.  
  582. C_______________________________________________________________________
  583. C
  584. C     ELEMENT COAXIAL (COA2)
  585. C_______________________________________________________________________
  586. C
  587.   272 continue
  588.       NBNO=NBNN
  589.       SEGINI,MWRK1,MWRK2,MWRK4
  590. C
  591.       DO 2721 IB=1,NBELEM
  592. C
  593. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  594. C
  595.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  596. C
  597.       CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  598. C
  599. C     ON CHERCHE LES DEPLACEMENTS
  600. C
  601.          MPTVAL=IVADEP
  602.          IE=1
  603.          DO      IGAU=1,NBNN
  604.             DO      ICOMP=1,NDEP
  605.                MELVAL=IVAL(ICOMP)
  606.                IGMN=MIN(IGAU,VELCHE(/1))
  607.                IBMN=MIN(IB  ,VELCHE(/2))
  608.                XDDL(IE)=VELCHE(IGMN,IBMN)
  609.                IE=IE+1
  610.          enddo
  611.          enddo
  612. C
  613. C     BOUCLE SUR LES POINTS DE GAUSS
  614. C
  615.          DO 2723 IGAU=1,NBPGAU
  616. C
  617. C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  618. C
  619.       CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  620.      .               BGENE,DJAC,IRRT,IDIM,NBNN,NSTRS,LRE)
  621.       IF(IRRT.NE.0) THEN
  622.              INTERR(1)=IB
  623.              CALL ERREUR(764)
  624.              GOTO 9985
  625.       ENDIF
  626.       DO i=1,NSTRS
  627.           cc=0.D0
  628.           DO j=1,LRE
  629.             cc= cc + (XDDL(j) * BGENE(i,j))
  630. C            write(6,*) 'xddl b',ib,igau,i,j,xddl(j),bgene(i,j)
  631.           ENDDO
  632.           XSTRS(i) = cc
  633. C          write(6,*) 'gliss',ib,igau,i,xstrs(i)
  634.       ENDDO
  635. C
  636. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  637. C
  638.             MPTVAL=IVAEPS
  639.             DO 2724 ICOMP=1,NSTRS
  640.                MELVAL=IVAL(ICOMP)
  641.                VELCHE(IG,IB)=XSTRS(ICOMP)
  642.  2724       CONTINUE
  643.  2723 CONTINUE
  644.  2721 CONTINUE
  645. C
  646.  9985 CONTINUE
  647.       GOTO 510
  648. C____________________________________________________________________
  649. C
  650. C     ELEMENT BARRE 3D EXCENTRE (BAEX)
  651. C____________________________________________________________________
  652. C
  653.  124  CONTINUE
  654.       NBBB=NBNN
  655.       NSTN=NBNN
  656.       LRN =LRE
  657.       NYD2=2
  658.       SEGINI,MWRK1,MWRK3,MWRK5,MWRK6
  659. C
  660. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  661. C
  662.       DO  3108 IB=1,NBELEM
  663. C
  664. C  ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  665. C  ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  666. C  SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  667. C
  668.       MPTVAL=IVACAR
  669.       DO IC=1,NCARR
  670.         MELVAL=IVAL(IC)
  671.         IF(MELVAL.NE.0) THEN
  672.           IBMN=MIN(IB,VELCHE(/2))
  673.           WORK(IC)=VELCHE(1,IBMN)
  674.         ELSE
  675.           WORK(IC)=0.D0
  676.         ENDIF
  677.       END DO
  678. C      SECT=WORK(1)
  679. C   XGENE  STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  680. C
  681.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  682.       CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  683.       IF (KERRE.NE.0) THEN
  684.         INTERR(1)=ISOUS
  685.         INTERR(2)=IB
  686.         CALL ERREUR(128)
  687.         GOTO 510
  688.       ENDIF
  689. C
  690. C     ON CHERCHE LES DEPLACEMENTS
  691. C
  692.       IE=1
  693.       MPTVAL=IVADEP
  694.       DO      IGAU=1,NBNN
  695.       DO      ICOMP=1,NDEP
  696.         MELVAL=IVAL(ICOMP)
  697.         IGMN=MIN(IGAU,VELCHE(/1))
  698.         IBMN=MIN(IB  ,VELCHE(/2))
  699.         XDDL(IE)=VELCHE(IGMN,IBMN)
  700.         IE=IE+1
  701.       enddo
  702.       enddo
  703. C
  704. C     ON CALCULE LES DEFORMATIONS
  705. C
  706.       CALL BAEPEX(XDDL,XGENE,AL,YDDL,LRE)
  707. C
  708. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATION
  709. C
  710.       MPTVAL=IVAEPS
  711.       IE=1
  712.       DO      IGAU=1,NBPTEL
  713.       DO      ICOMP=1,NSTRS
  714.         MELVAL=IVAL(ICOMP)
  715.         VELCHE(IGAU,IB)=YDDL(IE)
  716.         IE=IE+1
  717.       enddo
  718.       enddo
  719. C
  720.  3108 CONTINUE
  721.       GOTO 510
  722. C_______________________________________________________________________
  723. C
  724. C     LIA2 : element de liaison a 2 noeuds (6 ddl par
  725. C noeuds)
  726. C_______________________________________________________________________
  727. C
  728.  125  CONTINUE
  729.       NBBB=NBNN
  730.       NSTN=3
  731.       LRN =3
  732.       SEGINI,MWRK1,MWRK3,MWRK5
  733. C
  734. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  735. C
  736.       DO  3109 IB=1,NBELEM
  737. C
  738. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  739. C
  740.       MPTVAL=IVACAR
  741.       DO IC=1,NCARR
  742.         MELVAL=IVAL(IC)
  743.         IF(MELVAL.NE.0) THEN
  744.           IBMN=MIN(IB,VELCHE(/2))
  745.           WORK(IC)=VELCHE(1,IBMN)
  746.         ELSE
  747.           WORK(IC)=0.D0
  748.         ENDIF
  749.       END DO
  750. C
  751.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  752.       CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  753.       IF (KERRE.NE.0) THEN
  754.         INTERR(1)=ISOUS
  755.         INTERR(2)=IB
  756.         CALL ERREUR(128)
  757.         GOTO 510
  758.       ENDIF
  759. C
  760. C     ON CHERCHE LES DEPLACEMENTS
  761. C
  762.       MPTVAL=IVADEP
  763.       IE=1
  764.       DO      IGAU=1,NBNN
  765.       DO      ICOMP=1,NDEP
  766.         MELVAL=IVAL(ICOMP)
  767.         IGMN=MIN(IGAU,VELCHE(/1))
  768.         IBMN=MIN(IB  ,VELCHE(/2))
  769.         XDDL(IE)=VELCHE(IGMN,IBMN)
  770.         IE=IE+1
  771.       enddo
  772.       enddo
  773. C
  774.       CALL ZERO(XSTRS,NSTRS,1)
  775. C
  776. C  ON CALCULE LES DEFORMATIONS    !!! a completer
  777. C   pour le moment on ne met rien dans les deformations
  778. C
  779. CCC     CALL DEFLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS)
  780. C
  781. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  782. C
  783.       MPTVAL=IVAEPS
  784.       IE=1
  785.       DO      IGAU=1,NBPTEL
  786.       DO      ICOMP=1,NSTRS
  787.         MELVAL=IVAL(ICOMP)
  788.         VELCHE(IGAU,IB)=XSTRS(IE)
  789.         IE=IE+1
  790.       enddo
  791.       enddo
  792. C
  793.  3109 CONTINUE
  794.       GOTO 510
  795. C_______________________________________________________________________
  796. C
  797. C     JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  798. C_______________________________________________________________________
  799. C
  800.  265  CONTINUE
  801.       NBBB=NBNN
  802.       NSTN=3
  803.       LRN =3
  804.       SEGINI,MWRK1,MWRK3,MWRK4
  805. C
  806. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  807. C
  808.       DO  3110 IB=1,NBELEM
  809. C
  810. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  811. C
  812.       MPTVAL=IVAMAT
  813.       DO IC=1,NMATT
  814.         MELVAL=IVAL(IC)
  815.         IF(MELVAL.NE.0) THEN
  816.           IBMN=MIN(IB,VELCHE(/2))
  817.           WORK(IC)=VELCHE(1,IBMN)
  818.         ELSE
  819.           WORK(IC)=0.D0
  820.         ENDIF
  821.       END DO
  822. C
  823.       CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  824. C
  825. C     ON CHERCHE LES DEPLACEMENTS
  826. C
  827.       MPTVAL=IVADEP
  828.       IE=1
  829.       DO      IGAU=1,NBNN
  830.       DO      ICOMP=1,NDEP
  831.         MELVAL=IVAL(ICOMP)
  832.         IGMN=MIN(IGAU,VELCHE(/1))
  833.         IBMN=MIN(IB  ,VELCHE(/2))
  834.         XDDL(IE)=VELCHE(IGMN,IBMN)
  835.         IE=IE+1
  836.       enddo
  837.       enddo
  838. C
  839. C  CALCUL DES DEPLACEMENTS LOCAUX
  840. C
  841.       IAW1 = 101
  842.       IAW2 = IAW1 + LRE
  843.       CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  844. C
  845.       CALL ZERO(XSTRS,NSTRS,1)
  846. C
  847. C  ON CALCULE LES DEFORMATIONS
  848. C
  849.       CALL DEFJOI(XDDL,LRE,XSTRS,NDEP)
  850. C
  851. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  852. C
  853.       MPTVAL=IVAEPS
  854.       IE=1
  855.       DO      IGAU=1,NBPTEL
  856.       DO      ICOMP=1,NSTRS
  857.         MELVAL=IVAL(ICOMP)
  858.         VELCHE(IGAU,IB)=XSTRS(IE)
  859.         IE=IE+1
  860.       enddo
  861.       enddo
  862. C
  863.  3110 CONTINUE
  864.       GOTO 510
  865. C_______________________________________________________________________
  866. C
  867. C     ELEMENT TUYO
  868. C_______________________________________________________________________
  869. C
  870.   96  CONTINUE
  871.       SEGINI,MWRK1,MWRK3
  872. C
  873. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  874. C
  875.       DO  3096 IB=1,NBELEM
  876. C
  877. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  878. C
  879.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  880. C
  881. C     ON CHERCHE LES DEPLACEMENTS
  882. C
  883.          MPTVAL=IVADEP
  884.          IE=1
  885.          DO      IGAU=1,NBNN
  886.             DO      ICOMP=1,NDEP
  887.                MELVAL=IVAL(ICOMP)
  888.                IGMN=MIN(IGAU,VELCHE(/1))
  889.                IBMN=MIN(IB  ,VELCHE(/2))
  890.                XDDL(IE)=VELCHE(IGMN,IBMN)
  891.                IE=IE+1
  892.             enddo
  893.          enddo
  894. C
  895. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  896. C
  897.          MPTVAL=IVACAR
  898.          DO 6096 IC=1,NCARR
  899.             MELVAL=IVAL(IC)
  900.             IF(MELVAL.NE.0) THEN
  901.                IBMN=MIN(IB,VELCHE(/2))
  902.                WORK(IC)=VELCHE(1,IBMN)
  903.              ELSE
  904.                WORK(IC)=0.D0
  905.              ENDIF
  906.  6096    CONTINUE
  907. C
  908. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  909. C                   EQUIVALENTE
  910.          IF(MELE.EQ.42) THEN
  911.            CISA=WORK(4)
  912.            VX=WORK(5)
  913.            VY=WORK(6)
  914.            VZ=WORK(7)
  915.            CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  916.          ENDIF
  917. C
  918. C  ON CALCULE LES DEFORMATIONS
  919. C
  920.          youbid=0.d0
  921.          xnubid=1.
  922.          CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2,youbid,
  923.      $               xnubid)
  924. C
  925. C  REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  926. C
  927.          IE=12
  928.          MPTVAL=IVAEPS
  929.          DO      IGAU=1,NBPTEL
  930.          DO      ICOMP=1,NSTRS
  931.             MELVAL=IVAL(ICOMP)
  932.             VELCHE(IGAU,IB)=WORK(IE)
  933.             IE=IE+1
  934.          enddo
  935.          enddo
  936. C
  937.  3096 CONTINUE
  938.       GOTO 510
  939. C_______________________________________________________________________
  940. C
  941. C     ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4
  942. C_______________________________________________________________________
  943. C
  944.   266 CONTINUE
  945.  
  946.       NBNO=NBNN
  947.       SEGINI,MWRK1,MWRK2,MWRK4
  948. C
  949.       DO 3266 IB=1,NBELEM
  950. C
  951. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  952. C
  953.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  954. C
  955. C
  956. C     ON CHERCHE LES DEPLACEMENTS
  957. C
  958.          MPTVAL=IVADEP
  959.          IE=1
  960.          DO      IGAU=1,NBNN
  961.             DO      ICOMP=1,NDEP
  962.                MELVAL=IVAL(ICOMP)
  963.                IGMN=MIN(IGAU,VELCHE(/1))
  964.                IBMN=MIN(IB  ,VELCHE(/2))
  965.                XDDL(IE)=VELCHE(IGMN,IBMN)
  966.                IE=IE+1
  967.             enddo
  968.          enddo
  969. C
  970. C     BOUCLE SUR LES POINTS DE GAUSS
  971. C
  972.          DO 4266 IGAU=1,NBPGAU
  973. C
  974.             CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
  975. C
  976.             CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
  977.      &            NSTRS,NBNO,LRE,MELE,SHPWRK,BGENE,DJAC,IRRT)
  978. C           IRRT.NE.0 JACOBIEN <= 0
  979.             IF(IRRT.NE.0) THEN
  980.               INTERR(1)=IB
  981.               CALL ERREUR(612)
  982.               GOTO 510
  983.             ENDIF
  984. C
  985.             CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  986. C
  987. C     REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  988. C
  989.             MPTVAL=IVAEPS
  990.             DO ICOMP=1,NSTRS
  991.                MELVAL=IVAL(ICOMP)
  992.                VELCHE(IGAU,IB)=XSTRS(ICOMP)
  993.             ENDDO
  994.  4266    CONTINUE
  995.  3266 CONTINUE
  996. C
  997.       GOTO 510
  998. C____________________________________________________________________
  999. C
  1000.   510 CONTINUE
  1001.       SEGSUP,MWRK1
  1002.       IF (MWRK2.NE.0) SEGSUP,MWRK2
  1003.       IF (MWRK3.NE.0) SEGSUP,MWRK3
  1004.       IF (MWRK4.NE.0) SEGSUP,MWRK4
  1005.       IF (MWRK5.NE.0) SEGSUP,MWRK5
  1006.       IF (MWRK6.NE.0) SEGSUP,MWRK6
  1007.  
  1008. C      RETURN
  1009.       END
  1010.  
  1011.  
  1012.  

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