C CORIO2 SOURCE PV090527 26/04/30 21:15:22 12529 SUBROUTINE CORIO2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR, &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE, &LHOOK,IPMATR,VROT,NUMLIS,IIPDPG) *---------------------------------------------------------------------* * _________________________________________________ * * | | * * | calcul de la matrice de couplage gyroscopique | * * | dans le repère tournant | * * |________________________________________________| * * * * barr,poutre,timo,tuyau * * coq3,dkt,coq4,coq8,dst * *---------------------------------------------------------------------* * * * entrees : * * ________ * * * * ipmail pointeur sur un segment meleme * * lre nombre de ddl dans la matrice de masse * * lw dimension du tableau de travail de l'element * * mele numero de l'element fini * * ivamat pointeur sur un segment mptval pour le materiau * * nmatt nombre de composante de materiau (imat=1) * * ivacar pointeur sur un segment mptval pour les caracteri- * * stiques * * ncarr nombre de caracteristiques geometriques * * ivect flag indiquant si on a entree les axes locaux * * isous numero de la sous-zone * * nbpgau nombre de point d'integration pour la masse * * ipmint pointeur sur un segment minte * * ipmin1 pointeur sur un segment minte (aux noeuds) * * nddl nombre de degre de liberte /noeud * * mate numero du materiau * * cmate nom du materiau * * vrot vecteur vitesse de rotation * * * * sorties : * * ________ * * * * ipmatr pointeur sur la matrice d'amortissement * * de la sous-zone * * * * Didier COMBESCURE mars 2003 * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL *- -INC SMRIGID -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMINTE -INC SMMODEL -INC TMPTVAL SEGMENT WRK1 REAL*8 REL(LRE,LRE),XE(3,NBBB) ENDSEGMENT C SEGMENT WRK2 REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE) ENDSEGMENT C SEGMENT WRK3 REAL*8 DDHOOK(LHOOK,LHOOK) REAL*8 WORK(LW) ENDSEGMENT C SEGMENT WRK4 REAL*8 BPSS(3,3),XEL(3,NBBB) ENDSEGMENT C SEGMENT WRK6 REAL*8 RHOMAT(6,6) ENDSEGMENT SEGMENT WRK7 REAL*8 XJI(3,3),TXR(3,3,NBNO),FINT(3,LRE),XJ(3,3),B(3,3) REAL*8 TH(NBNO),EXC(NBNO),H(NBNO) REAL*8 ROME(3,3),REWO(LRE,LRE) ENDSEGMENT C SEGMENT MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT DIMENSION VROT(*) DIMENSION CRIGI(12),CMASS(12),VROTL(3) CHARACTER*8 CMATE * MELEME=IPMAIL c* SEGACT,IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * xMATRI=IPMATR c* SEGACT,xMATRI*MOD c* NLIGRP=LRE c* NLIGRD=LRE * NHRM=NIFOUR * MINTE =IPMINT c* SEGACT,MINTE c C_______________________________________________________________________ C C NUMERO DES ETIQUETTES : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : C 5 CONTINUE C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... C 44 CONTINUE C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... C_______________________________________________________________________ C * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 & , 99, 99, 99, 99, 93, 93, 21, 99, 99, 99, 99 * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 & , 99, 99, 99, 99, 99, 99, 99, 41, 21, 99, 44 * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO & , 99, 21, 99, 99, 51, 99, 99, 99, 99, 99, 99 * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 & , 41, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99 * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 & , 99, 99, 99, 99, 93, 99, 99, 99, 99, 99, 99 * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99 * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 * TE56 PY91 TRH6 & , 99, 99, 99),MELE GOTO 99 C C_______________________________________________________________________ C C ELEMENTS POUTRES C_______________________________________________________________________ C 21 CONTINUE C C CAS DES POUTRES - TUYAUX C NBBB=NBNN SEGINI WRK1,WRK3 * * cas du materiau section * NBGMAT = 0 NELMAT = 0 IF(CMATE.EQ.'SECTION') THEN MPTVAL=IVAMAT DO IM=1,NMATT IF(IVAL(IM).NE.0)THEN MELVAL=IVAL(IM) NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) END IF END DO ENDIF C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 2027 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C CAS DES POUTRES C -------------- C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE C MPTVAL=IVACAR DO 2429 IC=1,NCARR WORK(IC)=0.D0 IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) DO 2029 IGAU=1,NBNN IGMN=MIN(IGAU,VELCHE(/1)) WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 2029 CONTINUE WORK(IC)=WORK(IC)/NBNN ENDIF 2429 CONTINUE C C CAS OU ON A LU LE MOT VECTEUR C C MPTVAL=IVAMAT C C CAS DES POUTRES ET TUYAU C MELVAL=IVAL(1) IF(CMATE.NE.'SECTION') THEN IBMN=MIN(IB,VELCHE(/2)) C IF(MELE.EQ.46) THEN WORK(2)=VELCHE(1,IBMN) ELSE WORK(11)=VELCHE(1,IBMN) ENDIF C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C -------------- EQUIVALENTE C IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1) ELSE * * cas formulation section * IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF C C ON CALCULE LA MATRICE DE COUPLAGE GYROSCOPIQUE C IF (MELE.EQ.46) THEN CALL BARCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) ELSEIF (MELE.EQ.84) THEN IF(CMATE.NE.'SECTION') THEN CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) ELSE CALL TIFCOR(REL,LRE,WORK,XE,VROT,WORK(12),LHOOK, & DDHOOK,KERRE) ENDIF ELSE CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) ENDIF C IF (KERRE.NE.0) THEN INTERR(1)=ISOUS INTERR(2)=IB CALL ERREUR(128) GOTO 9027 ENDIF DO IIIA=1,LRE DO IIIB=1,LRE RE(IIIA,IIIB,ib)=REL(IIIA,IIIB) ENDDO ENDDO * 2027 CONTINUE 9027 CONTINUE SEGSUP,WRK1,WRK3 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS DST, DKT ET COQ3 C ADAPTE DE LA MATRICE DE MASSE DES ELEMENTS DST C CAR PROBLEME AVEC DKT ET COQ3 C_______________________________________________________________________ C 93 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4,WRK6 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 9300 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) CALL VPAST(XE,BPSS) CALL VCORLC(XE,XEL,BPSS) C MPTVAL=IVACAR C C ACQUISITION DES EPAISSEURS C EP=0.D0 MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EP=EP+VELCHE(IGMN,IBMN) ENDDO EP=EP/NBPGAU ENDIF C EXCEN=0.D0 MELVAL=IVAL(2) IF (MELVAL.NE.0) THEN DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) EXCEN=EXCEN+VELCHE(IGMN,IBMN) ENDDO EXCEN=EXCEN/NBPGAU ENDIF C C BOULE SUR LES POINTS DE GAUSS C DO 9310 IGAU=1,NBPGAU C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) RHO=VELCHE(IGMN,IBMN) C CALL ZERO(RHOMAT,6,6) C VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2) . +BPSS(1,3)*VROT(3) VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2) . +BPSS(2,3)*VROT(3) VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2) . +BPSS(3,3)*VROT(3) C RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3) RHOMAT( 1, 3)=RHO*EP*VROTL(2) RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2) RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1) RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3) RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3) C RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3) RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3) RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1) RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2) C RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4) RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5) RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4) RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5) C CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC) DJAC=DJAC*POIGAU(IGAU) CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL) 9310 CONTINUE C ICOM = 0 IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4) ICOM=1 CALL TRANSG(REL,BPSS,18,3,ICOM) C C REMPLISSAGE C DO I2=1,LRE DO I1=1,LRE RE(I1,I2,ib) = REL(I1,I2) enddo enddo C 9300 CONTINUE SEGSUP WRK1,WRK2,WRK4,WRK6 GOTO 510 C_______________________________________________________________________ C C ELEMENT COQ6 COQ8 C_______________________________________________________________________ C 41 CONTINUE NBBB=NBNN NBNO = NBNN SEGINI WRK1,WRK7 c Debut du remplissage WRK7 ROME(1,1) = 0.D0 ROME(1,2) = (-1.)*VROT(3) ROME(1,3) = VROT(2) ROME(2,1) = VROT(3) ROME(2,2) = 0.D0 ROME(2,3) = (-1.)*VROT(1) ROME(3,1) = (-1.)*VROT(2) ROME(3,2) = VROT(1) ROME(3,3) = 0.D0 MINTE2=IPMIN2 SEGACT,MINTE2 C DO 4041 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) VALMAT(1)=VELCHE(1,IBMN) RHO = VALMAT(1) C C CALCUL DE L'EPAISSEUR ET DE L'EXCENTREMENT (MOYENS) C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) C EPAI = 0.D0 IF (IVAL(1).NE.0) THEN MELVAL=IVAL(1) IBMN=MIN(IB ,VELCHE(/2)) DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) EPAI = EPAI + VELCHE(IGMN,IBMN) ENDDO EPAI = EPAI / NBPGAU ENDIF EXENT = 0.D0 IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB ,VELCHE(/2)) DO IGAU=1,NBPGAU IGMN=MIN(IGAU,VELCHE(/1)) EXENT = EXENT + VELCHE(IGMN,IBMN) ENDDO EXENT = EXENT / NBPGAU ENDIF C DO igau = 1, NBNO TH(igau) = EPAI EXC(igau) = EXENT ENDDO C CALL COQ8GY(NBNN,RHO,NBPGAU,WRK1,MINTE,MINTE2,WRK7) C DO IIIB=1,LRE DO IIIA=1,LRE RE(IIIA,IIIB,ib)=REL(IIIA,IIIB) enddo enddo 4041 CONTINUE SEGSUP,WRK1,WRK7 SEGDES,MINTE2 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES COQ2 C_______________________________________________________________________ C+DC: d apres la matrice de massse 44 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1 XDPGE = 0.D0 YDPGE = 0.D0 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 3044 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EP=VELCHE(1,IBMN) C MPTVAL=IVAMAT DO 4044 IM=1,NMATT MELVAL=IVAL(IM) IBMN=MIN(IB,VELCHE(/2)) VALMAT(IM)=VELCHE(1,IBMN) 4044 CONTINUE RHO=VALMAT(1) C C APPEL A LA SUBROUTINE CALCULANT LA MATRICE DE CORIOLIS C IF (NUMLIS.EQ.1) THEN C Cas d'une matrice utilsé en calcul harmonique (symétrique) CALL COQ2CH(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, + XDPGE,YDPGE,VROT) ELSE C Cas de la matrice utilisé en temporel (antisymétrique) CALL COQ2CO(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, + XDPGE,YDPGE,VROT) ENDIF C C GESTION D'ERREUR C IF(IARR.NE.0) THEN INTERR(1)=IB IF(IARR.EQ.1) CALL ERREUR(195) IF(IARR.EQ.2) CALL ERREUR(259) GOTO 9044 ENDIF C C REMPLISSAGE C DO I2=1,LRE DO I1=1,LRE RE(I1,I2,ib) = REL(I1,I2) enddo enddo C 3044 CONTINUE C 9044 CONTINUE SEGSUP,WRK1 GOTO 510 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES COQ4 C_______________________________________________________________________ C 51 CONTINUE NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2,WRK4,WRK6 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C DO 5149 IB=1,NBELEM c C C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL ZERO (REL,LRE,LRE) C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé CALL CQ4LOC(XE,XEL,BPSS,IERT,0) C MPTVAL=IVACAR MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EP=VELCHE(1,IBMN) IF (IVAL(2).NE.0) THEN MELVAL=IVAL(2) IBMN=MIN(IB,VELCHE(/2)) EXCEN =VELCHE(1,IBMN) ELSE EXCEN=0.D0 ENDIF C MPTVAL=IVAMAT MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) VALMAT(1)=VELCHE(1,IBMN) RHO=VALMAT(1) C CALL ZERO(RHOMAT,6,6) C VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2) . +BPSS(1,3)*VROT(3) VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2) . +BPSS(2,3)*VROT(3) VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2) . +BPSS(3,3)*VROT(3) C RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3) RHOMAT( 1, 3)=RHO*EP*VROTL(2) RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2) RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1) RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3) RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3) C RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3) RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3) RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1) RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2) C RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4) RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5) RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4) RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5) C NBPGAM=NBPGAU-1 DO 5049 IGAU=1,NBPGAM CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT) C IERT=1 JACOBIANO=<0 IF (IERT.EQ.1) THEN INTERR(1)=IB CALL ERREUR(321) GOTO 9051 ENDIF C DJAC=DJAC*POIGAU(IGAU) CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL) 5049 CONTINUE C C PASSAGE EN COORDONNéES GLOBALES C CALL TRANSG(REL,BPSS,24,4,0) C C REMPLISSAGE ET ON BOULEVERSE LA MATRICE DE COUPLAGE C DO I1=1,LRE DO I2=1,LRE RE(I1,I2,ib) = REL(I1,I2) enddo enddo 5149 CONTINUE C 9051 CONTINUE SEGSUP WRK1,WRK2,WRK4,WRK6 GOTO 510 C_______________________________________________________________________ C 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='CORI' CALL ERREUR(86) * 510 CONTINUE SEGSUP,MVELCH RETURN END