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

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