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

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