Télécharger la plaquette Cast3M


fr en

Télécharger amor4.eso

Retour à la liste

Numérotation des lignes : 

amor4

  1. C AMOR4     SOURCE    CB215821  24/04/12    21:15:05     11897          
  2.       SUBROUTINE AMOR4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3.      &     IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT,
  4.      &     LHOOK,NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD)
  5. *---------------------------------------------------------------------*
  6. *         ________________________________________                    *
  7. *        |                                       |                    *
  8. *        |  CALCUL DE L AMORTISSEMENT STRUCTUREL |                    *
  9. *        |_______________________________________|                    *
  10. *                                                                     *
  11. * poutre,tuyau,barre
  12. *                                                                     *
  13. *                                                                     *
  14. *---------------------------------------------------------------------*
  15. *                                                                     *
  16. *                                                                     *
  17. *   ENTREES :                                                         *
  18. *   ________                                                          *
  19. *                                                                     *
  20. *        MATE     Numero du materiau                                  *
  21. *        MELE     Numero de l'element fini                            *
  22. *        IPMAIL   Pointeur sur un segment  MELEME                     *
  23. *        IPMINT   Pointeur sur un segment MINTE                       *
  24. *        NBPGAU   Nombre de point d'integration pour la rigidite      *
  25. *        LRE      Nombre de ddl dans la matrice de rigidite           *
  26. *        NSTRS    Nombre de composante de contraintes/deformations    *
  27. *        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  28. *                 pour une matrice de hooke                           *
  29. *        IVACAR   Pointeur sur un segment MPTVAL pour les caracteri-  *
  30. *                 stiques                                             *
  31. *        IVECT    FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL       *
  32. *        CMATE    Nom du materiau                                     *
  33. *        MFR      Numero de la formulation element fini               *
  34. *        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  35. *        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  36. *        NMATT    Nombre de composantes de materiau (IMAT=1)          *
  37. *        NCARR    Nombre de caracteristiques geometriques             *
  38. *        ISOUS    NUMERO DE LA SOUS-ZONE                              *
  39. *        LW       Dimension du tableau de travail                     *
  40. *        IPORE    nombre de fonctions de forme                        *
  41. *        ICAS     1 si amortissement                                  *
  42. *                 2 si rigidite antisymetrique                        *
  43. *                                                                     *
  44. *                                                                     *
  45. *   SORTIES :                                                         *
  46. *   ________                                                          *
  47. *                                                                      *
  48. *        IPMATR   pointeur sur la rigidite de la sous-zone            *
  49. *                                                                     *
  50. *                                                                     *
  51. *---------------------------------------------------------------------*
  52.       IMPLICIT INTEGER(I-N)
  53.       IMPLICIT REAL*8(A-H,O-Z)
  54. *
  55.  
  56. -INC PPARAM
  57. -INC CCOPTIO
  58. -INC CCHAMP
  59. -INC CCREEL
  60. *-
  61. -INC SMCHAML
  62. -INC SMINTE
  63. -INC SMELEME
  64. -INC SMRIGID
  65. -INC SMMODEL
  66. -INC SMCOORD
  67. -INC SMLREEL
  68. -INC SMLMOTS
  69. *
  70.       SEGMENT WRK1
  71.        REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS)
  72.        REAL*8 REL(LRE,LRE) , XE(3,NBBB)
  73.       ENDSEGMENT
  74. *
  75.       SEGMENT WRK2
  76.        REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
  77.       ENDSEGMENT
  78. *
  79.       SEGMENT WRK3
  80.        REAL*8 WORK(LW)
  81.       ENDSEGMENT
  82. *
  83.       SEGMENT WRK4
  84.        REAL*8 BPSS(3,3),XEL(3,NBBB)
  85.       ENDSEGMENT
  86. *
  87.       SEGMENT WRK5
  88.        REAL*8 XGENE(NSTN,LRN)
  89.       ENDSEGMENT
  90. *
  91.       SEGMENT WRK6
  92.        REAL*8 PSS(3,3)
  93.       ENDSEGMENT
  94. *
  95.       SEGMENT,MVELCH
  96.          REAL*8 VALMAT(NV1)
  97.       ENDSEGMENT
  98. *
  99.       SEGMENT MPTVAL
  100.         INTEGER IPOS(NS)    ,NSOF(NS)
  101.         INTEGER      IVAL(NCOSOU)
  102.         CHARACTER*16 TYVAL(NCOSOU)
  103.       ENDSEGMENT
  104. *
  105.       CHARACTER*4 lesinc(7),lesdua(7)
  106.       DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  107.       DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  108. *
  109.       DIMENSION CRIGI(12),CMASS(12)
  110.       CHARACTER*4 CMOT
  111.       CHARACTER*8 CMATE
  112. *
  113.       SEGACT,MCOORD
  114.       MELEME=IPMAIL
  115.       NBNN=NUM(/1)
  116.       NBELEM=NUM(/2)
  117. *
  118.       NV1=NMATT
  119.       SEGINI,MVELCH
  120. *
  121.       XMATRI=IPMATR
  122. *      LVAL  = (LRE*(LRE+1))/2
  123.        NLIGRP=LRE
  124.        NLIGRD=LRE
  125. *
  126. *     INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  127. *     DE LA SECTION EN DEFO PLANE GENERALISEE
  128. *
  129. * PPJ IF (IFOUR.EQ.-3)THEN
  130.       IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN
  131.         IP=IIPDPG
  132.         IREF=(IP-1)*(IDIM+1)
  133.         XDPGE=XCOOR(IREF+1)
  134.         YDPGE=XCOOR(IREF+2)
  135.       ELSE
  136.         XDPGE=0.D0
  137.         YDPGE=0.D0
  138.       ENDIF
  139. *
  140.       NHRM=NIFOUR
  141. *
  142.       MINTE=IPMINT
  143.       IRTD=1
  144. *
  145.       IF (mfr.eq.28) THEN
  146.       jgn = 4
  147.        if (ifour.eq.2) then
  148.       jgm = 6
  149.       segini mlmots
  150.       iinc = mlmots
  151.       do igm = 1,jgm
  152.        mots(igm) = lesinc(igm)
  153.       enddo
  154.       segini mlmots
  155.       idua = mlmots
  156.       do igm= 1,jgm
  157.        mots(igm) = lesdua(igm)
  158.       enddo
  159.        else if (ifour.lt.0) then
  160.       jgm = 4
  161.       segini mlmots
  162.       iinc = mlmots
  163.        mots(1) = lesinc(1)
  164.        mots(2) = lesinc(2)
  165.        mots(3) = lesinc(4)
  166.        mots(4) = lesinc(5)
  167.       segini mlmots
  168.       idua = mlmots
  169.        mots(1) = lesdua(1)
  170.        mots(2) = lesdua(2)
  171.        mots(3) = lesdua(4)
  172.        mots(4) = lesdua(5)
  173.        else if (ifour.eq.0) then
  174.       jgm = 3
  175.       segini mlmots
  176.       iinc = mlmots
  177.        mots(1) = lesinc(7)
  178.        mots(2) = lesinc(3)
  179.        mots(3) = lesinc(6)
  180.       segini mlmots
  181.       idua = mlmots
  182.        mots(1) = lesdua(7)
  183.        mots(2) = lesdua(3)
  184.        mots(3) = lesdua(6)
  185.        else if (ifour.eq.1) then
  186. * a faire
  187.        endif
  188.       ENDIF
  189.  
  190.       IMODEL = IMOD
  191.       jmat = 0
  192.         DO imat = 1 , matmod(/2)
  193.          if (matmod(imat).eq.'IMPEDANCE') then
  194.            jmat = imat
  195. *           goto 29
  196.          endif
  197.         ENDDO
  198. C
  199. C_______________________________________________________________________
  200. C
  201. C     NUMERO DES ETIQUETTES      :
  202. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  203. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  204. C     5  CONTINUE
  205. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  206. C     44 CONTINUE
  207. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  208. C_______________________________________________________________________
  209. C
  210.  
  211. *                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  212.             GOTO (  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  213. *                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  214.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  215. *                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
  216.      &           ,  99,  99,  99,  99,  99,  99,  29,  99,  99,  99,  99
  217. *                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  218.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  29,  99,  99
  219. *                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  220.      &           ,  45,  46,  99,  99,  99,  99,  99,  99,  99,  99,  99
  221. *                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  222.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  223. *                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  224.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  225. *                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  226.      &           ,  99,  99,  99,  99,  99,  99,  29,  99,  99,  99,  99
  227. *                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
  228.      &           ,  99,  99,  99,  99,  99,  99,  46,  99,  99,  99,  99
  229. *                 HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  230.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  231. *                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  232.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  233. *                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  234.      &           ,  99,  46, 124, 99,  99,  99,  99,  99,  99,  99,  99
  235. *                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  236.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  237. *                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  238.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  239. *                 TE56 PY91 TRH6
  240.      &           ,  99,  99,  99),MELE
  241. C
  242. C      GOTO(168,169,170,171,172),MELE-167
  243. C
  244.       GOTO 99
  245. C_______________________________________________________________________
  246. C
  247. C     IMPEDANCE
  248. C_______________________________________________________________________
  249. C
  250.   2   CONTINUE
  251.       IF (jmat.gt.0) THEN
  252.           MPTVAL=IVAMAT
  253.           MELVAL=IVAL(1)
  254.         if (ival(/1).gt.1) then
  255.           melva1 = ival(2)
  256.         else
  257.           melva1 = 0
  258.         endif
  259.           jddl = LRE/NBPGAU
  260.          DO IB = 1,NBELEM
  261.           JDIAG = 0
  262.           IBMN=MIN(IB,VELCHE(/2))
  263.          do IG = 1, NBPGAU
  264.            igmn = MIN(IG,VELCHE(/1))
  265.           XAMOR=VELCHE(IGMN,IBMN)
  266.           XINAM = XAMOR
  267.               if (melva1.gt.0) then
  268.                 igmn = MIN(IG,melva1.VELCHE(/1))
  269.                 XINAM = melva1.VELCHE(IGMN,IBMN)
  270.               endif
  271.              do idl = 1,jddl
  272.               JDIAG = JDIAG + 1
  273.               RE(JDIAG,JDIAG,ib) = XAMOR
  274.               if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM
  275.               if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM
  276.              enddo
  277.          enddo
  278.         ENDDO
  279.         GOTO 510
  280.       ENDIF
  281. C_______________________________________________________________________
  282. C
  283. C     ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO
  284. C_______________________________________________________________________
  285. C
  286.   29  CONTINUE
  287.  
  288.       NBBB=NBNN
  289.       SEGINI WRK1,WRK3
  290. C
  291. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  292. C
  293.       KERRE=0
  294.  
  295.       DO  3029 IB=1,NBELEM
  296. C
  297. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  298. C
  299.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  300. C
  301. C     CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
  302. C
  303.       IF (MELE.EQ.98) THEN
  304.          CALL ZERO(REL,LRE,LRE)
  305.          GOTO 8029
  306.       ENDIF
  307. C
  308. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  309. C     SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  310. C
  311.       NCARR1=NCARR
  312. ****  IF(IVECT.EQ.1) NCARR1=NCARR-3
  313.       CALL ZERO(WORK,NCARR1,1)
  314.       DO 4030 IGAU=1,NBNN
  315.       MPTVAL=IVACAR
  316.       DO 6029 IC=1,NCARR1
  317.         IF (IVAL(IC).NE.0) THEN
  318.           MELVAL=IVAL(IC)
  319.           IBMN=MIN(IB,VELCHE(/2))
  320.           IGMN=MIN(IGAU,VELCHE(/1))
  321.           WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  322.         ELSE
  323.           WORK(IC)=0.D0
  324.         ENDIF
  325.         IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  326.  6029 CONTINUE
  327.  4030    CONTINUE
  328. C
  329.       MPTVAL=IVAMAT
  330. C
  331. C AUTRES CAS ......
  332. C
  333.         MELVAL=IVAL(1)
  334. *
  335.         IF(CMATE.NE.'SECTION') THEN
  336.           IBMN=MIN(IB,VELCHE(/2))
  337.           VALMAT(1)=VELCHE(1,IBMN)
  338.           YOUNG=VALMAT(1)
  339. C
  340. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  341. C                   EQUIVALENTE
  342. **        write(6,*) 'amor4 mele icas ncarr',mele,icas,ncarr
  343.           IF(MELE.EQ.42) THEN
  344.             IF (ICAS.EQ.2) WORK(10)=WORK(9)
  345.             WORK(9)=WORK(8)
  346.             WORK(8)=WORK(7)
  347.             WORK(7)=WORK(6)
  348.             EPAIS=WORK(1)
  349.             REXT=WORK(2)
  350.             RINT=REXT-EPAIS
  351.             RACO=WORK(3)
  352.             PRES=WORK(4)
  353.             CISA=WORK(5)
  354.             XIN=XPI*(REXT**4-RINT**4)*0.25D00
  355.             WORK(1)=2.D00*XIN
  356.             WORK(2)=XIN
  357.             WORK(3)=XIN
  358.             WORK(4)=XPI*(REXT**2-RINT**2)
  359.             WORK(5)=WORK(4)*0.5D0*CISA
  360.             WORK(6)=WORK(5)
  361. C
  362. C
  363.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  364.               WORK(4)=VALMAT(1)
  365.               AUX=VALMAT(2)
  366.               WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  367.             ELSE
  368. C
  369.              IF (ICAS.EQ.2) THEN
  370.               WORK(11)=VALMAT(1)
  371.               WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  372.              ELSE
  373.               WORK(10)=VALMAT(1)
  374.               WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  375.              ENDIF
  376.             ENDIF
  377.           ENDIF
  378. C
  379. C
  380.             DO 9029 IM=1,NMATT
  381.               IF (IVAL(IM).NE.0) THEN
  382.                 MELVAL=IVAL(IM)
  383.                 IBMN=MIN(IB,VELCHE(/2))
  384.                 VALMAT(IM)=VELCHE(1,IBMN)
  385.               ELSE
  386.                 VALMAT(IM)=0.D0
  387.               ENDIF
  388. C
  389.  9029       CONTINUE
  390.             IF(MELE.EQ.84) THEN
  391. C
  392.              IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  393.               CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  394.              ELSE
  395.               CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  396.              ENDIF
  397.             ELSE
  398. C
  399.              IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  400.               CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  401.              ELSE
  402.               CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  403.              ENDIF
  404.            ENDIF
  405. C-------------
  406. C  PROVISOIRE
  407. C-------------
  408.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  409.               WORK(4)=VALMAT(1)
  410.               AUX=VALMAT(2)
  411.               WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  412.             ELSE
  413. C
  414.              IF (ICAS.EQ.2) THEN
  415.               WORK(11)=VALMAT(1)
  416.               WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  417.              ELSE
  418.               WORK(10)=VALMAT(1)
  419.               WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  420.              ENDIF
  421.             ENDIF
  422. C-------------
  423. C          ENDIF
  424. C-------------
  425. *
  426. *  CAS DE LA FORMULATION SECTION
  427. *
  428.         ELSE
  429. *
  430. *         ON REGARDE SI ON A LA COMPOSANTE MAHO
  431. *         SI OUI, ON LA PREND
  432. *
  433. C            IF(IVAL(3).NE.0) THEN
  434. C              MELVAL=IVAL(3)
  435. C              IBMN=MIN(IB,IELCHE(/2))
  436. C              MLREEL=IELCHE(1,IBMN)
  437. C              SEGACT MLREEL
  438. C              IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  439. C     $          CALL DOHOOO(PROG,LHOOK,DDHOOK)
  440. C              SEGDES MLREEL
  441. *
  442. C            ELSE
  443.               IBMN=MIN(IB,IELCHE(/2))
  444.               IPMODL=IELCHE(1,IBMN)
  445.               MELVAL=IVAL(2)
  446.               IBMN=MIN(IB,IELCHE(/2))
  447.               IPMAT=IELCHE(1,IBMN)
  448.               CALL FAMORE(IPMODL,IPMAT,CRIGI,CMASS)
  449.               IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  450.      $         CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  451. C            ENDIF
  452.           ENDIF
  453. C
  454. C
  455. C FIN TRAITEMENT DES DONNEES MATERIAUX
  456. C
  457.       IF(MELE.EQ.97) THEN
  458.          CALL ACORIG(REL,LRE,WORK,XE,KERRE)
  459.       ELSE IF(MELE.EQ.84) THEN
  460.         IF (ICAS.EQ.1) THEN
  461. C
  462. C Matrice d amortissement symetrique Timo
  463. C
  464. C
  465.          IF(CMATE.NE.'SECTION') THEN
  466. C
  467.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  468.              CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  469.            ELSE
  470.              CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  471.            ENDIF
  472. *
  473.          ELSE
  474.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  475.              CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
  476.      $                                      DDHOOK,KERRE)
  477.            ELSE
  478.              CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
  479.      $                                      DDHOOK,KERRE)
  480.            ENDIF
  481.          ENDIF
  482. C
  483.        ELSE
  484. C
  485. C Matrice de raideur antisymetrique Timo (seulement en 3D)
  486. C
  487.          IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  488.             KERRE = 1
  489.          ELSE
  490. C
  491.            IF(CMATE.NE.'SECTION') THEN
  492.              CALL TIMDH3(REL,WORK,XE,KERRE)
  493.            ELSE
  494. C             KERRE = 1
  495. C           ENDIF
  496. C
  497.              CALL TIFDH3(REL,WORK,XE,LHOOK,DDHOOK,KERRE)
  498.            ENDIF
  499.          ENDIF
  500.        ENDIF
  501.       ELSE
  502. C
  503.         IF (ICAS.EQ.1) THEN
  504. C
  505. C Matrice d amortissement symetrique Poutre
  506.  
  507.            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  508.              CALL POURI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  509.            ELSE
  510.              CALL POURIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  511.            ENDIF
  512.        ELSE
  513. C
  514. C Matrice de raideur antisymetrique Poutre (seulement en 3D)
  515. C
  516.          IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  517.            KERRE = 1
  518.          ELSE
  519.            CALL POUDH3(REL,WORK,XE,KERRE)
  520.          ENDIF
  521.        ENDIF
  522.       ENDIF
  523. C
  524.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  525.       IF(KERRE.NE.0) INTERR(2)=IB
  526. C
  527.  4029 CONTINUE
  528.  8029 CONTINUE
  529. *      SEGINI XMATRI
  530. *      IMATTT(IB)=XMATRI
  531. C
  532. C     REMPLISSAGE DE XMATRI
  533. C
  534.           DO      IIIA=1,LRE
  535.            DO      IIIB=1,LRE
  536.            RE(IIIA,IIIB,IB)=REL(IIIA,IIIB)
  537.            enddo    
  538.           enddo    
  539.  3029 CONTINUE
  540.       IF(KERRE.EQ.1) CALL ERREUR(128)
  541.       IF(KERRE.EQ.2) CALL ERREUR(138)
  542.       IF(IRTD.EQ.0) THEN
  543.         MOTERR(1:8)=CMATE
  544.         MOTERR(9:16)=NOMFR(MFR/2+1)
  545.        INTERR(1)=IFOUR
  546.        CALL ERREUR(81)
  547.       ENDIF
  548.       SEGSUP WRK1,WRK3,MVELCH
  549.       GOTO 510
  550.  
  551. C_______________________________________________________________________
  552. C
  553. C      ELEMENT POI1
  554. C_______________________________________________________________________
  555. C
  556.   45  CONTINUE
  557.       IF (jmat.gt.0) THEN
  558.           MPTVAL=IVAMAT
  559.           MELVAL=IVAL(1)
  560.         if (ival(/1).gt.1) then
  561.           melva1 = ival(2)
  562.         else
  563.           melva1 = 0
  564.         endif
  565.           jddl = LRE/NBPGAU
  566.          DO IB = 1,NBELEM
  567.           JDIAG = 0
  568.           if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2))
  569.          do IG = 1, NBPGAU
  570.            if (melval.gt.0) igmn = MIN(IG,VELCHE(/1))
  571.           XAMOR = 0.D0
  572.           if (melval.gt.0) XAMOR=VELCHE(IGMN,IBMN)
  573.           XINAM = XAMOR
  574.               if (melva1.gt.0) then
  575.                 igmn = MIN(IG,melva1.VELCHE(/1))
  576.                 XINAM = melva1.VELCHE(IGMN,IBMN)
  577.               endif
  578.              do idl = 1,jddl
  579.               JDIAG = JDIAG + 1
  580.               RE(JDIAG,JDIAG,ib) = XAMOR
  581.               if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM
  582.               if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM
  583.              enddo
  584. *             enddo
  585.          enddo
  586.         ENDDO
  587.         GOTO 510
  588.       ENDIF
  589.  
  590.       IF (MFR.EQ.26) THEN
  591. * MODAL
  592.         DO IB = 1,NBELEM
  593. *          SEGINI XMATRI
  594. *          IMATTT(IB)=XMATRI
  595.  
  596.           MPTVAL=IVAMAT
  597.           MELVAL=IVAL(1)
  598.           IBMN=MIN(IB,VELCHE(/2))
  599.           XFREQ=VELCHE(1,IBMN)
  600.           MELVAL=IVAL(2)
  601.           IBMN=MIN(IB,VELCHE(/2))
  602.           XMASS=VELCHE(1,IBMN)
  603.           MELVAL=IVAL(4)
  604.           if (melval.gt.0) then
  605.           IBMN=MIN(IB,VELCHE(/2))
  606.          XAMOR=VELCHE(1,IBMN)
  607.           else
  608.            xamor = 0.
  609.           endif
  610.           OMEG = 2. * XPI * XFREQ
  611.           RE(1,1,IB) = XMASS * OMEG * XAMOR
  612.         ENDDO
  613.         GOTO 510
  614. *
  615.       ELSE IF (MFR.EQ.28) THEN
  616. * STATIQUE
  617.         DO IB = 1,NBELEM
  618. *          SEGINI XMATRI
  619. *          IMATTT(IB)=XMATRI
  620.  
  621.           MPTVAL=IVAMAT
  622.           MELVAL=IVAL(4)
  623.           IBMN=MIN(IB,VELCHE(/2))
  624.           if (melval.gt.0) then
  625.            segact melval
  626.           XAMOR=VELCHE(1,IBMN)
  627.            else
  628.           re(1,1,IB) = 0.d0
  629.           endif
  630.         if (xamor.ne.0.d0) then
  631.           MELVAL=IVAL(1)
  632.           IBMN=MIN(IB,IELCHE(/2))
  633.           idepl=IELCHE(1,IBMN)
  634.           MELVAL=IVAL(2)
  635.           IBMN=MIN(IB,IELCHE(/2))
  636.           itreac=IELCHE(1,IBMN)
  637.          CALL XTY1(idepl,itreac,iinc,idua,XR1)
  638.           if (ierr.ne.0) then
  639.             return
  640.           endif
  641.           MELVAL=IVAL(3)
  642.           IBMN=MIN(IB,IELCHE(/2))
  643.           imade=IELCHE(1,IBMN)
  644.          CALL XTY1(idepl,imade,iinc,idua,XM1)
  645.           if (ierr.ne.0) then
  646.             return
  647.           endif
  648.            x1 = xm1 * xr1
  649.           re(1,1,IB) = SQRT(ABS(x1))*xamor
  650.           if (x1.lt.0.) re(1,1,IB) = re(1,1,IB) *(-1.d0)
  651.          endif
  652.         ENDDO
  653.         GOTO 510
  654.       ENDIF
  655. *
  656. C_______________________________________________________________________
  657. C
  658. C     ELEMENTS BARRE ET CERCE
  659. C_______________________________________________________________________
  660. C
  661.   46  CONTINUE
  662. *
  663.       IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  664.         GO TO 99
  665.       ENDIF
  666.       NBBB=NBNN
  667.       SEGINI WRK1,WRK3
  668.       IF(MELE.EQ.123) THEN
  669.         NSTN=NBNN
  670.         LRN =LRE
  671.         SEGINI WRK5
  672.       ENDIF
  673. C
  674. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  675. C
  676.       KERRE=0
  677.       DO 3046 IB=1,NBELEM
  678. C
  679. C  ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  680. C
  681.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  682. C
  683. C
  684. C  ON RECUPERE LA SECTION DE L'ELEMENT
  685. C
  686.       MPTVAL=IVACAR
  687.       MELVAL=IVAL(1)
  688.       IBMN=MIN(IB,VELCHE(/2))
  689.       SECT=VELCHE(1,IBMN)
  690. C
  691. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  692. C
  693.       MPTVAL=IVAMAT
  694. *
  695.         DO 9046 IM=1,NMATT
  696.           IF (IVAL(IM).NE.0) THEN
  697.             MELVAL=IVAL(IM)
  698.             IBMN=MIN(IB  ,VELCHE(/2))
  699.             VALMAT(IM)=VELCHE(1,IBMN)
  700.           ELSE
  701.             VALMAT(IM)=0.D0
  702.           ENDIF
  703.  9046   CONTINUE
  704.         CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  705. C
  706.       IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  707.       IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  708.       IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  709.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  710.       IF(KERRE.NE.0) INTERR(2)=IB
  711. C
  712. *      SEGINI XMATRI
  713. *      IMATTT(IB)=XMATRI
  714. C
  715. C     REMPLISSAGE DE XMATRI
  716. C
  717.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  718.  3046 CONTINUE
  719.       IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  720.       IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  721.       IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  722.       IF(IRTD.EQ.0) THEN
  723.         MOTERR(1:8)=CMATE
  724.         MOTERR(9:16)=NOMFR(MFR/2+1)
  725.        INTERR(1)=IFOUR
  726.        CALL ERREUR(81)
  727.       ENDIF
  728.       SEGSUP WRK1,WRK3,MVELCH
  729.       IF(MELE.EQ.123) SEGSUP WRK5
  730.       GOTO 510
  731. C
  732. C_______________________________________________________________________
  733. C
  734. C     ELEMENT BARRE 3D EXCENTRE (BAEX)
  735. C_______________________________________________________________________
  736. C
  737.  124  CONTINUE
  738.       NBBB=NBNN
  739.       NBNO=NBNN
  740.       NSTRS1=NSTRS
  741.       NSTRS=NBNN
  742.       SEGINI WRK1,WRK2,WRK3
  743. C
  744. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  745. C
  746.       KERRE=0
  747.       DO 3108 IB=1,NBELEM
  748. C
  749. C  ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  750. C  ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  751. C  SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  752. C
  753.       MPTVAL=IVACAR
  754.       DO IC=1,NCARR
  755.         IF(IVAL(IC).NE.0) THEN
  756.           MELVAL=IVAL(IC)
  757.           IBMN=MIN(IB,VELCHE(/2))
  758.           WORK(IC)=VELCHE(1,IBMN)
  759.         ELSE
  760.           WORK(IC)=0.D0
  761.         ENDIF
  762.       END DO
  763.       SECT=WORK(1)
  764. C
  765. C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  766. C
  767.       MPTVAL=IVAMAT
  768.  
  769.         DO 9108 IM=1,NMATT
  770.           IF (IVAL(IM).NE.0) THEN
  771.             MELVAL=IVAL(IM)
  772.             IBMN=MIN(IB  ,VELCHE(/2))
  773.             VALMAT(IM)=VELCHE(1,IBMN)
  774.           ELSE
  775.             VALMAT(IM)=0.D0
  776.           ENDIF
  777.  9108   CONTINUE
  778.         IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  779.      1  CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  780. C
  781. C   BGENE  STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  782. C
  783.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  784.       CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  785.       IF(KERRE.NE.0) INTERR(1)=ISOUS
  786.       IF(KERRE.NE.0) INTERR(2)=IB
  787.       IF(KERRE.EQ.1) CALL ERREUR(128)
  788.       CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  789. C
  790. *      SEGINI XMATRI
  791. *      IMATTT(IB)=XMATRI
  792. C
  793. C     REMPLISSAGE DE XMATRI
  794. C
  795.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  796.  3108 CONTINUE
  797.       NSTRS=NSTRS1
  798.       SEGSUP WRK1,WRK2,WRK3,MVELCH
  799.       GOTO 510
  800.  
  801. C
  802. *_______________________________________________________________________
  803. *
  804.    99 CONTINUE
  805.       MOTERR(1:4)=NOMTP(MELE)
  806.       MOTERR(9:12)='AMOR'
  807.       CALL ERREUR(86)
  808. *
  809.   510 CONTINUE
  810.       RETURN
  811.       END
  812.  
  813.  
  814.  
  815.  
  816.  
  817.  
  818.  
  819.  
  820.  
  821.  
  822.  
  823.  
  824.  
  825.  
  826.  
  827.  
  828.  
  829.  
  830.  
  831.  
  832.  
  833.  
  834.  
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  
  841.  
  842.  
  843.  
  844.  
  845.  
  846.  
  847.  
  848.  
  849.  
  850.  
  851.  

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