C CRTBAS SOURCE JC220346 12/09/13 21:15:07 7504 SUBROUTINE CRTBAS(IPSOLU,IPMASS) C*********************************************************************** C C C R T B A S C ----------- C C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRATION" C C FONCTION: C --------- C C CREATION D'UNE TABLE DE TYPE BASE_MODALE COMME SORTIE C DE L'OPERATEUR "VIBRATION" C C ARGUMENTS D'ENTREE: C ------------------ C C IPSOLU = POINTEUR SUR L'OBJET SOLUTION C IPMASS = POINTEUR SUR LA MATRICE MASSE C C DESCRIPTION DE LA TABLE BASE_MODALE CREE: C ---------------------------------------- C C TAB1 = 'TABLE' 'BASE_MODALE' ( POINTEUR IPTAB1 ) C TAB2 = 'TABLE' 'BASE_DE_MODES' ( POINTEUR IPTAB2 ) C DE MEME STRUCTURE QUE CELLE ISSUE DE LA PROCEDURE C TRADUIRE. C TAB3 = 'TABLE' 'MODE' ( POINTEUR IPTAB3 ) C TAB4 = 'TABLE' 'DEPLACEMENTS_GENERALISES' ( POINTEUR IPTAB4 ) C C ---------------------------------------- C C TAB1.'SOUSTYPE' = 'BASE_MODALE' C TAB1.'MODES' = IPTAB2 C C TAB2.'SOUSTYPE' = 'BASE_DE_MODES' C TAB2.'MAILLAGE' = IPG1 ( POINTEUR SUR LE C MAILLAGE EXTRAIT DE LA MATRICE C MASSE ) C C PUIS POUR CHAQUE MODE IMOD1 CONTENU DANS L'OBJET SOLUTION C C TAB3.'SOUSTYPE' = 'MODE' C TAB4.'SOUSTYPE' = 'DEPLACEMENTS_GENERALISES' C C TAB4.1 = QX DU MODE C TAB4.2 = QY DU MODE C TAB4.3 = QZ DU MODE C C TAB3.'NUMERO_MODE' = NUME1 ( NUMERO DU MODE ) C TAB3.'POINT_REPERE' = IPOIN1 ( NUMERO DU POINT ASSOCIE C AU MODE ) C TAB3.'FREQUENCE' = FREQ1 DU MODE C TAB3.'MASSE_GENERALISEE' = XMGEN1 DU MODE C TAB3.'DEPLACEMENTS_GENERALISES' = IPTAB4 C TAB3.'DEFORMEE_MODALE' = IPDEP1 ( POINTEUR SUR LE CHAMP C DE DEPLACEMENTS DU MODE ) C C TAB2.IMOD1 = IPTAB3 C C C AUTEUR, DATE DE CREATION: C ------------------------- C C NADINE BLAY 21 OCTOBRE 1991 C C*********************************************************************** C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C -INC CCOPTIO C -INC SMSOLUT -INC SMRIGID -INC SMTABLE -INC SMELEME -INC SMLREEL -INC SMLENTI CHARACTER*8 letyp,charre LOGICAL boolin,ltelq C C--- RECUPERATION DU MAILLAGE DANS LA MATRICE MASSE C MRIGID=IPMASS SEGACT MRIGID NBSOUS=IRIGEL(/2) IPG1=IRIGEL(1,1) C IF(NBSOUS.GT.1) THEN DO 10 I=2,NBSOUS IPP2=IRIGEL(1,I) ltelq=.false. CALL FUSE(IPG1,IPP2,IRET,ltelq) IPG1=IRET 10 CONTINUE ENDIF SEGDES MRIGID C C--- CREATION DE LA TABLE BASE_DE_MODES C CALL CRTABL(IPTAB2) CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, # 'MOT',0,0.D0,'BASE_DE_MODES',.TRUE.,0) CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0, # 'MAILLAGE',0,0.D0,' ',.TRUE.,IPG1) C C--- EXTRACTION DES INFORMATIONS DE L'OBJET SOLUTION C MSOLUT=IPSOLU SEGACT MSOLUT C MSOLE1=MSOLIS(4) * si l'objet solution n'est pas vide if (msole1.ne.0) then SEGACT MSOLE1 NBMOD1=MSOLE1.ISOLEN(/1) C MSOLE2=MSOLIS(5) SEGACT MSOLE2 C DO 20 I=1,NBMOD1 IMOD1=I C C--- CREATION DE LA TABLE MODE C CALL CRTABL(IPTAB3) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, # 'MOT',0,0.D0,'MODE',.TRUE.,0) C C--- CREATION DE LA TABLE DEPLACEMENTS_GENERALISES C CALL CRTABL(IPTAB4) CALL ECCTAB(IPTAB4,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, # 'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES',.TRUE.,0) C MMODE=MSOLE1.ISOLEN(IMOD1) SEGACT MMODE C NUME1=IMMODD(1) FRQ1=FMMODD(1) XMGEN1=FMMODD(2) QX1=FMMODD(3) QY1=FMMODD(4) QZ1=FMMODD(5) C MELEME=MSOLIS(3) SEGACT MELEME IPOIN1=NUM(1,IMOD1) SEGDES MELEME C IPDEP1=MSOLE2.ISOLEN(IMOD1) C C--- REMPLISSAGE DE LA TABLE DEPLACEMENTS_GENERALISES C CALL ECCTAB(IPTAB4,'ENTIER',1,0.D0,' ',.TRUE.,0, # 'FLOTTANT',0,QX1,' ',.TRUE.,0) CALL ECCTAB(IPTAB4,'ENTIER',2,0.D0,' ',.TRUE.,0, # 'FLOTTANT',0,QY1,' ',.TRUE.,0) CALL ECCTAB(IPTAB4,'ENTIER',3,0.D0,' ',.TRUE.,0, # 'FLOTTANT',0,QZ1,' ',.TRUE.,0) C C--- REMPLISSAGE DE LA TABLE MODE C CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0, # 'ENTIER',NUME1,0.D0,' ',.TRUE.,0) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0, # 'POINT',0,0.D0,' ',.TRUE.,IPOIN1) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'FREQUENCE',.TRUE.,0, # 'FLOTTANT',0,FRQ1,' ',.TRUE.,0) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0, # 'FLOTTANT',0,XMGEN1,' ',.TRUE.,0) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES', # .TRUE.,0,'TABLE',0,0.D0,' ',.TRUE.,IPTAB4) CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEFORMEE_MODALE',.TRUE.,0, # 'CHPOINT',0,0.D0,' ',.TRUE.,IPDEP1) C C--- SUITE DU REMPLISSAGE DE LA TABLE BASE_DE_MODES C CALL ECCTAB(IPTAB2,'ENTIER',IMOD1,0.D0,' ',.TRUE.,0, # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB3) C SEGDES MMODE 20 CONTINUE C C SEGDES MSOLE1 SEGDES MSOLE2 SEGDES MSOLUT endif * * tri selon les frequences jg = 10000 segini mlreel,mlenti do 350 i = 1, 10000 letyp=' ' call acctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin, $ letyp,ivalre,xvalre,charre,boolin,mtab2) if(letyp.ne.'TABLE ') go to 351 lect(i) = mtab2 call acctab (mtab2,'MOT ',iva,xva,'FREQUENCE',boolin,iobin, $ 'FLOTTANT',ivalre,xvalre,charre,boolin,ioboi) prog(i) = xvalre 350 continue 351 jg = i - 1 segadj mlreel,mlenti call ecrobj('LISTENTI',mlenti) call ecrobj('LISTREEL',mlreel) call ORDONN call lirobj('LISTREEL',mlreel,1,IRETOU) call lirobj('LISTENTI',mlenti,1,IRETOU) IF (IERR.NE.0) RETURN segact mlenti do i = 1,jg mtab2 = lect(i) call ecctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin, $ 'TABLE ',ivalre,xvalre,charre,boolin,mtab2) enddo C C--- CREATION DE LA TABLE BASE_MODALE C CALL CRTABL(IPTAB1) CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0, # 'MOT',0,0.D0,'BASE_MODALE',.TRUE.,0) CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'MODES',.TRUE.,0, # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB2) CALL ECROBJ('TABLE',IPTAB1) C END