C COPBAS SOURCE PV 09/03/12 21:18:16 6325 SUBROUTINE COPBAS(ITBAS,ITPTS,MOTCLE,IPO1,IPO2,XANG) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,Q-Z) LOGICAL L0,L1 *--------------------------------------------------------------------* * * * Effectue une op{ration g{om{trique de translation (MOTCLE = * * 'PLUS') ou de rotation (MOTCLE = 'ROTA') sur ITBAS contenant * * les modes, les pseudo-modes de la structure. * * * * Param}tres: * * * * e ITBAS table de sous-type BASE_MODALE, contenant les modes, * * les pseudo-modes,... de la structure * * e ITPTS table de sous-type POINT, points de la g{om{trie que * * l'on souhaite translat{s * * e MOTCLE mot : PLUS ou ROTA * * e IPO1 premier point de l'axe de rotation * * e IPO2 deuxi}me point de l'axe de rotation, si 3D * * e XANG angle de rotation * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 9 mai 1990. * * * *--------------------------------------------------------------------* * * -INC CCOPTIO -INC SMCHPOI -INC SMCHAML -INC SMCOORD -INC SMELEME -INC SMTABLE * logical ltelq SEGMENT ITRCHP INTEGER ICHCA(NSOU),ICHCN(NSOU) ENDSEGMENT SEGMENT ITRCHA INTEGER ICHAM(NSOUS) ENDSEGMENT SEGMENT MTRAV REAL*8 XPT(IDIMB),XPTP(IDIMB),XP1PT(IDIMB),XMPT(IDIMB,IDIMB) ENDSEGMENT SEGMENT MTRA2 INTEGER IDEP(3),IROT(3) REAL*8 XDEP(3),XROT(3) ENDSEGMENT SEGMENT MTRA3 REAL*8 XDGEN(3),XDGE2(3) ENDSEGMENT SEGMENT MTRA4 INTEGER IFOR(3),IMOM(3) REAL*8 XFOR(3),XMOM(3) ENDSEGMENT * * LCHAIN contiendra les adresses des cha™nes dans CCNOYAU * PARAMETER ( NCHAIN = 19 ) INTEGER LCHAIN(NCHAIN) CHARACTER*4 COMP,MOTCLE CHARACTER*8 TYPRET,CHARRE * CALL CRTABL(ITBID) * ICHAIN = 1 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'POINT_REPERE',L1,IP1) ICHAIN = 2 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'DEPLACEMENTS_GENERALISES',L1,IP1) ICHAIN = 3 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'DEFORMEE_MODALE',L1,IP1) ICHAIN = 4 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'CONTRAINTE_MODALE',L1,IP1) ICHAIN = 5 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'REACTION_MODALE',L1,IP1) ICHAIN = 6 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'DEPLACEMENT',L1,IP1) ICHAIN = 7 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'CONTRAINTE',L1,IP1) ICHAIN = 8 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'REACTION',L1,IP1) ICHAIN = 9 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'CHAMP_BASE_B',L1,IP1) ICHAIN = 10 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'POINT',L1,IP1) ICHAIN = 11 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'MODES',L1,IP1) ICHAIN = 12 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'PSEUDO_MODES',L1,IP1) ICHAIN = 13 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'MAILLAGE',L1,IP1) ICHAIN = 14 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'SOUSTYPE',L1,IP1) ICHAIN = 15 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'BASE_MODALE',L1,IP1) ICHAIN = 16 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'BASE_ROTA',L1,IP1) ICHAIN = 17 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'BASE_PLUS',L1,IP1) ICHAIN = 18 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'BASE',L1,IP1) ICHAIN = 19 CALL ECCTAB(ITBID,'ENTIER',ICHAIN,X0,' ',L0,IP0,'MOT',I1,X1, & 'MASSE_GENERALISEE',L1,IP1) * MTABLE = ITBID SEGACT,MTABLE DO 20 ICHAIN = 1 , NCHAIN LCHAIN(ICHAIN) = MTABIV(ICHAIN) 20 CONTINUE * end do SEGSUP,MTABLE * * R{cup{ration de la table des modes * MTABLE = ITBAS SEGACT MTABLE LONG = MLOTAB DO 10 I = 1,LONG IF (MTABTI(I).EQ.'MOT ' .AND. & MTABII(I).EQ.LCHAIN(11) .AND. & MTABTV(I).EQ.'TABLE ') THEN IBAS = MTABIV(I) GOTO 12 ENDIF 10 CONTINUE * end do CALL ERREUR(499) SEGDES MTABLE RETURN 12 CONTINUE * * R{cup{ration de la table des pseudo-modes * IPSM = 0 DO 14 I = 1,LONG IF (MTABTI(I).EQ.'MOT ' .AND. & MTABII(I).EQ.LCHAIN(12) .AND. & MTABTV(I).EQ.'TABLE ') THEN IPSM = MTABIV(I) GOTO 16 ENDIF 14 CONTINUE * end do 16 CONTINUE SEGDES MTABLE * KTRAV = 0 IF (MOTCLE.EQ.'ROTA') THEN IDIM1 = IDIM + 1 CALL CALMAT(KTRAV,IPO1,IPO2,XANG) IF (IERR.NE.0) RETURN MTRAV = KTRAV ENDIF * * Traitement de la table de modes * =============================== * * On duplique la table des modes * CALL COPBA2(LCHAIN,IBAS,IBA2) * * On r{cup}re la premi}re d{form{e modale pour cr{er le nouveau * maillage. * MTABLE = IBA2 SEGACT MTABLE*MOD LONG = MLOTAB IM = 1 DO 60 I = 1,LONG IF (MTABTI(I).EQ.'ENTIER ' .AND. MTABII(I).EQ.IM .AND. & MTABTV(I).EQ.'TABLE ') THEN ITMOD = MTABIV(I) GOTO 62 ENDIF 60 CONTINUE * end do CALL ERREUR(500) SEGDES MTABLE RETURN 62 CONTINUE MTAB1 = ITMOD SEGACT MTAB1*MOD LON1 = MTAB1.MLOTAB DO 64 I1 = 1,LON1 IF (MTAB1.MTABTI(I1).EQ.'MOT ' .AND. & MTAB1.MTABII(I1).EQ.LCHAIN(3) .AND. & MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN ICHDEP = MTAB1.MTABIV(I1) GOTO 66 ENDIF 64 CONTINUE * end do CALL ERREUR(501) SEGDES MTAB1 SEGDES MTABLE RETURN 66 CONTINUE * MCHPOI = ICHDEP SEGACT MCHPOI NSOU = IPCHP(/1) SEGINI ITRCHP KTRCHP = ITRCHP DO 80 INS = 1,NSOU MSOUPO = IPCHP(INS) SEGACT MSOUPO*MOD IF (MOTCLE.EQ.'PLUS') THEN MAIL1 = IGEOC ICHCA(INS) = MAIL1 CALL ECROBJ('POINT ',IPO1) CALL ECROBJ('MAILLAGE',MAIL1) CALL PROPER(1) IF (IERR.NE.0) RETURN CALL LIROBJ('MAILLAGE',NOMA1,1,IRETOU) IF (IERR.NE.0) RETURN IGEOC = NOMA1 ICHCN(INS) = NOMA1 ELSE SEGINI MTRA2 MPOVAL = IPOVAL SEGACT MPOVAL NPOIN = VPOCHA(/1) NCOM = VPOCHA(/2) DO 210 IP = 1,NPOIN ICD = 0 ICR = 0 DO 220 IC = 1,NCOM COMP = NOCOMP(IC) IF (COMP(1:1).EQ.'U') THEN ICD = ICD + 1 IDEP(ICD) = IC XDEP(ICD) = VPOCHA(IP,IC) ELSE IF (COMP(1:1).EQ.'R') THEN ICR = ICR + 1 IROT(ICR) = IC XROT(ICR) = VPOCHA(IP,IC) ENDIF 220 CONTINUE * end do DO 230 IDE = 1,ICD XVAL = 0.D0 DO 232 ID2 = 1,ICD XVAL = XVAL + (XMPT(IDE,ID2) * XDEP(ID2)) 232 CONTINUE * end do IC = IDEP(IDE) VPOCHA(IP,IC) = XVAL 230 CONTINUE * end do IF (IDIM.EQ.3) THEN DO 240 IRO = 1,ICR XVAL = 0.D0 DO 242 IR2 = 1,ICR XVAL = XVAL + (XMPT(IRO,IR2) * XROT(IR2)) 242 CONTINUE * end do IC = IROT(IRO) VPOCHA(IP,IC) = XVAL 240 CONTINUE * end do ENDIF 210 CONTINUE * end do SEGDES MPOVAL SEGSUP MTRA2 MAIL1 = IGEOC ICHCA(INS) = MAIL1 IPT1 = MAIL1 SEGINI,MELEME=IPT1 NOMA1 = MELEME NBE = NUM(/2) NBPT = XCOOR(/1) / IDIM1 NBPTS = NBPT + NBE SEGADJ MCOORD DO 82 IP = 1,NBE IPT = NUM(IP,1) CALL EXCOO1(IPT,XP,YP,ZP,DP) NBPT1 = NBPT + 1 XPT(1) = XP XPT(2) = YP IF (IDIM.EQ.3) XPT(3) = ZP DO 84 ID1 = 1,IDIM XVAL = 0.D0 DO 86 ID2 = 1,IDIM XVAL = XVAL + (XMPT(ID1,ID2) * XPT(ID2)) 86 CONTINUE * end do XPTP(ID1) = XVAL + XP1PT(ID1) 84 CONTINUE * end do XCOOR(NBPT * IDIM1 + 1) = XPTP(1) XCOOR(NBPT * IDIM1 + 2) = XPTP(2) IF (IDIM.EQ.3) XCOOR(NBPT * IDIM1 + 3) = XPTP(3) XCOOR(NBPT1 * IDIM1) = DP NUM(IP,1) = NBPT1 NBPT = NBPT1 82 CONTINUE * end do SEGDES MELEME IGEOC = NOMA1 ICHCN(INS) = NOMA1 ENDIF SEGDES MSOUPO 80 CONTINUE * end do SEGDES MCHPOI MTAB1.MTABIV(I1) = ICHDEP * IMAIL = ICHCA(1) INOMA = ICHCN(1) DO 40 INS = 2,NSOU MAIL1 = ICHCA(INS) NOMA1 = ICHCN(INS) ltelq=.false. CALL FUSE(INOMA,NOMA1,INOM2,ltelq) INOMA = INOM2 CALL FUSE(IMAIL,MAIL1,IMAI2,ltelq) IMAIL = IMAI2 40 CONTINUE * end do * ICONT = 0 DO 90 I1 = 1,LON1 IF (MTAB1.MTABTI(I1).EQ.'MOT ' .AND. & MTAB1.MTABII(I1).EQ.LCHAIN(4) .AND. & MTAB1.MTABTV(I1).EQ.'MCHAML ') THEN ICHCON = MTAB1.MTABIV(I1) ICONT = 1 GOTO 92 ENDIF 90 CONTINUE * end do 92 CONTINUE KTRCHA = 0 IF (ICONT.EQ.1) THEN MCHELM = ICHCON SEGACT MCHELM*MOD NSOUS = IMACHE(/1) SEGINI ITRCHA KTRCHA = ITRCHA DO 94 IN = 1,NSOUS IPT1 = IMACHE(IN) SEGINI,MELEME=IPT1 NBN = NUM(/1) NBE = NUM(/2) DO 96 IE = 1,NBE DO 98 IP = 1,NBN IPO = NUM(IP,IE) CALL BAPOIN(IMAIL,IPO,INOMA,INOPO) IF (IERR.NE.0) RETURN NUM(IP,IE) = INOPO 98 CONTINUE * end do 96 CONTINUE * end do SEGDES MELEME ICHAM(IN) = MELEME IMACHE(IN) = MELEME 94 CONTINUE * end do SEGDES MCHELM MTAB1.MTABIV(I1) = ICHCON ENDIF * IF (MOTCLE.EQ.'ROTA') THEN DO 400 I1 = 1,LON1 IF (MTAB1.MTABTI(I1).EQ.'MOT ' .AND. & MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND. & MTAB1.MTABTV(I1).EQ.'TABLE ') THEN ITDEPG = MTAB1.MTABIV(I1) GOTO 402 ENDIF 400 CONTINUE * end do CALL ERREUR(502) SEGDES MTAB1 SEGDES MTABLE RETURN 402 CONTINUE * SEGINI MTRA3 MTAB2 = ITDEPG SEGACT MTAB2 LON2 = MTAB2.MLOTAB IDG = 1 DO 410 I2 = 1,LON2 IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND. & MTAB2.MTABII(I2).EQ.IDG .AND. & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN XDGEN(IDG) = MTAB2.RMTABV(I2) IDG = IDG + 1 ENDIF 410 CONTINUE * end do DO 420 ID1 = 1,IDIM XVAL = 0.D0 DO 422 ID2 = 1,IDIM XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2)) 422 CONTINUE * end do XDGE2(ID1) = XVAL 420 CONTINUE * end do IDG = 1 DO 430 I2 = 1,LON2 IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND. & MTAB2.MTABII(I2).EQ.IDG .AND. & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN MTAB2.RMTABV(I2) = XDGE2(IDG) IDG = IDG + 1 ENDIF 430 CONTINUE * end do SEGDES MTAB2 MTAB1.MTABIV(I1) = ITDEPG SEGSUP MTRA3 ENDIF * IREAC = 0 DO 790 I1 = 1,LON1 IF (MTAB1.MTABTI(I1).EQ.'MOT ' .AND. & MTAB1.MTABII(I1).EQ.LCHAIN(5) .AND. & MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN ICHREA = MTAB1.MTABIV(I1) IREAC = 1 GOTO 792 ENDIF 790 CONTINUE * end do 792 CONTINUE IF (IREAC.EQ.1) THEN MCHPOI = ICHREA SEGACT MCHPOI NSOU2 = IPCHP(/1) DO 722 INS = 1,NSOU2 MSOUPO = IPCHP(INS) SEGACT MSOUPO*MOD IF (MOTCLE.EQ.'ROTA') THEN SEGINI MTRA4 MPOVAL = IPOVAL SEGACT MPOVAL NPOI2 = VPOCHA(/1) NCOM2 = VPOCHA(/2) DO 710 IP = 1,NPOI2 ICF = 0 ICM = 0 DO 720 IC = 1,NCOM2 COMP = NOCOMP(IC) IF (COMP(1:1).EQ.'F') THEN ICF = ICF + 1 IFOR(ICF) = IC XFOR(ICF) = VPOCHA(IP,IC) ELSE IF (COMP(1:1).EQ.'M') THEN ICM = ICM + 1 IMOM(ICM) = IC XMOM(ICM) = VPOCHA(IP,IC) ENDIF 720 CONTINUE * end do DO 730 IFO = 1,ICF XVAL = 0.D0 DO 732 IF2 = 1,ICF XVAL = XVAL + XMPT(IFO,IF2) * XFOR(IF2) 732 CONTINUE * end do IC = IFOR(IFO) VPOCHA(IP,IC) = XVAL 730 CONTINUE * end do IF (IDIM.EQ.3) THEN DO 740 IMO = 1,ICM XVAL = 0.D0 DO 742 IM2 = 1,ICM XVAL = XVAL + XMPT(IMO,IM2) * XROT(IM2) 742 CONTINUE * end do IC = IMOM(IMO) VPOCHA(IP,IC) = XVAL 740 CONTINUE * end do ENDIF 710 CONTINUE * end do SEGDES MPOVAL SEGSUP MTRA4 ENDIF IPT1 = IGEOC SEGINI,MELEME=IPT1 NBE = NUM(/2) NBP = NUM(/1) DO 750 IE = 1,NBE DO 752 IP = 1,NBP IPTS = NUM(IP,IE) CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT) IF (IERR.NE.0) RETURN NUM(IP,IE) = INOPT 752 CONTINUE * end do 750 CONTINUE * end do SEGDES MELEME IGEOC = MELEME SEGDES MSOUPO 722 CONTINUE * end do SEGDES MCHPOI MTAB1.MTABIV(I1) = ICHREA ENDIF * SEGDES MTAB1 MTABIV(I) = ITMOD * * On range le maillage dans la nouvelle table de modes * DO 42 I = 1,LONG IF (MTABTI(I).EQ.'MOT ' .AND. & MTABII(I).EQ.LCHAIN(13) .AND. & MTABTV(I).EQ.'MAILLAGE') THEN MTABIV(I) = INOMA GOTO 44 ENDIF 42 CONTINUE * end do CALL ERREUR(503) SEGDES MTABLE RETURN 44 CONTINUE * SEGDES MTABLE * IMODE = 2 CALL COPBA3(IBA2,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,KTRCHA, & KTRAV,ICONT) IF (IERR.NE.0) RETURN * * Normalisation des modes * IF (MOTCLE.EQ.'ROTA') THEN CALL NORMOD(IBA2,LCHAIN) ENDIF * * Traitement de la table de pseudo-modes * ====================================== * * On duplique la table des pseudo-modes * IF (IPSM.NE.0) THEN CALL COPBA2(LCHAIN,IPSM,IPS2) IMODE = 1 CALL COPBA3(IPS2,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP, & KTRCHA,KTRAV,ICONT) IF (IERR.NE.0) RETURN * * On projecte les champs base B sur la base modale * CALL COPBA4(IBA2,IPS2) ENDIF * SEGSUP ITRCHP IF (ICONT.EQ.1) SEGSUP ITRCHA IF (MOTCLE.EQ.'ROTA') THEN SEGSUP MTRAV ENDIF * * Cr{ation de la table de sous-type BASE_MODALE * IF (IPSM.EQ.0) THEN M = 2 ELSE M = 3 ENDIF SEGINI MTABLE ITBA2 = MTABLE MLOTAB = M MTABTI(1) = 'MOT ' MTABII(1) = LCHAIN(14) MTABTV(1) = 'MOT ' MTABIV(1) = LCHAIN(15) MTABTI(2) = 'MOT ' MTABII(2) = LCHAIN(11) MTABTV(2) = 'TABLE ' MTABIV(2) = IBA2 IF (IPSM.NE.0) THEN MTABTI(3) = 'MOT ' MTABII(3) = LCHAIN(12) MTABTV(3) = 'TABLE ' MTABIV(3) = IPS2 ENDIF SEGDES MTABLE * * Traitement de la table des points * ================================= * CALL CRTABL(ITPT2) IF (MOTCLE.EQ.'PLUS') THEN CALL ECCTAB(ITPT2,'MOT',I0,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,'POINT_PLUS',L1,IP1) ELSE CALL ECCTAB(ITPT2,'MOT',I0,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,'POINT_ROTA',L1,IP1) ENDIF IP = 0 50 CONTINUE IP = IP + 1 TYPRET = ' ' CALL ACCTAB(ITPTS,'ENTIER',IP,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IPTS) IF (IPTS.NE.0 .AND. TYPRET.EQ.'POINT ') THEN CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT) IF (IERR.NE.0) RETURN CALL ECCTAB(ITPT2,'POINT',I0,X0,' ',L0,IPTS, & 'POINT',I1,X1,' ',L1,INOPT) GOTO 50 ENDIF * * Cr{ation de la table de sortie * M = 3 SEGINI MTABLE ITNOBA = MTABLE MLOTAB = 3 MTABTI(1) = 'MOT ' MTABII(1) = LCHAIN(14) MTABTV(1) = 'MOT ' IF (MOTCLE.EQ.'PLUS') THEN MTABIV(1) = LCHAIN(17) ELSE MTABIV(1) = LCHAIN(16) ENDIF MTABTI(2) = 'MOT ' MTABII(2) = LCHAIN(18) MTABTV(2) = 'TABLE ' MTABIV(2) = ITBA2 MTABTI(3) = 'MOT ' MTABII(3) = LCHAIN(10) MTABTV(3) = 'TABLE ' MTABIV(3) = ITPT2 SEGDES MTABLE * CALL ECROBJ('TABLE ',ITNOBA) * END