C RECOMB SOURCE FANDEUR 10/12/14 21:19:14 6812 SUBROUTINE RECOMB IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *_______________________________________________________________________ * * OPERATEUR RECO : * RECOMBINAISON EN ANALYSE MODALE. * SYNTAXE: * ======= * ******** B EST UNE BASE ELEMENTAIRE * ---------------- * X1 = RECO XA B DEPL; * X2 = RECO XA B CONT; * * ******** B EST UNE BASE COMPLEXE: STR1 EST LA STRUCTURE * ------------- POUR LAQUELLE LA * RECOMBINAISON S'EFFECTUE, ET N LE NUMERO DE * LA SOUS-STRUCTURE SI CELLE CI EST FORMEE DE * SOUS-STRUCTURES IDENTIQUES. * X1 = RECO XA B STR1 (N) DEPL ; * X2 = RECO XA B STR1 (N) CONT ; * * XA : OBJET CHPOINT CONTENANT LES CONTRIBUTIONS MODALES * DEPL : ON RECOMBINE DES DEPLACEMENTS. X1 EST UN CHPOINT * CONT : ON RECOMBINE DES CONTRAINTES . X2 EST UN CHELEM * * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91 * *_______________________________________________________________________ * -INC CCOPTIO -INC CCREEL -INC SMBASEM -INC SMCHPOI -INC SMLCHPO -INC SMLREEL -INC SMSOLUT -INC SMSTRUC LOGICAL L0,L1 PARAMETER ( LMOOPT = 5 , IUN = 1 ) CHARACTER*4 MOOPT(LMOOPT) CHARACTER*(8) ITYPE,CTYP DATA MOOPT/'DEPL','CONT','VITE','ACCE','REAC'/ * CALL LIRTAB('LIAISONS_STATIQUES',itst,0,iretst) if (iretst.ne.0) then CALL LIRTAB('BASE_MODALE',itbm,0,iretbm) if (ierr.ne.0) return if (iretst.ne.0.or.iretbm.ne.0) then call lirobj('CHPOINT ',ichp1,0,iret) if (iret.ne.0) then call recof1(itst,itbm,ichp1,ipout) if (ierr.ne.0) return call ecrobj('CHPOINT ',ipout) return endif endif endif CALL LIROBJ('MMODEL',IPMODL,0,IRET) IF (IRET.NE.0) THEN CALL LIROBJ('MCHAML',IPCHA1,1,IRET1) if (ierr.ne.0) return if (iret1.ne.0) then call lirobj('CHPOINT ',ichp1,0,iret) if (ierr.ne.0) return if (ichp1.eq.0) then CALL LIRTAB('PASAPAS',ITRES,1,IRET) if (ierr.ne.0) return CALL LIRMOT(MOOPT,LMOOPT,IMOO,1) IF(IERR.NE.0) RETURN call repec2(itres,imoo,ichp1) if (ierr.ne.0) return endif call recof2(ipmodl,ipcha1,ichp1,ipout) if (ierr.ne.0) return call ecrobj('CHPOINT ',ipout) return endif ENDIF CALL LIRMOT(MOOPT,LMOOPT,IMOO,1) IF(IERR.NE.0) RETURN KPSMO = 0 KCHAR = 0 KCHLIA = 0 ITLIA = 0 XTEMP = 0.D0 * CALL QUETYP(CTYP,1,IRETOU) * IF (CTYP(1:8).EQ.'TABLE ') THEN CALL LIRTAB('RESULTAT_DYNE',ITRES,1,IRET) IF (IERR.NE.0) RETURN CALL LIRTAB('BASE_MODALE',ITBAS,0,IRET) IF (IRET.EQ.0) THEN CALL LIRTAB('ENSEMBLE_DE_BASES',ITBAS,1,IRET) ENDIF IF (IERR.NE.0) RETURN CALL LIRREE(XTEMP,1,IRET) IF (IERR.NE.0) RETURN XMPE = -XPETIT IF (XTEMP.LT.XMPE) THEN CALL ERREUR(431) RETURN ENDIF CALL LIROBJ('CHARGEME',KCHAR,0,IRET) CALL LIRTAB('LIAISON',ITLIA,0,IRET) * * R{cup{ration du CHPOINT @ l'instant XTEMP * CALL ACCTAB(ITRES,'MOT',I0,X0,'TEMPS_DE_SORTIE',L0,IP0, & 'LISTREEL',I1,X1,' ',L1,LBO) MLREEL = LBO SEGACT MLREEL LTE = PROG(/1) PRECI = (PROG(LTE) - PROG(1)) / (LTE * 100) CALL PLACE3(PROG,IUN,LTE,XTEMP,IR,AR) IF (AR.LE.PRECI) THEN IPOS = IR ELSE ARR = ABS(1. - AR) IF (ARR.LE.PRECI) THEN IPOS = IR + 1 ELSE MOTERR(1:8) = 'TABLE ' MOTERR(9:16) ='LISTREEL' CALL ERREUR(135) SEGDES MLREEL RETURN ENDIF ENDIF SEGDES MLREEL * CALL ACCTAB(ITRES,'ENTIER',IPOS,X0,' ',L0,IP0, & 'TABLE',I1,X1,' ',L1,ITDEP) IF (MOOPT(IMOO).EQ.'DEPL') THEN CALL ACCTAB(ITDEP,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPT) CALL RCDEPL(ITBAS,ICHPT,KCHAR,XTEMP,ITRES,IPOS,ITLIA,0) ELSE IF (MOOPT(IMOO).EQ.'VITE') THEN CALL ACCTAB(ITDEP,'MOT',I0,X0,'VITESSE',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPT) CALL RCDEPL(ITBAS,ICHPT,KCHAR,XTEMP,ITRES,IPOS,ITLIA,1) ELSE IF (MOOPT(IMOO).EQ.'ACCE') THEN CALL ACCTAB(ITDEP,'MOT',I0,X0,'ACCELERATION',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPT) CALL RCDEPL(ITBAS,ICHPT,KCHAR,XTEMP,ITRES,IPOS,ITLIA,-1) ELSE IF (MOOPT(IMOO).EQ.'REAC') THEN CALL ACCTAB(ITDEP,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPT) CALL RCDEPL(ITBAS,ICHPT,KCHAR,XTEMP,ITRES,IPOS,ITLIA,2) ELSE CALL ACCTAB(ITDEP,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPT) CALL RCCONT(ITBAS,ICHPT,KCHAR,XTEMP,ITRES,IPOS,ITLIA) ENDIF RETURN ENDIF *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+* * version appel{e @ disparaitre *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+* CALL LIROBJ('CHPOINT ',ICH1,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRREE(XTEMP,0,IRETOU) IF (IRETOU.EQ.1) THEN KPSMO = 1 CALL LIROBJ('CHPOINT ',KCHLIA,0,IRETOU) CALL LIROBJ('CHARGEME',KCHAR,0,IRETOU) ENDIF CALL LIROBJ ('BASEMODA',IP2,1,IRETOU) IF(IERR.NE.0) RETURN C C **** ON VERIFIE QUE LE CHPOINT CONTIENT LES CONTRIBUTIONS MODALES C MCHPOI = ICH1 SEGACT MCHPOI NSOUPO = IPCHP(/1) DO 1 ISOU = 1,NSOUPO MSOUPO = IPCHP(ISOU) SEGACT MSOUPO IF (NOCOMP(/2).NE.1) THEN C ON CHERCHE UN CHPOINT QUI CONTIENT DES CONTIBUTIONS MODALES CALL ERREUR(188) RETURN ENDIF IF (NOCOMP(1).NE.'ALFA') THEN C ON CHERCHE ........ CALL ERREUR(188) SEGDES MSOUPO RETURN ENDIF SEGDES MSOUPO 1 CONTINUE SEGDES MCHPOI * MBASEM = IP2 SEGACT MBASEM NBAS = LISBAS(/1) IP4 = 1 IF (NBAS.NE.1) THEN C BASE COMPLEXE CALL LIROBJ('STRUCTUR',IRET,1,IRETOU) IF( IERR.NE.0 ) RETURN MSTRUC = IRET SEGACT MSTRUC NSTRU = LISTRU(/1) MSOSTU = LISTRU(1) IP3 = 1 IF (NSTRU.NE.1) THEN C STRUCTURE COMPLEXE CALL LIRENT(IP3,1,IRETOU) IF (IERR.NE.0) RETURN C ON VERIFIE QU'IL S'AGIT DE SOUS-STRUCTURES IDENTIQUES SEGACT MSOSTU ISRAI1 = ISRAID SEGDES MSOSTU DO 14 NS = 2,NSTRU MSOSTU = LISTRU(NS) SEGACT MSOSTU IF (ISRAI1.NE.ISRAID) RETURN SEGDES MSOSTU 14 CONTINUE IF (IP3.EQ.0 .OR. IP3.GT.NSTRU) THEN CALL ERREUR(216) RETURN ENDIF MSOSTU = LISTRU(IP3) ENDIF SEGDES MSTRUC C ON VERIFIE QUE LA SOUS-STRUCTURE EST DANS LA BASE DO 16 NB = 1,NBAS MSOBAS = LISBAS(NB) SEGACT MSOBAS IP4 = NB IF (IBSTRM(1).EQ.MSOSTU) GOTO 17 SEGDES MSOBAS 16 CONTINUE C *** INCOHERENCE ENTRE LA BASE ET LA STRUCTURE CALL ERREUR(216) RETURN 17 CONTINUE ENDIF MSOBAS = LISBAS(IP4) SEGDES MBASEM SEGACT MSOBAS IBMODE = IBSTRM(2) IBSOLS = IBSTRM(3) IBPSMO = IBSTRM(5) IRET = 0 IRET1 = 0 IRET2 = 0 * IF (IMOO.EQ.2) THEN * * RECOMBINAISON DE CONTRAINTES * READ (MOOPT(2),FMT='(A4)') MOCON IF (IBMODE.NE.0) THEN MSOLUT = IBMODE SEGACT MSOLUT KMEL1 = MSOLIS(3) KCON = MSOLIS(6) SEGDES MSOLUT IF (KCON.EQ.0) THEN MOTERR(1:8) = ITYSOL CALL ERREUR(61) RETURN ENDIF CALL RCOSIG(ICH1,KCON,KMEL1,IRET1) IF( IERR.NE.0 ) RETURN IF (IBSOLS.EQ.0) IRET = IRET1 ENDIF IF (IBSOLS.NE.0) THEN MSOLUT = IBSOLS SEGACT MSOLUT KMEL1 = MSOLIS(3) KCON = MSOLIS(6) SEGDES MSOLUT IF (KCON.EQ.0) THEN MOTERR(1:8) = ITYSOL CALL ERREUR(61) RETURN ENDIF CALL RCOSIG(ICH1,KCON,KMEL1,IRET2) IF( IERR.NE.0 ) RETURN IF (IRET1.NE.0) THEN ICONV=0 CALL ADCHEL(IRET1,IRET2,IRET,IUN) ELSE IRET = IRET2 ENDIF ENDIF IF (IRET.EQ.0) RETURN ITYPE = 'CHAMELEM' ELSE * * RECOMBINAISON DE DEPLACEMENTS * READ (MOOPT(1),FMT='(A4)') MODEPL IF (IBMODE.NE.0) THEN MSOLUT = IBMODE SEGACT MSOLUT KDEPL = MSOLIS(5) KMEL1 = MSOLIS(3) SEGDES MSOLUT IF (KDEPL.EQ.0) THEN MOTERR(1:8) = ITYSOL CALL ERREUR(61) RETURN ENDIF CALL RCODP1(ICH1,KDEPL,KMEL1,IRET1) IF (IERR.NE.0) RETURN IF (IBSOLS.EQ.0) IRET = IRET1 ENDIF IF (IBSOLS.NE.0) THEN MSOLUT = IBSOLS SEGACT MSOLUT KDEPL = MSOLIS(5) KMEL1 = MSOLIS(3) SEGDES MSOLUT IF (KDEPL.EQ.0) THEN MOTERR(1:8) = ITYSOL CALL ERREUR(61) RETURN ENDIF CALL RCODP1(ICH1,KDEPL,KMEL1,IRET2) IF (IERR.NE.0) RETURN IF (IRET1.NE.0) THEN CALL ADCHPO(IRET1,IRET2,IRET,1D0,1D0) IF( IERR.NE.0 ) RETURN ELSE IRET = IRET2 ENDIF ENDIF IF (IRET.EQ.0) RETURN ITYPE = 'CHPOINT ' ENDIF * * PRIS EN COMPTE DES PSEUDO-MODES * IF (KPSMO.NE.0) THEN CALL PSRECO(IBMODE,IBPSMO,MOOPT(IMOO),KCHAR,KCHLIA,XTEMP,IRET) ENDIF * SEGDES MSOBAS CALL ECROBJ (ITYPE,IRET) * RETURN END