C DEVTRA SOURCE CHAT 09/10/09 21:17:11 6519 SUBROUTINE DEVTRA(ITBAS,ITKM,ITA,KTKAM,IPMAIL,KTRES,KPREF, & KTPHI,KTLIAB,RIGIDE,ITCARA,LMODYN) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Op�rateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Transpose l'information des objets de Castem2000 dans des * * tableaux de travail. * * * * Param�tres: * * * * e ITBAS Table repr�sentant une base modale * * e ITKM Table contenant les matrices XK et XM * * e ITA Table contenant la matrice XASM * * es KTKAM Segment contenant les matrices XK, XASM et XM * * e IPMAIL Maillage de r�f�rence pour les CHPOINTs r�sultats * * es KTRES Segment de sauvegarde des r�sultats * * e KPREF Segment des points de r�f�rence * * es KTPHI Segment des d�form�es modales * * e KTLIAB Segment des liaisons sur base B * * e RIGIDE Vrai si corps rigide, faux sinon * * * * Auteur, date de cr�ation: * * * * Denis ROBERT-MOUGIN, le 26 mai 1989. * * * *--------------------------------------------------------------------* -INC SMRIGID -INC CCOPTIO -INC CCREEL * SEGMENT,MTKAM REAL*8 XK(NA1),XASM(NA1),XM(NA1) ENDSEGMENT SEGMENT,MTPHI INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) INTEGER IAROTA(NSB) REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) ENDSEGMENT SEGMENT MTLIAB INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) REAL*8 XPALB(NLIAB,NXPALB) REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) ENDSEGMENT * * segment mtbas integer itbmod,lsstru(np1),nsstru endsegment LOGICAL L0,L1,RIGIDE,LMODYN CHARACTER*4 CMOT CHARACTER*8 TYPRET,CHARRE CHARACTER*40 MONMOT * MTKAM = KTKAM MTPHI = KTPHI MTLIAB = KTLIAB * NPLB = IBASB(/1) NSB = INMSB(/1) NA2 = XPHILB(/3) IDIMB = XPHILB(/4) NLIAB = IPALB(/1) * IA1 = 0 DEUXPI = 2.D0 * XPI RIGIDE =.FALSE. * * Traitement des matrices de variables g�n�ralis�es: * IF (ITBAS.NE.0 .AND.ITKM.EQ.0.AND.(.NOT.LMODYN)) THEN CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,MONMOT,L1,IP1) IF (IERR.NE.0) RETURN * * Cas o: la base est unique * IF (MONMOT(1:11).EQ.'BASE_MODALE') THEN * * On r�cup�re la base de modes * CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'MODES',L0,IP0, & 'TABLE',I1,X1,' ',L1,IBAS) IF (IERR.NE.0) RETURN CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,1,ICOMP, & RIGIDE,ITCARA,LMODYN) c IF (RIGIDE) THEN c RIGIDE =.FALSE. c DO 80 ILIA =1,NLIAB c ITYP = IPALB(ILIA,1) c IF (ITYP.EQ.35.OR.ITYP.EQ.36) THEN c RIGIDE =.TRUE. c ENDIF c 80 CONTINUE c ENDIF IF (IERR.NE.0) RETURN * * Cas o: on a un ensemble de bases * ELSE IF (MONMOT(1:17).EQ.'ENSEMBLE_DE_BASES') THEN * * On boucle sur le nombre de bases * IT = 0 NPLSB = 0 10 CONTINUE TYPRET = ' ' IT = IT + 1 CALL ACCTAB(ITBAS,'ENTIER',IT,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITTBAS) IF (IERR.NE.0) RETURN IF (ITTBAS.NE.0) THEN IF (TYPRET.EQ.'TABLE ') THEN CALL ACCTAB(ITTBAS,'MOT',IMODE,X0,'MODES',L0,IP0, & 'TABLE',I1,X1,' ',L1,IBAS) IF (IERR.NE.0) RETURN CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,IT,ICOMP, & RIGIDE,ITCARA,LMODYN) IF (IERR.NE.0) RETURN NPLSB = MAX(NPLSB,ICOMP) GOTO 10 ELSE CALL ERREUR(491) RETURN ENDIF ENDIF * le segadj n'est plus necessaire * on le fait dans dyne26 * MP * SEGADJ,MTPHI ENDIF * * ELSE IF (ITBAS.NE.0.AND.ITKM.NE.0) THEN * WRITE(IOIMP,*) * & 'DYNE : TBAS et TKM coexistent ---> @ impl�menter.' * IERR = 2 * RETURN * ELSE IF (LMODYN) THEN mtbas = itbas NPLSB = 0 do isstru = 1,nsstru CALL DYNE26(itbas,KTKAM,KTLIAB,KTPHI,IA1,isstru,ICOMP, & RIGIDE,ITCARA,LMODYN) IF (IERR.NE.0) RETURN NPLSB = MAX(NPLSB,ICOMP) enddo * * ELSE IF (ITKM.NE.0) THEN TYPRET = ' ' CALL ACCTAB(ITKM,'MOT',I0,X0,'RAIDEUR',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IRIGI) IF (IERR.NE.0) RETURN IF (IRIGI.NE.0 .AND. TYPRET.EQ.'RIGIDITE') THEN IA = 0 MRIGID = IRIGI SEGACT,MRIGID NRIGI = IRIGEL(/2) DO 20 I=1,NRIGI COEF = COERIG(I) xMATRI = IRIGEL(4,I) SEGACT,xMATRI NRIG = re(/3) DO 30 IRIG=1,NRIG * XMATRI = IMATTT(IRIG) * SEGACT,XMATRI LVAL = RE(/1) IN = 0 35 CONTINUE * * Partie diagonale seulement ... * IN = IN + 1 * NN = (IN * (IN + 1)) / 2 * IF (NN.LE.LVAL) THEN IF (IN.LE.LVAL) THEN IA = IA + 1 XK(IA) = RE(IN,IN,irig) * COEF GOTO 35 ENDIF * SEGDES,XMATRI 30 CONTINUE * end do SEGDES,xMATRI 20 CONTINUE * end do SEGDES,MRIGID ELSE CALL ERREUR(483) RETURN ENDIF * TYPRET = ' ' CALL ACCTAB(ITKM,'MOT',I0,X0,'MASSE',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IMASS) IF (IERR.NE.0) RETURN IF (IMASS.NE.0 .AND. TYPRET.EQ.'RIGIDITE') THEN IA = 0 MRIGID = IMASS SEGACT,MRIGID NMASS = IRIGEL(/2) DO 40 I=1,NMASS COEF = COERIG(I) xMATRI = IRIGEL(4,I) SEGACT,xMATRI NRIG = re(/3) DO 50 IRIG=1,NRIG * XMATRI = IMATTT(IRIG) * SEGACT,XMATRI LVAL = RE(/1) IN = 0 55 CONTINUE IN = IN + 1 * NN = (IN * (IN + 1)) / 2 * IF (NN.LE.LVAL) THEN IF (IN.LE.LVAL) THEN IA = IA + 1 XM(IA) = RE(IN,IN,irig) * COEF GOTO 55 ENDIF * SEGDES,XMATRI 50 CONTINUE * end do SEGDES,xMATRI 40 CONTINUE * end do SEGDES,MRIGID ELSE CALL ERREUR(484) RETURN ENDIF ENDIF * * Traitement de la matrice d'amortissement * IF (ITA.NE.0) THEN if (lmodyn) then iamor = ita typret='RIGIDITE' else TYPRET = ' ' CALL ACCTAB(ITA,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IAMOR) IF (IERR.NE.0) RETURN endif IF (IAMOR.NE.0 .AND. TYPRET.EQ.'RIGIDITE') THEN IA = 0 MRIGID = IAMOR SEGACT,MRIGID NAMOR = IRIGEL(/2) DO 60 I=1,NAMOR COEF = COERIG(I) xMATRI = IRIGEL(4,I) SEGACT,xMATRI NRIG = re(/3) DO 70 IRIG=1,NRIG * XMATRI = IMATTT(IRIG) * SEGACT,XMATRI LVAL = RE(/1) IN = 0 75 CONTINUE IN = IN + 1 * NN = (IN * (IN + 1)) / 2 * IF (NN.LE.LVAL) THEN IF (IN.LE.LVAL) THEN IA = IA + 1 XASM(IA) = RE(IN,IN,irig) * COEF GOTO 75 ENDIF * SEGDES,XMATRI 70 CONTINUE * end do SEGDES,xMATRI 60 CONTINUE * end do SEGDES,MRIGID ELSE CALL ERREUR(485) RETURN ENDIF ENDIF * IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)' segment MTPHI' WRITE(IOIMP,*)'DEVTRA : valeur de NPLB :',IBASB(/1) WRITE(IOIMP,*)'DEVTRA : valeur de NSB :',XPHILB(/1) WRITE(IOIMP,*)'DEVTRA : valeur de NPLSB :',XPHILB(/2) WRITE(IOIMP,*)'DEVTRA : valeur de NA2 :',XPHILB(/3) WRITE(IOIMP,*)'DEVTRA : valeur de IDIMB :',XPHILB(/4) ENDIF * END