C PSEVRC SOURCE FANDEUR 10/12/14 21:18:59 6812 SUBROUTINE PSEVRC(ICONT,ITPS,IBAS,IBOO,IPX,KCHAR) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Prise en compte des pseudo-modes pour une recombinaison. * * * * Param}tres: * * * * e ICONT recombinaison d'un d{placement ( ICONT = 0 ) * * recombinaison d'une contrainte ( ICONT = 1 ) * * recombinaison d'une r{action ( ICONT = 2 ) * * e ITPS table repr{sentant les pseudo-modes * * e IBAS table repr{sentant la base modale * * es IBOO segment des points en recombinaison * * e IPX listreel des temps de recombinaison * * e KCHAR chargement de la structure * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 2 mai 1990. * * * *--------------------------------------------------------------------* * * -INC CCOPTIO -INC SMCHARG -INC SMCHPOI -INC SMLREEL * SEGMENT NUMOO INTEGER NUMO(N),KLIST(N) CHARACTER*4 NUDDL(N) ENDSEGMENT LOGICAL L0,L1 CHARACTER*4 COMP CHARACTER*8 TYPRET,CHARRE CHARACTER*40 CMOT PARAMETER (TOLER = 1.D-6) * NUMOO = IBOO SEGACT NUMOO NP = NUMO(/1) DO 2 I = 1,NP MLREE3 = KLIST(I) SEGACT MLREE3*MOD 2 CONTINUE * MLREEL= IPX SEGACT MLREEL LDIM = PROG(/1) * MCHARG = KCHAR SEGACT MCHARG NCHAR = KCHARG(/1) * * Boucle sur les pseudo-modes * IPS = 0 10 CONTINUE IPS = IPS + 1 TYPRET = ' ' CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITPM) IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0, & 'MOT',I1,X1,CMOT,L1,IP1) IF (CMOT(1:9).EQ.'PSMO_FORC') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHBB) * * boucle sur les chargements {l{mentaires * DO 20 ICHA =1,NCHAR ICHARG = KCHARG(ICHA) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT' & .OR.CHALIE(ICHA).NE.'LIE ') THEN SEGDES ICHARG GOTO 20 ENDIF IF (ICHBB.EQ.ICHPO1) GOTO 100 20 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) SEGDES ICHARG GOTO 10 ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0, & 'ENTIER',IENT,X1,' ',L1,IP1) CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0, & 'TABLE',I1,X1,' ',L1,ITMK) CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES', & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD) CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0, & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1) * * boucle sur les chargements {l{mentaires * DO 30 ICHA =1,NCHAR ICHARG = KCHARG(ICHA) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT' & .OR.CHALIE(ICHA).NE.'LIE ') THEN SEGDES ICHARG GOTO 30 ENDIF MCHPOI = ICHPO1 SEGACT MCHPOI MSOUPO = IPCHP(1) SEGDES MCHPOI SEGACT MSOUPO MPOVAL = IPOVAL SEGDES MSOUPO SEGACT MPOVAL QXYZ = VPOCHA(1,1) SEGDES MPOVAL EPS = ABS(QXYZ + XQXYZ) IF (EPS.LT.TOLER) GOTO 100 30 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) SEGDES ICHARG GOTO 10 ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHBB) * * boucle sur les chargements {l{mentaires * DO 40 ICHA =1,NCHAR ICHARG = KCHARG(ICHA) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT' & .OR.CHALIE(ICHA).NE.'LIE ') THEN SEGDES ICHARG GOTO 40 ENDIF IF (ICHBB.EQ.ICHPO1) GOTO 100 40 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) SEGDES ICHARG GOTO 10 ENDIF * 100 CONTINUE ICDEP = 0 IF (ICONT.EQ.0) THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ELSE IF (ICONT.EQ.1) THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0, & 'MCHAML ',I1,X1,' ',L1,ICHAM1) C* Manque le passage en MCHAML aux noeuds avec le modele !!! C* CALL CHASUP(IPMODL,ICHAM1,ICHAM2,IRETOU,1) C* IF (IRETOU.EQ.0) THEN C* INTERR(1) = IPS C* CALL ERREUR(___) C* SEGDES ICHARG C* GOTO 10 C* ENDIF C* CALL CHAMPO(ICHAM2,2,ICDEP,IRETOU) CALL CHAMPO(ICHAM1,2,ICDEP,IRETOU) IF (IRETOU.EQ.0) THEN INTERR(1) = IPS CALL ERREUR(428) SEGDES ICHARG GOTO 10 ENDIF ELSE IF (ICONT.EQ.2) THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ENDIF MLREE1 = ICHPO2 SEGACT MLREE1 NF = MLREE1.PROG(/1) MLREE2 = ICHPO3 SEGACT MLREE2 IF (IIMPI.EQ.1804) THEN WRITE(IOIMP,*)'PSEVRC : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'PSEVRC : chargement ',KCHAR WRITE(IOIMP,*)'PSEVRC : num{ro ',ICHA ENDIF N1 = 1 N2 = 2 DO 110 IT = 1,LDIM XTEMP = PROG(IT) CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU) IF (IRETOU.EQ.0) THEN INTERR(1) = IPS CALL ERREUR(428) SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG GOTO 10 ENDIF IF (IIMPI.EQ.1804) THEN WRITE(IOIMP,*)'PSEVRC : temps ',XTEMP WRITE(IOIMP,*)'PSEVRC : f(t) ',XFTEM ENDIF * DO 120 IP = 1,NP IPOIN = NUMO(IP) COMP = NUDDL(IP) CALL EXTRA9(ICDEP,IPOIN,COMP,KERRE,XFLOT) IF (KERRE.NE.0) THEN INTERR(1) = IPS CALL ERREUR(428) SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG GOTO 10 ENDIF XVAL = XFLOT * XFTEM IF (IIMPI.EQ.1804) THEN WRITE(IOIMP,*)'PSEVRC : au point ',IPOIN WRITE(IOIMP,*)'PSEVRC : de composante ',COMP WRITE(IOIMP,*)'PSEVRC : valeur calcul{e ',XVAL ENDIF MLREE3 = KLIST(IP) MLREE3.PROG(IT) = MLREE3.PROG(IT) + XVAL 120 CONTINUE 110 CONTINUE SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG GOTO 10 ENDIF * SEGDES MCHARG SEGDES MLREEL DO 4 I = 1,NP MLREE3 = KLIST(I) SEGDES MLREE3 4 CONTINUE IBOO = NUMOO * IF (ICONT.EQ.1) THEN MCHPO1 = ICDEP SEGSUP MCHPO1 ENDIF * RETURN END