Télécharger la plaquette Cast3M


fr en

Télécharger kcent2.eso

Retour à la liste

Numérotation des lignes : 

kcent2

  1. C KCENT2    SOURCE    CB215821  24/04/12    21:16:29     11897          
  2.           SUBROUTINE KCENT2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,
  3.      &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE,
  4.      &LHOOK,IPMATR,VROT,IIPDPG)
  5. *---------------------------------------------------------------------*
  6. *        _________________________________________________            *
  7. *        |                                                |           *
  8. *        |  calcul de la matrice de raideur centrifuge    |           *
  9. *        |________________________________________________|           *
  10. *                                                                     *
  11. *      barr,poutre,timo,tuyau,dkt,coq4,coq8,coq2,dst,cerc             *
  12. *                                                                     *
  13. *---------------------------------------------------------------------*
  14. *                                                                     *
  15. *   entrees :                                                         *
  16. *   ________                                                          *
  17. *                                                                     *
  18. *        ipmail   pointeur sur un segment  meleme                     *
  19. *        lre      nombre de ddl dans la matrice de masse              *
  20. *        lw       dimension du tableau de travail de l'element        *
  21. *        mele     numero de l'element fini                            *
  22. *        ivamat   pointeur sur un segment mptval pour le materiau     *
  23. *        nmatt    nombre de composante de materiau (imat=1)           *
  24. *        ivacar   pointeur sur un segment mptval pour les caracteri-  *
  25. *                 stiques                                             *
  26. *        ncarr    nombre de caracteristiques geometriques             *
  27. *        ivect    flag indiquant si on a entree les axes locaux       *
  28. *        isous     numero de la sous-zone                             *
  29. *        nbpgau   nombre de point d'integration pour la masse         *
  30. *        ipmint   pointeur sur un segment minte                       *
  31. *        ipmin1   pointeur sur un segment minte (aux noeuds)          *
  32. *        nddl     nombre de degre de liberte /noeud                   *
  33. *        mate     numero du materiau                                  *
  34. *       cmate     nom du materiau                                     *
  35. *       iprota    vecteur vitesse de rotation                         *
  36. *                                                                     *
  37. *   sorties :                                                         *
  38. *   ________                                                          *
  39. *                                                                     *
  40. *        ipmatr   pointeur sur la matrice de raideur                  *
  41. *                 de la sous-zone                                     *
  42. *                                                                     *
  43. *                         Didier COMBESCURE mars 2003                 *
  44. *---------------------------------------------------------------------*
  45.       IMPLICIT INTEGER(I-N)
  46.       IMPLICIT REAL*8(A-H,O-Z)
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC CCHAMP
  51. -INC CCREEL
  52. *-
  53. -INC SMRIGID
  54. -INC SMCHAML
  55. -INC SMELEME
  56. -INC SMCOORD
  57. -INC SMINTE
  58. -INC SMMODEL
  59. C
  60.       SEGMENT WRK1
  61.       REAL*8 REL(LRE,LRE),XE(3,NBBB)
  62.       ENDSEGMENT
  63. C
  64.       SEGMENT WRK2
  65.       REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  66.       ENDSEGMENT
  67. C
  68.       SEGMENT WRK3
  69.       REAL*8 DDHOOK(LHOOK,LHOOK)
  70.       REAL*8 WORK(LW)
  71.       ENDSEGMENT
  72. C
  73.       SEGMENT WRK4
  74.       REAL*8 BPSS(3,3),XEL(3,NBBB)
  75.       ENDSEGMENT
  76. C
  77.       SEGMENT WRK6
  78.       REAL*8 RHOMAT(6,6)
  79.       ENDSEGMENT
  80. C
  81.       SEGMENT MVELCH
  82.       REAL*8 VALMAT(NV1)
  83.       ENDSEGMENT
  84. C
  85.       SEGMENT MPTVAL
  86.       INTEGER IPOS(NS),NSOF(NS)
  87.       INTEGER IVAL(NCOSOU)
  88.       CHARACTER*16 TYVAL(NCOSOU)
  89.       ENDSEGMENT
  90. *
  91. cbp,2020      DIMENSION CRIGI(12),CMASS(12),VROT(3),ROMEB(6,6),VROTL(3)
  92.       REAL*8 CRIGI(12),CMASS(12),VROT(3),VROTL(3)
  93.       CHARACTER*8 CMATE
  94. *
  95.       MELEME=IPMAIL
  96.       NBNN=NUM(/1)
  97.       NBELEM=NUM(/2)
  98. *
  99.       NV1=NMATT
  100.       SEGINI,MVELCH
  101. *
  102.       xMATRI=IPMATR
  103.       LVAL  = (LRE*(LRE+1))/2
  104.       NLIGRP=LRE
  105.       NLIGRD=LRE
  106. *
  107.       NHRM=NIFOUR
  108. *
  109.       MINTE=IPMINT
  110.       MINTE2=IPMIN2
  111. C
  112. cbp,2020: ci-dessous, pas utilise, pourtant bonne idee a priori
  113. c         car sorti de la boucle sur les elements 
  114. c       DO 10 IM=1,6
  115. c       DO 11 IN=1,6
  116. c          ROMEB(IN,IM) = 0.D0
  117. c    11 CONTINUE
  118. c    10 CONTINUE
  119. c C
  120. c       ROMEB(1,1) = (-1.)*((VROT(2)**2) + (VROT(3)**2))
  121. c       ROMEB(2,2) = (-1.)*((VROT(1)**2) + (VROT(3)**2))
  122. c       ROMEB(3,3) = (-1.)*((VROT(1)**2) + (VROT(2)**2))
  123. c       ROMEB(1,2) = VROT(1)*VROT(2)
  124. c       ROMEB(1,3) = VROT(1)*VROT(3)
  125. c       ROMEB(2,3) = VROT(2)*VROT(3)
  126. c       ROMEB(2,1) = ROMEB(1,2)
  127. c       ROMEB(3,1) = ROMEB(1,3)
  128. c       ROMEB(3,2) = ROMEB(2,3)
  129.  
  130. C_______________________________________________________________________
  131. C
  132. C     NUMERO DES ETIQUETTES      :
  133. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  134. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  135. C     5  CONTINUE
  136. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  137. C     44 CONTINUE
  138. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  139. C_______________________________________________________________________
  140. C
  141. *                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  142.             GOTO (  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  143. *                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  144.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  145. *                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
  146.      &           ,  99,  99,  99,  99,  93,  93,  21,  99,  99,  99,  99
  147. *                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  148.      &           ,  99,  99,  99,  99,  99,  99,  99,  41,  21,  99,  44
  149. *                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  150.      &           ,  99,  21,  99,  99,  51,  99,  99,  99,  99,  99,  99
  151. *                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  152.      &           ,  41,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  153. *                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  154.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  155. *                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  156.      &           ,  99,  99,  99,  99,  99,  99,  21,  99,  99,  99,  99
  157. *                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
  158.      &           ,  99,  99,  99,  99,  93,  99,  21,  99,  99,  99,  99
  159. *                 HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  160.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  161. *                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  162.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  163. *                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  164.      &           ,  99,  21,  99,  99,  99,  99,  99,  99,  99,  99,  99
  165. *                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  166.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  167. *                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  168.      &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  169. *                 TE56 PY91 TRH6
  170.      &           ,  99,  99,  99),MELE
  171. C      GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  172. C     1     27,99,99,99,99,99,27,99,27,99,99,99,99,99,99,99,99,99,99,99,
  173. C     2     99,27,99,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  174. C     3     99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  175. C     4     99,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  176.       GOTO 99
  177. C_______________________________________________________________________
  178. C_______________________________________________________________________
  179. C
  180. C     ELEMENTS POUTRES et BARRES
  181. C_______________________________________________________________________
  182. C
  183.   21  CONTINUE
  184. C
  185. C  CAS DES POUTRES - TUYAUX
  186. C
  187.       NBBB=NBNN
  188.       SEGINI WRK1,WRK3
  189. *
  190. *  cas du materiau section
  191. *
  192.       NBGMAT = 0
  193.       NELMAT = 0
  194.       IF(CMATE.EQ.'SECTION') THEN
  195.           MPTVAL=IVAMAT
  196.           DO IM=1,NMATT
  197.           IF(IVAL(IM).NE.0)THEN
  198.               MELVAL=IVAL(IM)
  199.               NBGMAT=MAX(NBGMAT,IELCHE(/1))
  200.               NELMAT=MAX(NELMAT,IELCHE(/2))
  201.           END IF
  202.           END DO
  203.       ENDIF
  204. C
  205. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  206. C
  207.       DO 2027 IB=1,NBELEM
  208. C
  209. C     ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  210. C
  211.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  212. C
  213. C  ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK
  214. C
  215. C
  216. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE
  217. C
  218. C
  219.           NCARR1=NCARR
  220.           CALL ZERO(WORK,NCARR,1)
  221.           DO 2129 IGAU=1,NBNN
  222.               MPTVAL=IVACAR
  223.               DO 2229 IC=1,NCARR
  224.                   MELVAL=IVAL(IC)
  225.                   IF (IVAL(IC).NE.0) THEN
  226.                       IBMN=MIN(IB,VELCHE(/2))
  227.                       IGMN=MIN(IGAU,VELCHE(/1))
  228.                       WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  229.                   ELSE
  230.                       WORK(IC)=0.D0
  231.                   ENDIF
  232.                   IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  233.  2229         CONTINUE
  234.  2129     CONTINUE
  235. C
  236. C
  237.           MPTVAL=IVAMAT
  238.           MELVAL=IVAL(1)
  239. C
  240. C
  241.  2529    CONTINUE
  242. C
  243. C CAS DES POUTRES ET TUYAU
  244. C
  245.               IF(CMATE.NE.'SECTION') THEN
  246.                   IBMN=MIN(IB,VELCHE(/2))
  247. C
  248.                   IF((MELE.EQ.46).OR.(MELE.EQ.95)) THEN
  249.                      WORK(2)=VELCHE(1,IBMN)
  250.                   ELSE
  251.                      WORK(11)=VELCHE(1,IBMN)
  252.                   ENDIF
  253. C
  254. C
  255. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  256. C  --------------   EQUIVALENTE
  257. C
  258.                   IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1)
  259.               ELSE
  260. *
  261. *       cas formulation section
  262. *
  263.                   IBMN=MIN(IB,IELCHE(/2))
  264.                   IPMODL=IELCHE(1,IBMN)
  265.                   MELVAL=IVAL(2)
  266.                   IBMN=MIN(IB,IELCHE(/2))
  267.                   IPMAT=IELCHE(1,IBMN)
  268.                   IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN
  269.                       CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  270.                       CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  271.                   ENDIF
  272.               ENDIF
  273. C
  274.  2000    CONTINUE
  275. C**************************************************
  276. C  ON CALCULE LA MATRICE DE RAIDEUR CENTRIFUGE
  277. C**************************************************
  278.           IF (MELE.EQ.46) THEN
  279. C
  280. C Cas de la barre
  281. C
  282.                 CALL BARKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  283.           ELSEIF (MELE.EQ.95) THEN
  284. C
  285. C Cas de CERC
  286. C
  287.                 CALL CERKCE(REL,LRE,WORK,XE,VROT,KERRE)
  288.           ELSEIF (MELE.EQ.84) THEN
  289. C
  290. C Cas du Timo
  291. C
  292.               IF(CMATE.NE.'SECTION') THEN
  293.                 CALL TIMKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  294.               ELSE
  295.                 CALL TIFKCE(REL,LRE,WORK,XE,VROT,WORK(12),LHOOK,
  296.      &          DDHOOK,KERRE)
  297.               ENDIF
  298.           ELSEIF ((MELE.EQ.29).OR.(MELE.EQ.42)) THEN
  299. C
  300. C Cas de la poutre
  301. C
  302.                 CALL POUKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  303. C
  304.           ENDIF
  305. C
  306.           IF(KERRE.EQ.0) GO TO 2127
  307.           INTERR(1)=ISOUS
  308.           INTERR(2)=IB
  309.           SEGSUP WRK1,WRK3,MVELCH
  310.           CALL ERREUR(128)
  311.           SEGSUP xMATRI
  312.           GO TO 510
  313. C
  314. c
  315. c        remplissage de xmatri
  316. c
  317.  2127     CONTINUE
  318. *          SEGINI XMATRI
  319. *          IMATTT(IB)=XMATRI
  320.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  321. *          SEGDES XMATRI
  322.  2027 CONTINUE
  323.       SEGDES xMATRI
  324.       SEGSUP WRK1,WRK3,MVELCH
  325.       GO TO 510
  326. C_______________________________________________________________________
  327. C
  328. C     SECTEUR DE CALCUL POUR LES COQ2
  329. C_______________________________________________________________________
  330. C
  331.    44 CONTINUE
  332.       DIM3=1.D0
  333.       NBNO=NBNN
  334.       NBBB=NBNN
  335.       SEGINI WRK1,WRK3
  336.       I255=0
  337.       I256=0
  338. C
  339. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  340. C
  341.       DO 3044 IB=1,NBELEM
  342. C
  343. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  344. C
  345.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  346. C
  347.           MPTVAL=IVACAR
  348.           MELVAL=IVAL(1)
  349.           IBMN=MIN(IB,VELCHE(/2))
  350.           EP=VELCHE(1,IBMN)
  351.           IF(IFOUR.EQ.-2) THEN
  352.               MELVAL=IVAL(3)
  353.               IF(MELVAL.NE.0) THEN
  354.                   IBMN=MIN(IB,VELCHE(/2))
  355.                   DIM3=VELCHE(1,IBMN)
  356.               ELSE
  357.                   DIM3=1.D0
  358.               ENDIF
  359.           ENDIF
  360. C
  361.           MPTVAL=IVAMAT
  362.           DO 4044 IM=1,NMATT
  363.               MELVAL=IVAL(IM)
  364.               IBMN=MIN(IB,VELCHE(/2))
  365.               VALMAT(IM)=VELCHE(1,IBMN)
  366.  4044     CONTINUE
  367.           RHO=VALMAT(1)
  368. C
  369. C        APPEL A LA SUBROUTINE CALCULANT LA MATRICE KC
  370. C
  371.           CALL COQ2KC(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  372.      +    XDPGE,YDPGE,VROT)
  373. C
  374. C        GESTION D'ERREUR
  375. C
  376.           IF(IARR.EQ.1) I255=IB
  377.           IF(IARR.EQ.2) I256=IB
  378. C
  379. C        REMPLISSAGE
  380. C
  381. C
  382. *          SEGINI XMATRI
  383. *          IMATTT(IB)=XMATRI
  384.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  385. *          SEGDES XMATRI
  386.  3044 CONTINUE
  387. C
  388. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  389. C
  390.       IF(I255.NE.0) THEN
  391.           INTERR(1)=I255
  392.           CALL ERREUR(255)
  393.       ENDIF
  394.       IF(I256.NE.0) THEN
  395.           INTERR(1)=I256
  396.           CALL ERREUR(256)
  397.       ENDIF
  398. C
  399.       SEGDES xMATRI
  400.       SEGSUP WRK1,WRK3,MVELCH
  401.       GOTO 510
  402. C_______________________________________________________________________
  403. C
  404. C     SECTEUR DE CALCUL POUR LES ELEMENTS DST, DKT ET COQ3
  405. C     ADAPTE DE LA MATRICE DE MASSE DES ELEMENTS DST
  406. C     CAR PROBLEME AVEC DKT ET COQ3
  407. C_______________________________________________________________________
  408. C
  409.    93 CONTINUE
  410.       NBNO=NBNN
  411.       NBBB=NBNN
  412.       SEGINI WRK1,WRK2,WRK4,WRK6
  413. C
  414. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  415. C
  416.       DO 9300 IB=1,NBELEM
  417. C
  418. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  419. C
  420.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  421.           CALL ZERO (REL,LRE,LRE)
  422.           CALL VPAST(XE,BPSS)
  423.           CALL VCORLC(XE,XEL,BPSS)
  424. C
  425. C        ACQUISITION DES EPAISSEURS
  426. C
  427.           EP=0.D0
  428.           EXCEN=0.D0
  429.           MPTVAL=IVACAR
  430.               MELVAL=IVAL(1)
  431.               IF (MELVAL.NE.0) THEN
  432.               DO IGAU=1,NBPGAU
  433.                   IGMN=MIN(IGAU,VELCHE(/1))
  434.                   IBMN=MIN(IB  ,VELCHE(/2))
  435.                   EP=EP+VELCHE(IGMN,IBMN)
  436.               ENDDO
  437.               ENDIF
  438. C
  439.               MELVAL=IVAL(2)
  440.               IF (MELVAL.NE.0) THEN
  441.               DO IGAU=1,NBPGAU
  442.                   IGMN=MIN(IGAU,VELCHE(/1))
  443.                   IBMN=MIN(IB  ,VELCHE(/2))
  444.                   EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  445.               ENDDO
  446.               ENDIF
  447.           EP=EP/NBPGAU
  448.           EXCEN=EXCEN/NBPGAU
  449. C
  450. C  BOULE SUR LES POINTS DE GAUSS
  451. C
  452.           DO 9310 IGAU=1,NBPGAU
  453. C
  454.               MPTVAL=IVAMAT
  455.               MELVAL=IVAL(1)
  456.               IBMN=MIN(IB,VELCHE(/2))
  457.               IGMN=MIN(IGAU,VELCHE(/1))
  458.               RHO=VELCHE(IGMN,IBMN)
  459. C
  460. C        CALCUL  MATRICE MASSE
  461. C
  462.               CALL ZERO(RHOMAT,6,6)
  463. C
  464.            VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  465.      .      +BPSS(1,3)*VROT(3)
  466.            VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  467.      .      +BPSS(2,3)*VROT(3)
  468.            VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  469.      .      +BPSS(3,3)*VROT(3)
  470. C
  471.            RHOMAT( 1, 1)=RHO*EP*(-1.)*((VROTL(2)**2) + (VROTL(3)**2))
  472.            RHOMAT( 1, 2)=RHO*EP*VROTL(1)*VROTL(2)
  473.            RHOMAT( 1, 3)=RHO*EP*VROTL(1)*VROTL(3)
  474.            RHOMAT( 2, 1)=RHOMAT( 1, 2)
  475.            RHOMAT( 2, 2)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(3)**2))
  476.            RHOMAT( 2, 3)=RHO*EP*VROTL(2)*VROTL(3)
  477.            RHOMAT( 3, 1)=RHO*EP*RHOMAT( 1, 3)
  478.            RHOMAT( 3, 2)=RHO*EP*RHOMAT( 2, 3)
  479.            RHOMAT( 3, 3)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(2)**2))
  480. C
  481.            RHOMAT( 1, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  482.            RHOMAT( 1, 5)=(-1.D0)*RHO*EP*EXCEN*(VROTL(2)**2+VROTL(3)**2)
  483.            RHOMAT( 2, 4)=RHO*EP*EXCEN*(VROTL(1)**2+VROTL(3)**2)
  484.            RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(2)
  485.            RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)*VROTL(3)
  486.            RHOMAT( 3, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  487. C
  488.            RHOMAT( 4, 1)=RHOMAT( 1, 4)
  489.            RHOMAT( 5, 1)=RHOMAT( 1, 5)
  490.            RHOMAT( 4, 2)=RHOMAT( 2, 4)
  491.            RHOMAT( 5, 2)=RHOMAT( 2, 5)
  492.            RHOMAT( 4, 3)=RHOMAT( 3, 4)
  493.            RHOMAT( 5, 3)=RHOMAT( 3, 5)
  494. C
  495.               CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC)
  496.               DJAC=DJAC*POIGAU(IGAU)
  497.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  498.  9310     CONTINUE
  499. C
  500. C
  501. C
  502.           ICOM = 0
  503.           IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4)
  504.      &    ICOM=1
  505.           CALL TRANSK(REL,BPSS,18,3,ICOM)
  506. C
  507. C        REMPLISSAGE
  508. C
  509. *          SEGINI XMATRI
  510. *          IMATTT(IB)=XMATRI
  511.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  512. C
  513. *          SEGDES XMATRI
  514.  9300 CONTINUE
  515.       SEGDES xMATRI
  516.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  517.       GOTO 510
  518. C_______________________________________________________________________
  519. C
  520. C     ELEMENT COQ6 COQ8
  521. C_______________________________________________________________________
  522. C
  523.   41  CONTINUE
  524.       NBBB=NBNN
  525.       SEGINI WRK1,WRK3
  526. C
  527.       DO 4041 IB=1,NBELEM
  528. c         coordonnees XE
  529.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  530.  
  531. cbp,2020 : COQ8KC attend des valeurs constantes par element (probablement 
  532. c         car le support du materiau n'est pas forcement celui de la masse)
  533. c         ==> on prend la moyenne (et pas seulement le 1er point de Gauss!)
  534. c         WORK n'est pas utilise ==> on ne le remplit pas !
  535. c
  536. C         MASSE VOLUMIQUE
  537.           MPTVAL=IVAMAT
  538.           MELVAL=IVAL(1)
  539.           NGAU=VELCHE(/1)
  540.           IBMN=MIN(IB,VELCHE(/2))
  541.           IF(NGAU.EQ.1) THEN
  542.             RHO=VELCHE(1,IBMN)
  543.           ELSE
  544.             RHO=0.D0 
  545.             DO IGAU=1,NGAU
  546.               RHO=RHO+VELCHE(IGAU,IBMN)
  547.             ENDDO
  548.             RHO=RHO/NGAU
  549.           ENDIF
  550. c           VALMAT(1)=RHO
  551. C
  552. C         EPAISSEUR ET EXCENREMENT
  553.           MPTVAL=IVACAR
  554.           IF (IVAL(1).NE.0) THEN
  555.             MELVAL=IVAL(1)
  556. c             DO IGAU=1,NBPGAU
  557. c                 IGMN=MIN(IGAU,VELCHE(/1))
  558. c                 IBMN=MIN(IB  ,VELCHE(/2))
  559. c                 WORK(IGAU)=VELCHE(IGMN,IBMN)
  560. c             ENDDO           
  561. c           RR=VALMAT(1)*VELCHE(1,IBMN)
  562.             NGAU=VELCHE(/1)
  563.             IF(NGAU.EQ.1) THEN
  564.               EPAI=VELCHE(1,IBMN)
  565.             ELSE
  566.               EPAI=0.D0
  567.               DO IGAU=1,NGAU
  568.                 EPAI=EPAI+VELCHE(IGAU,IBMN)
  569.               ENDDO
  570.               EPAI=EPAI/NGAU
  571.             ENDIF
  572.           ELSE
  573. c           on ne devrait pas passer par la          
  574. c             WORK(IGAU)=0
  575.             CALL ERREUR(5)
  576.           ENDIF
  577.           IF (IVAL(2).NE.0) THEN
  578.             MELVAL=IVAL(2)
  579. c             DO IGAU=1,NBPGAU
  580. c                 IGMN=MIN(IGAU,VELCHE(/1))
  581. c                 IBMN=MIN(IB  ,VELCHE(/2))
  582. c                 WORK(IGAU+10)=VELCHE(IGMN,IBMN)
  583. c             ENDDO
  584.             NGAU=VELCHE(/1)
  585.             IF(NGAU.EQ.1) THEN
  586.               EXENT=VELCHE(1,IBMN)
  587.             ELSE
  588.               EXENT=0.D0
  589.               DO IGAU=1,NGAU
  590.                 EXENT=EXENT+VELCHE(IGAU,IBMN)
  591.               ENDDO
  592.               EXENT=EXENT/NGAU
  593.             ENDIF
  594.           ELSE
  595. c              WORK(IGAU+10)=0
  596.              EXENT=0.D0
  597.           ENDIF
  598. C
  599. c           RHO=VALMAT(1)
  600. c           EPAI = WORK(1)
  601. c           EXENT= WORK(11)
  602. cnewparadigm          SEGDES WRK1,WRK3
  603. cnewparadigm          SEGDES MINTE
  604.           CALL COQ8KC(NBNN,RHO,NBPGAU,EPAI,EXENT,WRK1,
  605.      .                MINTE,MINTE2,VROT)
  606. cnewparadigm          SEGACT WRK1,WRK3*MOD
  607. cnewparadigm          SEGACT MINTE
  608. *          SEGINI XMATRI
  609. *          IMATTT(IB)=XMATRI
  610.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  611. *          SEGDES XMATRI
  612.  4041 CONTINUE
  613.       SEGDES xMATRI
  614.       SEGSUP WRK1,WRK3,MVELCH
  615.       GOTO 510
  616. C_______________________________________________________________________
  617. C
  618. C     SECTEUR DE CALCUL POUR LES COQ4
  619. C_______________________________________________________________________
  620. C
  621.    51 CONTINUE
  622.       NBNO=NBNN
  623.       NBBB=NBNN
  624.       SEGINI WRK1,WRK2,WRK4,WRK6
  625.       IG1=0
  626.       IG2=0
  627.       IG3=0
  628. C
  629. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  630. C
  631.       DO 5149 IB=1,NBELEM
  632. c
  633. C
  634. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  635. C
  636.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  637.           CALL ZERO (REL,LRE,LRE)
  638. C         REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé
  639.           CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  640. C
  641.           MPTVAL=IVACAR
  642.           MELVAL=IVAL(1)
  643.           IBMN=MIN(IB,VELCHE(/2))
  644.           EP=VELCHE(1,IBMN)
  645.           IF (IVAL(2).NE.0) THEN
  646.               MELVAL=IVAL(2)
  647.               IBMN=MIN(IB,VELCHE(/2))
  648.               EXCEN =VELCHE(1,IBMN)
  649.           ELSE
  650.               EXCEN=0.D0
  651.           ENDIF
  652. C
  653.           MPTVAL=IVAMAT
  654.           MELVAL=IVAL(1)
  655.           IBMN=MIN(IB,VELCHE(/2))
  656.           VALMAT(1)=VELCHE(1,IBMN)
  657.           RHO=VALMAT(1)
  658. C
  659. C
  660.           CALL ZERO(RHOMAT,6,6)
  661. C
  662.            VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  663.      .      +BPSS(1,3)*VROT(3)
  664.            VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  665.      .      +BPSS(2,3)*VROT(3)
  666.            VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  667.      .      +BPSS(3,3)*VROT(3)
  668. C
  669.            RHOMAT( 1, 1)=RHO*EP*(-1.)*((VROTL(2)**2) + (VROTL(3)**2))
  670.            RHOMAT( 1, 2)=RHO*EP*VROTL(1)*VROTL(2)
  671.            RHOMAT( 1, 3)=RHO*EP*VROTL(1)*VROTL(3)
  672.            RHOMAT( 2, 1)=RHOMAT( 1, 2)
  673.            RHOMAT( 2, 2)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(3)**2))
  674.            RHOMAT( 2, 3)=RHO*EP*VROTL(2)*VROTL(3)
  675.            RHOMAT( 3, 1)=RHOMAT( 1, 3)
  676.            RHOMAT( 3, 2)=RHOMAT( 2, 3)
  677.            RHOMAT( 3, 3)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(2)**2))
  678. C
  679.            RHOMAT( 1, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  680.            RHOMAT( 1, 5)=(-1.D0)*RHO*EP*EXCEN*(VROTL(2)**2+VROTL(3)**2)
  681.            RHOMAT( 2, 4)=RHO*EP*EXCEN*(VROTL(1)**2+VROTL(3)**2)
  682.            RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(2)
  683.            RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)*VROTL(3)
  684.            RHOMAT( 3, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  685. C
  686.            RHOMAT( 4, 1)=RHOMAT( 1, 4)
  687.            RHOMAT( 5, 1)=RHOMAT( 1, 5)
  688.            RHOMAT( 4, 2)=RHOMAT( 2, 4)
  689.            RHOMAT( 5, 2)=RHOMAT( 2, 5)
  690.            RHOMAT( 4, 3)=RHOMAT( 3, 4)
  691.            RHOMAT( 5, 3)=RHOMAT( 3, 5)
  692. C
  693.           NBPGAM=NBPGAU-1
  694.           DO 5049 IGAU=1,NBPGAM
  695.               CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  696. C           IERT=1 JACOBIANO=<0
  697.               IF(IERT.EQ.1) IG3=IB
  698.               DJAC=DJAC*POIGAU(IGAU)
  699.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  700. 5049      CONTINUE
  701. C
  702. C  PASSAGE EN COORDONNéES GLOBALES
  703. C
  704.           CALL TRANSK(REL,BPSS,24,4,0)
  705. C
  706. C        REMPLISSAGE
  707. C
  708. *          SEGINI XMATRI
  709. *          IMATTT(IB)=XMATRI
  710.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  711. *          SEGDES XMATRI
  712.  5149 CONTINUE
  713. C
  714. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  715. C
  716.       IF(IG1.NE.0) THEN
  717.           INTERR(1)=IG1
  718.           CALL ERREUR(323)
  719.       ENDIF
  720.       IF(IG2.NE.0) THEN
  721.           INTERR(1)=IG2
  722.           CALL ERREUR(322)
  723.       ENDIF
  724.       IF(IG3.NE.0) THEN
  725.           INTERR(1)=IG3
  726.           CALL ERREUR(321)
  727.       ENDIF
  728. C
  729.       SEGDES xMATRI
  730.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  731.       GOTO 510
  732. C_______________________________________________________________________
  733. *
  734.    99 CONTINUE
  735.       MOTERR(1:4)=NOMTP(MELE)
  736.       MOTERR(5:12)='KCEN'
  737.       CALL ERREUR(86)
  738. *
  739.   510 CONTINUE
  740.       RETURN
  741.       END
  742. C
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  

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