C PSRCD2 SOURCE FANDEUR 10/12/14 21:19:00 6812 SUBROUTINE PSRCD2(TYPE,ITPS,IBAS,ICHCR,KCHAR,XTEMP,ITRES,IPOS, & ITLIA) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Prise en compte des pseudo-modes pour une recombinaison. * * * * Param}tres: * * * * e TYPE recombinaison d'une contrainte ou d'un d{placement * * ou d'une r{action * * e ITPS table repr{sentant les pseudo-modes * * e IBAS table repr{sentant la base modale * * es ICHCR nouveau chamelem ou chpoint * * e KCHAR chargement de la structure * * e XTEMP temps de recombinaison * * e ITRES table issue de l'op{rateur DYNE * * e IPOS position de XTEMP dans le listreel des temps * * e ITLIA table des liaisons * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 18 avril 1990. * * * * Passage aux nouveaux mchamls par jm CAMPENON le 01/91 * * * *--------------------------------------------------------------------* * * -INC CCOPTIO -INC CCREEL *- -INC SMCHARG -INC SMCHPOI -INC SMCOORD -INC SMELEME -INC SMLREEL * LOGICAL L0,L1 CHARACTER*4 TYPE CHARACTER*8 TYPRET,CHARRE CHARACTER*40 CMOT,CTYP PARAMETER (TOLER = 1.D-6 , IUN = 1 , NBPP = 1) CHARACTER*13 MADIR1,MOTPPL(NBPP) CHARACTER*21 MADIR2,MOTPPA(NBPP),MOTPPB(NBPP) DATA MOTPPL/'FORCE_DE_CHOC'/ DATA MOTPPA/'FORCE_DE_CHOC_POINT_A'/ DATA MOTPPB/'FORCE_DE_CHOC_POINT_B'/ * IF (KCHAR.NE.0) THEN MCHARG = KCHAR SEGACT MCHARG NCHAR = KCHARG(/1) ENDIF ITLIAB = 0 IF (ITLIA.NE.0) THEN TYPRET = ' ' CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITAB) IF (ITAB.NE.0 .AND. TYPRET.EQ.'TABLE ') ITLIAB = ITAB ENDIF CALL ACCTAB(IBAS,'MOT',I0,X0,'MAILLAGE',L1,IP0, & 'MAILLAGE',I1,X1,' ',L1,IMAIL) * * 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 IF (KCHAR.EQ.0) GOTO 10 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 IF (KCHAR.EQ.0) GOTO 10 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 IF (KCHAR.EQ.0) GOTO 10 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 ELSE IF (CMOT(1:9).EQ.'PSMO_LIAI') THEN IF (ITLIAB.EQ.0) GOTO 10 CALL ACCTAB(ITPM,'MOT',I0,X0,'POINT',L0,IP0, & 'POINT',I1,X1,' ',L1,IPTS) * * Le point appartient-il au maillage ? * MELEME = IMAIL SEGACT MELEME NBEL = NUM(/2) DO 50 IE = 1,NBEL IPTR = NUM(1,IE) IF (IPTR.EQ.IPTS) GOTO 52 50 CONTINUE * END DO SEGDES MELEME GOTO 10 52 CONTINUE SEGDES MELEME CALL ACCTAB(ITPM,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,NORM) * * A quelle table de liaison appartient le point ? * ITL = 0 54 CONTINUE ITL = ITL + 1 TYPRET = ' ' CALL ACCTAB(ITLIAB,'ENTIER',ITL,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITTL) IF (ITTL.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL ACCTAB(ITTL,'MOT',I0,X0,'TYPE_LIAISON',L0,IP0, & 'MOT',I1,X1,CTYP,L1,IP1) CALL ACCTAB(ITTL,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,INOR) IF (CTYP(1:10).EQ.'POINT_PLAN') THEN CALL ACCTAB(ITTL,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IPTR) IF (IPTR.EQ.IPTS .AND. INOR.EQ.NORM) GOTO 56 GOTO 54 ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN NPTA = 0 NPTB = 0 CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_A',L0,IP0, & 'POINT',I1,X1,' ',L1,IPTA) IF (IPTA.EQ.IPTS .AND. INOR.EQ.NORM) THEN NPTA = 1 GOTO 56 ENDIF CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_B',L0,IP0, & 'POINT',I1,X1,' ',L1,IPTB) IF (IPTB.EQ.IPTS .AND. INOR.EQ.NORM) THEN NPTB = 1 GOTO 56 ENDIF GOTO 54 ELSE GOTO 54 ENDIF ENDIF GOTO 10 56 CONTINUE IF (TYPE.EQ.'DEPL') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ELSE IF (TYPE.EQ.'REAC') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ELSE IF (TYPE.EQ.'CONT') THEN TYPRET = ' ' CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ICDEP) ENDIF TYPRET = ' ' CALL ACCTAB(ITRES,'TABLE',I0,X0,' ',L0,ITTL, & TYPRET,I1,X1,CHARRE,L1,ITRL1) IF (ITRL1.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN IF (CTYP(1:10).EQ.'POINT_PLAN') THEN MADIR1 = MOTPPL(NBPP) TYPRET = ' ' CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR1,L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ILRX) ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN MADIR2 = ' ' IF (NPTA.EQ.1) MADIR2 = MOTPPA(NBPP) IF (NPTB.EQ.1) MADIR2 = MOTPPB(NBPP) TYPRET = ' ' CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR2,L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ILRX) ENDIF IF (ILRX.NE.0 .AND. TYPRET.EQ.'LISTREEL') THEN MLREEL = ILRX SEGACT MLREEL XFC = PROG(IPOS) SEGDES MLREEL IPNV = (IDIM + 1) * (INOR - 1) PS = 0.D0 DO 300 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 300 CONTINUE * END DO IF (PS.LE.XPETIT) THEN INTERR(1) = IPS CALL ERREUR(428) GOTO 10 ENDIF DO 200 ID = 1,IDIM XNORM = XCOOR(IPNV + ID) / SQRT(PS) XFTEM = XFC * XNORM IF (IIMPI.EQ.1804) THEN WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'PSRCD2 : point concern{ ',IPTS WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM ENDIF IF (TYPE.EQ.'CONT') THEN CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN) CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN) ELSE CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM) ENDIF 200 CONTINUE * END DO ENDIF ENDIF GOTO 54 ELSE GOTO 10 ENDIF * 100 CONTINUE IF (TYPE.EQ.'DEPL') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ELSE IF (TYPE.EQ.'REAC') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICDEP) ELSE IF (TYPE.EQ.'CONT') THEN TYPRET = ' ' CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ICDEP) ENDIF MLREE1 = ICHPO2 SEGACT MLREE1 NF = MLREE1.PROG(/1) MLREE2 = ICHPO3 SEGACT MLREE2 N1 = 1 N2 = 2 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 SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG IF (IIMPI.EQ.1804) THEN WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'PSRCD2 : chargement ',KCHAR WRITE(IOIMP,*)'PSRCD2 : num{ro ',ICHA WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM ENDIF IF (TYPE.EQ.'CONT') THEN CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN) CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN) ELSE CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM) ENDIF GOTO 10 ENDIF * IF (KCHAR.NE.0 ) SEGDES MCHARG * RETURN END