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

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