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

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