C DEVPS2 SOURCE CHAT 05/01/12 22:47:08 5004 SUBROUTINE DEVPS2(ICHAR1,KTLIAB,KTNUM,KTPHI,KTFEX,REPRIS,ITPS, & IBAS,NUMBAS) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Opérateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Remplissage du tableau FEXPSM, repr{sentant les pseudo-modes * * aux points de liaison. * * * * Paramètres: * * * * e ITCHAR Table représentant les chargements * * e ITBAS Table représentant la base modale * * e KTLIAB Segment contenant les liaisons sur base B * * e KTNUM Segment contenant les paramètres numériques * * e KTPHI Segment des déformées modales * * es KTFEX Segment contenant les chargements libres * * e REPRIS Logique indiquant si le calcul est en reprise * * e ITPS Table contenant les pseudo-modes * * e IBAS Table contenant les modes * * e NUMBAS numéro de la sous base * * * * Auteur, date de création: * * * * Lionel VIVAN, le 10 avril 1990 * * * *--------------------------------------------------------------------* * -INC CCOPTIO -INC SMCHARG -INC SMLREEL -INC SMCHPOI * * FEXPSM(.,.,1,.) valeur au pas m * FEXPSM(.,.,2,.) valeur au pas m - 1/2 * SEGMENT,MTNUM REAL*8 XDT(NPC1),XTEMPS(NPC1) ENDSEGMENT SEGMENT,MTFEX REAL*8 FEXA(NPFEXA,NPC1,2) REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB) REAL*8 FTEXB(NPLB,NPC1,2,IDIM) INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB) ENDSEGMENT SEGMENT,MTPHI INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) INTEGER IAROTA(NSB) REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) ENDSEGMENT SEGMENT,MTLIAB INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) REAL*8 XPALB(NLIAB,NXPALB) REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) ENDSEGMENT SEGMENT,MTRAV REAL*8 FTCHG(NPC2) ENDSEGMENT * LOGICAL L0,L1,REPRIS CHARACTER*4 NOMAXI(6),NOMTRI(6),COMP CHARACTER*8 TYPRET,CHARRE CHARACTER*40 CMOT PARAMETER ( TOLER = 1.E-6 ) * DATA NOMAXI/'UR ','UZ ','UT ','RR ','RZ ','RT '/ DATA NOMTRI/'UX ','UY ','UZ ','RX ','RY ','RZ '/ * MTNUM = KTNUM MTFEX = KTFEX MTPHI = KTPHI MTLIAB = KTLIAB NPC1 = XDT(/1) NPLB = IBASB(/1) NSB = XPHILB(/1) IDIMB = XPHILB(/4) MCHARG = ICHAR1 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_A',L0,IP0, & 'CHPOINT',I1,X1,CHARRE,L1,ICHBA) * * boucle sur les chargements {l{mentaires * DO 20 ICHAR=1,NCHAR ICHARG = KCHARG(ICHAR) SEGACT,ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT' &.OR.CHALIE(ICHAR).NE.'LIE ') THEN SEGDES ICHARG GOTO 20 ENDIF IF (ICHBA.EQ.ICHPO1) GOTO 120 20 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) GOTO 10 * 120 CONTINUE IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1 WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR ENDIF MLR1 = ICHPO2 MLR2 = ICHPO3 CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS) IF (IERR.NE.0) RETURN MTRAV = KTRAV SEGDES ICHARG * * boucle sur les points de liaison * DO 30 IPL = 1,NPLB IB = IBASB(IPL) IF (IB.EQ.NUMBAS) THEN IPTL = JPLIB(IPL) CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPS) DO 40 ID = 1,IDIMB IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN COMP = NOMAXI(ID) ELSE COMP = NOMTRI(ID) ENDIF CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL) IF (KERRE.EQ.0) THEN DO 50 IT=1,NPC1 NP = 2 * IT FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NP) ) NI = NP - 1 FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NI) ) 50 CONTINUE * end do ENDIF 40 CONTINUE * end do ENDIF 30 CONTINUE * end do SEGSUP MTRAV 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 24 ICHAR=1,NCHAR ICHARG = KCHARG(ICHAR) SEGACT,ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT' & .OR.CHALIE(ICHAR).NE.'LIE ') THEN SEGDES ICHARG GOTO 24 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 124 24 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) GOTO 10 * 124 CONTINUE IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1 WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR ENDIF MLR1 = ICHPO2 MLR2 = ICHPO3 CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS) IF (IERR.NE.0) RETURN MTRAV = KTRAV SEGDES ICHARG * * boucle sur les points de liaison * DO 32 IPL = 1,NPLB IB = IBASB(IPL) IF (IB.EQ.NUMBAS) THEN IPTL = JPLIB(IPL) CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPS) DO 42 ID = 1,IDIMB IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN COMP = NOMAXI(ID) ELSE COMP = NOMTRI(ID) ENDIF CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL) IF (KERRE.EQ.0) THEN DO 52 IT=1,NPC1 NP = 2 * IT FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NP) ) NI = NP - 1 FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NI) ) 52 CONTINUE * end do ENDIF 42 CONTINUE ENDIF * end do 32 CONTINUE * end do SEGSUP MTRAV GOTO 10 ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHBA) * * boucle sur les chargements {l{mentaires * DO 28 ICHAR=1,NCHAR ICHARG = KCHARG(ICHAR) SEGACT,ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT' & .OR.CHALIE(ICHAR).NE.'LIE ') THEN SEGDES ICHARG GOTO 28 ENDIF IF (ICHBA.EQ.ICHPO1) GOTO 128 28 CONTINUE * end do * on n'a pas trouv{ le chargement INTERR(1) = IPS CALL ERREUR(428) GOTO 10 * 128 CONTINUE IF (IIMPI.EQ.333) THEN WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1 WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR ENDIF MLR1 = ICHPO2 MLR2 = ICHPO3 CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS) IF (IERR.NE.0) RETURN MTRAV = KTRAV SEGDES ICHARG * * boucle sur les points de liaison * DO 34 IPL = 1,NPLB IB = IBASB(IPL) IF (IB.EQ.NUMBAS) THEN IPTL = JPLIB(IPL) CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0, & 'CHPOINT',I1,X1,' ',L1,ICHPS) DO 44 ID = 1,IDIMB IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN COMP = NOMAXI(ID) ELSE COMP = NOMTRI(ID) ENDIF CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL) IF (KERRE.EQ.0) THEN DO 54 IT=1,NPC1 NP = 2 * IT FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NP) ) NI = NP - 1 FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) + & ( XVAL * FTCHG(NI) ) 54 CONTINUE * end do ENDIF 44 CONTINUE * end do ENDIF 34 CONTINUE * end do SEGSUP MTRAV GOTO 10 ENDIF ENDIF SEGDES MCHARG * END