C COPBA3 SOURCE CB215821 20/11/25 13:22:14 10792 SUBROUTINE COPBA3(ITBAS,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP, & KTRCHA,KTRAV,ICONT) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * 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 contenant les modes, ou les pseudo-modes * * e MOTCLE mot : PLUS ou ROTA * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 31 mai 1990. * * * *--------------------------------------------------------------------* * * -INC PPARAM -INC CCOPTIO -INC SMCHPOI -INC SMCHAML -INC SMELEME -INC SMTABLE * 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 * INTEGER LCHAIN(*) CHARACTER*(*) MOTCLE CHARACTER*(LOCOMP) COMP * ITRCHP = KTRCHP NSOU = ICHCA(/1) IF (ICONT.EQ.1) THEN ITRCHA = KTRCHA NSOUS = ICHAM(/1) ENDIF IF (MOTCLE.EQ.'ROTA') MTRAV = KTRAV * MTABLE = ITBAS SEGACT MTABLE*MOD LONG = MLOTAB IM = IMODE DO 10 I = 1,LONG IF (MTABTI(I).EQ.'ENTIER ' .AND. MTABII(I).EQ.IM .AND. & MTABTV(I).EQ.'TABLE ') THEN ITMOD = MTABIV(I) IM = IM + 1 MTAB1 = ITMOD SEGACT MTAB1*MOD LON1 = MTAB1.MLOTAB DO 20 I1 = 1,LON1 IF (MTAB1.MTABTI(I1).EQ.'MOT ') THEN IF (MTAB1.MTABII(I1).EQ.LCHAIN(3) .OR. & MTAB1.MTABII(I1).EQ.LCHAIN(6)) THEN IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN ICHDEP = MTAB1.MTABIV(I1) MCHPOI = ICHDEP SEGACT MCHPOI DO 22 INS = 1,NSOU MSOUPO = IPCHP(INS) SEGACT MSOUPO*MOD IF (MOTCLE.EQ.'ROTA') THEN NCOM = NOCOMP(/2) SEGINI MTRA2 MPOVAL = IPOVAL SEGACT MPOVAL NPOIN = VPOCHA(/1) DO 24 IP = 1,NPOIN ICD = 0 ICR = 0 DO 26 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 26 CONTINUE * end do DO 28 IDE = 1,ICD XVAL = 0.D0 DO 30 ID2 = 1,ICD XVAL = XVAL + XMPT(IDE,ID2) * XDEP(ID2) 30 CONTINUE * end do IC = IDEP(IDE) VPOCHA(IP,IC) = XVAL 28 CONTINUE * end do IF (IDIM.EQ.3) THEN DO 32 IRO = 1,ICR XVAL = 0.D0 DO 34 IR2 = 1,ICR XVAL = XVAL + XMPT(IRO,IR2) * XROT(IR2) 34 CONTINUE * end do IC = IROT(IRO) VPOCHA(IP,IC) = XVAL 32 CONTINUE * end do ENDIF 24 CONTINUE * end do SEGDES MPOVAL SEGSUP MTRA2 ENDIF IGEOC = ICHCN(INS) SEGDES MSOUPO 22 CONTINUE * end do SEGDES MCHPOI MTAB1.MTABIV(I1) = ICHDEP ENDIF ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(5) .OR. & MTAB1.MTABII(I1).EQ.LCHAIN(8)) THEN IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN ICHDEP = MTAB1.MTABIV(I1) MCHPOI = ICHDEP SEGACT MCHPOI NSOU2 = IPCHP(/1) DO 40 INS = 1,NSOU2 MSOUPO = IPCHP(INS) SEGACT MSOUPO*MOD IF (MOTCLE.EQ.'ROTA') THEN NCOM2 = NOCOMP(/2) SEGINI MTRA4 MPOVAL = IPOVAL SEGACT MPOVAL NPOI2 = VPOCHA(/1) NCOM2 = VPOCHA(/2) DO 42 IP = 1,NPOI2 ICF = 0 ICM = 0 DO 44 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 44 CONTINUE * end do DO 46 IDE = 1,ICF XVAL = 0.D0 DO 48 ID2 = 1,ICF XVAL = XVAL + XMPT(IDE,ID2) * XFOR(ID2) 48 CONTINUE * end do IC = IFOR(IDE) VPOCHA(IP,IC) = XVAL 46 CONTINUE * end do IF (IDIM.EQ.3) THEN DO 50 IRO = 1,ICM XVAL = 0.D0 DO 52 IR2 = 1,ICM XVAL = XVAL + XMPT(IRO,IR2) * XMOM(IR2) 52 CONTINUE * end do IC = IMOM(IRO) VPOCHA(IP,IC) = XVAL 50 CONTINUE * end do ENDIF 42 CONTINUE * end do SEGDES MPOVAL SEGSUP MTRA4 ENDIF IPT1 = IGEOC SEGINI,MELEME=IPT1 NBE = NUM(/2) NBP = NUM(/1) DO 54 IE = 1,NBE DO 56 IP = 1,NBP IPTS = NUM(IP,IE) CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT) IF (IERR.NE.0) RETURN NUM(IP,IE) = INOPT 56 CONTINUE * end do 54 CONTINUE * end do SEGDES MELEME IGEOC = MELEME SEGDES MSOUPO 40 CONTINUE * end do SEGDES MCHPOI MTAB1.MTABIV(I1) = ICHDEP ENDIF ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(4) .OR. & MTAB1.MTABII(I1).EQ.LCHAIN(7)) THEN IF (MTAB1.MTABTV(I1).EQ.'MCHAML ') THEN ICHCON = MTAB1.MTABIV(I1) MCHELM = ICHCON SEGACT MCHELM*MOD DO 60 INS = 1,NSOUS IMACHE(INS) = ICHAM(INS) 60 CONTINUE * end do SEGDES MCHELM MTAB1.MTABIV(I1) = ICHCON ENDIF ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(9) .AND. & MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN ICHDEP = MTAB1.MTABIV(I1) MCHPOI = ICHDEP SEGACT MCHPOI NSOU3 = IPCHP(/1) DO 80 INS = 1,NSOU3 MSOUPO = IPCHP(INS) SEGACT MSOUPO IPT1 = IGEOC SEGINI,MELEME=IPT1 NBE = NUM(/2) NBP = NUM(/1) DO 82 IE = 1,NBE DO 84 IP = 1,NBP IPTS = NUM(IP,IE) CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT) IF (IERR.NE.0) RETURN NUM(IP,IE) = INOPT 84 CONTINUE * end do 82 CONTINUE * end do SEGDES MELEME IGEOC = MELEME SEGDES MSOUPO 80 CONTINUE * end do SEGDES MCHPOI MTAB1.MTABIV(I1) = ICHDEP ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(10) .AND. & MTAB1.MTABTV(I1).EQ.'POINT ') THEN IPTS = MTAB1.MTABIV(I1) CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT) IF (IERR.NE.0) RETURN MTAB1.MTABIV(I1) = INOPT ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND. & MTAB1.MTABTV(I1).EQ.'TABLE ') THEN IF (MOTCLE.EQ.'ROTA') THEN ITDEPG = MTAB1.MTABIV(I1) SEGINI MTRA3 MTAB2 = ITDEPG SEGACT MTAB2 LON2 = MTAB2.MLOTAB IDG = 1 DO 70 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 70 CONTINUE * end do DO 72 ID1 = 1,IDIM XVAL = 0.D0 DO 74 ID2 = 1,IDIM XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2)) 74 CONTINUE * end do XDGE2(ID1) = XVAL 72 CONTINUE * end do IDG = 1 DO 76 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 76 CONTINUE * end do SEGDES MTAB2 MTAB1.MTABIV(I1) = ITDEPG SEGSUP MTRA3 ENDIF ENDIF ENDIF 20 CONTINUE * end do SEGDES MTAB1 MTABIV(I) = ITMOD ENDIF 10 CONTINUE * end do SEGDES MTABLE * END