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

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