C HBMTRA SOURCE OF166741 26/05/11 21:15:16 12538 *--------------------------------------------------------------------* * * * Operateur DYNC * * ________________________________________________ * * * * Transpose l'information des objets de Castem2000 dans des * * tableaux de travail. * * * * Parametres: * * * * e ITBAS Table representant 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 reference pour les CHPOINTs resultats * * es KTRES Segment de sauvegarde des resultats * * e KPREF Segment des points de reference * * es KTPHI Segment des deformees modales * * e KTLIAB Segment des liaisons sur base B * * e RIGIDE Vrai si corps rigide, faux sinon * * * *--------------------------------------------------------------------* SUBROUTINE HBMTRA(ITBAS,ITKM,ITA,KTKAM,IPMAIL,NHBM,KTRES,KTNUM, & KPREF,KTPHI,KTLIAB,RIGIDE) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCREEL -INC SMRIGID -INC SMCOORD -INC SMELEME -INC TMDYNC LOGICAL L0,L1,RIGIDE CHARACTER*4 CMOT,MOINC CHARACTER*8 TYPRET,CHARRE CHARACTER*40 MONMOT * MTKAM = KTKAM MTPHI = KTPHI MTLIAB = KTLIAB MPREF = KPREF MTNUM = KTNUM * dimensions de MTPHI NPLB = IBASB(/1) NSB = INMSB(/1) NA2 = XPHILB(/3) IDIMB = XPHILB(/4) NLIAB = IPALB(/1) * dimensions de MTKAM NA1 = XASM(/1) NB1K = XK(/2) NB1C = XASM(/2) NB1M = XM(/2) * dimensions de MTQ * NT1 = NA1*(2*NHBM+1) NPREF=IPOREF(/1) * IA1 = 0 DEUXPI = 2.D0 * XPI RIGIDE =.FALSE. * * Traitement des matrices de variables generalisees: * IF (ITBAS.NE.0 .AND.ITKM.EQ.0) THEN IF (IIMPI.EQ.333) & WRITE(IOIMP,*) 'HBMTRA: cas table BASE_DE_MODES, quel type?' CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,MONMOT,L1,IP1) IF (IERR.NE.0) RETURN * * Cas ou la base est unique * IF (MONMOT(1:11).EQ.'BASE_MODALE') THEN IF (IIMPI.EQ.333) & WRITE(IOIMP,*) 'HBMTRA: lecture table BASE_MODALE' * * On recupere la base de modes * CALL ACCTAB(ITBAS,'MOT',IMODE,X0,'MODES',L0,IP0, & 'TABLE',I1,X1,' ',L1,IBAS) IF (IERR.NE.0) RETURN CALL HBM26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,1,ICOMP,RIGIDE,ITKM) * CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,1,ICOMP,RIGIDE, * & 0,.false.,ITKM) IF (RIGIDE) THEN RIGIDE =.FALSE. DO 80 ILIA =1,NLIAB ITYP = IPALB(ILIA,1) IF (ITYP.EQ.35.OR.ITYP.EQ.36) THEN RIGIDE =.TRUE. ENDIF 80 CONTINUE ENDIF IF (IERR.NE.0) RETURN * * Cas ou on a un ensemble de bases * ELSE IF (MONMOT(1:17).EQ.'ENSEMBLE_DE_BASES') THEN IF (IIMPI.EQ.333) & WRITE(IOIMP,*) 'HBMTRA: lecture table ENSEMBLE_DE_BASES' * * 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 HBM26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,IT,ICOMP, & RIGIDE,ITKM) * CALL DYNE26(IBAS,KTKAM,KTLIAB,KTPHI,IA1,IT,ICOMP, * & RIGIDE,0,.false.,ITKM) IF (IERR.NE.0) RETURN NPLSB = MAX(NPLSB,ICOMP) GOTO 10 ELSE CALL ERREUR(491) RETURN ENDIF ENDIF ENDIF * ELSE IF (ITKM.NE.0) THEN * cas table RAIDEUR_ET_MASSE non prevu pour l'instant CALL ERREUR(491) RETURN ENDIF * * Traitement de la matrice d'amortissement * IF (ITA.NE.0) THEN IF (IIMPI.EQ.333) & WRITE(IOIMP,*) 'HBMTRA: cas table AMORTISSEMENT' TYPRET = ' ' CALL ACCTAB(ITA,'MOT',I0,X0,'AMORTISSEMENT',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IAMOR) IF (IERR.NE.0) RETURN IF (IAMOR.NE.0 .AND. TYPRET.EQ.'RIGIDITE') THEN IF (IIMPI.EQ.333) & WRITE(IOIMP,*) 'HBMTRA: lecture table AMORTISSEMENT ok' MRIGID = IAMOR SEGACT,MRIGID NAMOR = IRIGEL(/2) DO 60 I=1,NAMOR COEF = COERIG(I) c write(ioimp,*) 'HBMTRA: sous rigidite ',I,'/',NAMOR,COEF MELEME = IRIGEL(1,I) DESCR = IRIGEL(3,I) XMATRI = IRIGEL(4,I) SEGACT,DESCR,MELEME,XMATRI NRIG = RE(/3) LVAL = RE(/1) DO 70 IRIG=1,NRIG c write(ioimp,*) 'HBMTRA: + element',IRIG,'/',NRIG c boucle sur les lignes (ddls duals) DO 75 IN=1,LVAL INODE=NOELED(IN) IF(INODE.ne.NOELEP(IN)) THEN WRITE(IIOMP,*) 'Incoherence entre les inconnues', & 'primales et duales de la matrice AMORTISSEMENT' CALL ERREUR(47) RETURN ENDIF NNODE=NUM(INODE,IRIG) c write(ioimp,*) 'HBMTRA: + noeud dual',IN,'/',LVAL,' #',NNODE c position de cette inconnue dans IPOREF de MPREF DO 76 IA=1,NPREF IF (IPOREF(IA).EQ.NNODE) GOTO 79 76 CONTINUE write(ioimp,*) 'HBMTRA: Incoherence entre les ', & 'points de reference et la matrice AMORTISSEMENT' CALL ERREUR(504) 79 CONTINUE c write(ioimp,*) 'HBMTRA: + noeud dual trouve en position',IA * Partie diagonale seulement ... XASM(IA,1) = XASM(IA,1) + (RE(IN,IN,IRIG) * COEF) 75 CONTINUE 70 CONTINUE SEGDES,XMATRI,MELEME,DESCR 60 CONTINUE SEGDES,MRIGID ELSE CALL ERREUR(485) RETURN ENDIF ENDIF * IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)' segment MTPHI' WRITE(IOIMP,*)'HBMTRA : valeur de NPLB :',IBASB(/1) WRITE(IOIMP,*)'HBMTRA : valeur de NSB :',XPHILB(/1) WRITE(IOIMP,*)'HBMTRA : valeur de NPLSB :',XPHILB(/2) WRITE(IOIMP,*)'HBMTRA : valeur de NA2 :',XPHILB(/3) WRITE(IOIMP,*)'HBMTRA : valeur de IDIMB :',XPHILB(/4) WRITE(IOIMP,*)' segment MTKAM' WRITE(IOIMP,*)'NA1,NB1K,NB1C,NB1M=',NA1,NB1K,NB1C,NB1M if(NB1K.gt.1) then do iou=1,NA1 WRITE(IOIMP,*) 'XK=',(XK(iou,jou),jou=1,NB1K) enddo else do iou=1,NA1 WRITE(IOIMP,*) 'XK(',iou,',1)=',XK(iou,1) enddo endif if(NB1C.gt.1) then do iou=1,NA1 WRITE(IOIMP,*) 'XASM=',(XASM(iou,jou),jou=1,NB1C) enddo else do iou=1,NA1 WRITE(IOIMP,*) 'XASM(',iou,',1)=',XASM(iou,1) enddo endif if(NB1M.gt.1) then do iou=1,NA1 WRITE(IOIMP,*) 'XM=',(XM(iou,jou),jou=1,NB1M) enddo else do iou=1,NA1 WRITE(IOIMP,*) 'XM(',iou,',1)=',XM(iou,1) enddo endif ENDIF RETURN END