Télécharger la plaquette Cast3M


fr en

Télécharger corio2.eso

Retour à la liste

Numérotation des lignes : 

corio2

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

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