C DYN202 SOURCE BP208322 19/02/25 21:15:51 10120 SUBROUTINE DYN202(I,ITLB,ITYP,KTLIAB,NPLB) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Op{rateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Remplissage des tableaux de description des liaisons sur * * la base des informations contenues dans la table ILIB * * Liaison POINT_POINT avec ou sans amortissement * * Liaison POINT_POINT_FROTTEMENT avec ou sans amortissement * * Liaison POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans amortissement * * * * Param}tres: * * * * e I Num{ro de la liaison. * * e ITLB Table rassemblant la description d'une liaison. * * e ITYP Type de la liaison. * * s KTLIAB Segment descriptif des liaisons sur base B. * * e NPLB Nombre total de points. * * * * * * Auteur, date de cr{ation: * * * * Lionel VIVAN, le 5 D{cembre 1990. * * * *--------------------------------------------------------------------* -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMEVOLL -INC SMLREEL * 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 * LOGICAL L1,L0,LPERM CHARACTER*8 MONAMO,MONPER,MARAID,TYPRET CHARACTER*16 CHARRE CHARACTER*20 MONECR * MTLIAB = KTLIAB * * --- choc {l{mentaire POINT_POINT avec ou sans amortissement * IF (ITYP.EQ.11) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOA) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,IPOI) IF (IERR.NE.0) RETURN MARAID = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & MARAID,I0,XRAID,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN IF (MARAID .EQ. 'ENTIER ') THEN XRAID = 1.D0*I0 MARAID = 'FLOTTANT' ENDIF CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN MONPER = ' ' LPERM = .FALSE. CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0, & IP0,MONPER,I0,X1,CHARRE,LPERM,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN IF (MONAMO .EQ. 'ENTIER ') THEN XAMON = 1.D0*I0 MONAMO = 'FLOTTANT' ENDIF TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IPEVO) IF (IERR.NE.0) RETURN IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF * IF (TYPRET.EQ.'EVOLUTIO') THEN ITYP = 111 XRAID = 0.d0 ENDIF IPALB(I,1) = ITYP IPALB(I,3) = IDIM IF(LPERM) IPALB(I,4)=2 XPALB(I,1) = XRAID XPALB(I,2) = XJEU * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 10 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 10 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,3) = XAMON ELSE XPALB(I,3) = 0.d0 ENDIF DO 12 ID = 1,IDIM ID2 = 3 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 12 CONTINUE * end do * IF (IPALB(I,1) .EQ. 111) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des * tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 16 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 16 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * * --- choc {l{mentaire POINT_POINT_FROTTEMENT avec ou sans amortissement * elseIF (ITYP.EQ.13) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOA) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,IPOI) IF (IERR.NE.0) RETURN MARAID = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & MARAID,I0,XRAID,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN IF (MARAID .EQ. 'ENTIER ') THEN XRAID = 1.D0*I0 MARAID = 'FLOTTANT' ENDIF CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IPEVO) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN IF (MONAMO .EQ. 'ENTIER ') THEN XAMON = 1.D0*I0 MONAMO = 'FLOTTANT' ENDIF IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN CALL ERREUR(891) RETURN ENDIF IF (TYPRET.EQ.'EVOLUTIO') THEN ITYP = 113 XRAID = 0.d0 ENDIF * *bp,2016 petit message informatif pour ceux qui, comme moi, n'auraient * pas lu la notice jusqu'au bout : IF(XRAIT.LT.0.D0) THEN IF(XAMOT.LE.0D0.OR.IIMPI.GT.0) THEN WRITE(IOIMP,*) 'Liaison elementaire ..._FROTTEMENT numero',I WRITE(IOIMP,*) & 'utilisation du modele de frottement regularise d ODEN' ENDIF IF(XAMOT.LE.0D0) THEN c ERREUR: %m1:8 = %r1 inferieur a %r2 MOTERR(1:8)='AMOR*_T*' REAERR(1)=XAMOT REAERR(2)=0.D0 CALL ERREUR(41) RETURN ENDIF ENDIF IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAID XPALB(I,2) = XJEU XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT IF (MONAMO.EQ.'FLOTTANT') THEN XPALB(I,7) = XAMON ELSE XPALB(I,7) = 0.D0 ENDIF * cas particulier pas tres orthodoxe pour Gibert * on passe a ityp = -13 et on modifie et ajoute * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4 TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'MODELE',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,IGIB) IF (TYPRET.EQ.'MOT') THEN IF (CHARRE.EQ.'NEDJAI-GIBERT') THEN IPALB(I,1) = -13 ELSE CALL ERREUR(891) RETURN ENDIF ELSEIF (IGIB.NE.0) THEN CALL ERREUR(891) RETURN ENDIF * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 20 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 20 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF DO 22 ID = 1,IDIM ID2 = 7 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 22 CONTINUE * end do * IF (IPALB(I,1) .EQ. 113) THEN MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des * tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 24 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 24 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * * --- choc elementaire POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans * amortissement * ELSE IF (ITYP.EQ.16) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOA) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,INOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,CHARRE,L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & 'EVOLUTIO',I1,X1,CHARRE,L1,IPEVO) IF (IERR.NE.0) RETURN * MONPER = ' ' LPERM = .FALSE. IPERM = 1 CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0, & IP0,MONPER,I0,X1,CHARRE,LPERM,IP1) IF (IERR.NE.0) RETURN IF (LPERM) THEN CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0, & IP0,'MOT',I0,X1,MONECR,L1,IP1) IF (IERR.NE.0) RETURN IF (.NOT.(XJEU.EQ.0.D0)) THEN * WRITE (*,*) 'Liaison permanente, mise a zero du jeu.' XJEU = 0.D0 ENDIF IF (MONECR.EQ.'ISOTROPE') THEN IPERM = 2 ELSEIF (MONECR.EQ.'CINEMATIQUE') THEN IPERM = 3 ELSE call erreur(21) RETURN ENDIF ENDIF * MEVOLL = IPEVO * * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des * tableaux xabsci et xordon * SEGACT MEVOLL KEVOLL = IEVOLL(1) SEGACT KEVOLL MLREE1 = IPROGX MLREE2 = IPROGY SEGACT MLREE1 SEGACT MLREE2 NIP = XABSCI(/2) * DO 26 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 26 CONTINUE * SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOLL SEGDES MEVOLL * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,CHARRE,L1,IP1) IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XJEU IF(LPERM) IPALB(I,4)=2 IPALB(I,5) = IPERM * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) PS = 0.D0 DO 30 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 30 CONTINUE * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 17 XPALB(I,2) = XAMON DO 32 ID = 1,IDIM ID2 = 2 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 32 CONTINUE * end do ELSE DO 34 ID = 1,IDIM ID2 = 1 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 34 CONTINUE * end do ENDIF * CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * * --- choc {l{mentaire POINT_POINT... * * ELSE IF (ITYP.EQ. ) THEN * ... * ... ENDIF * END