C DYN203 SOURCE PV 07/12/14 21:15:00 6005 SUBROUTINE DYN203(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 @ partir des informations contenues dans la * * table ITLB (liaison de type ..._CERCLE). * * Liaison POINT_CERCLE avec ou sans amortissement * * Liaison POINT_CERCLE_FROTTEMENT avec ou sans amortissement * * Liaison POINT_CERCLE_MOBILE avec ou sans amortissement * * Liaison CERCLE_CERCLE_FROTTEMENT 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 CCOPTIO -INC SMCOORD * 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,LINTER CHARACTER*8 MONAMO,MONINTER * LINTER=.TRUE. PS=0.D0 MTLIAB = KTLIAB * * --- choc {l{mentaire POINT_CERCLE avec ou sans amortissement * IF (ITYP.EQ.21) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'EXCENTRATION',L0,IP0, & 'POINT',I1,X1,' ',L1,IEXC) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & 'FLOTTANT',I0,XRAID,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON',L0,IP0, & 'FLOTTANT',I0,XRAYO,' ',L1,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM XPALB(I,1) = XRAID XPALB(I,2) = XRAYO * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 10 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 10 CONTINUE *** write (6,*) ' ps ',ps * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 22 XPALB(I,3) = XAMON ID1 = 3 ELSE ID1 = 2 ENDIF ID2 = ID1 + IDIM DO 12 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 12 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * * --- choc {l{mentaire POINT_CERCLE_FROTTEMENT * avec ou sans amortissement * ELSE IF (ITYP.EQ.23) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'EXCENTRATION',L0,IP0, & 'POINT',I1,X1,' ',L1,IEXC) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & 'FLOTTANT',I0,XRAIN,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON',L0,IP0, & 'FLOTTANT',I0,XRAYO,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) IF (IERR.NE.0) RETURN MONINTER = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'CONTACT_INTERIEUR',L0, & IP0,MONINTER,I0,X1,' ',LINTER,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYO XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 20 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 20 CONTINUE *** write (6,*) ' ps - 2 ',ps * end do IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 24 XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF ID2 = ID1 + IDIM DO 22 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 22 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * * --- choc {l{mentaire POINT_CERCLE_MOBILE * avec ou sans amortissement * ELSE IF (ITYP.EQ.33) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT',L0,IP0, & 'POINT',I1,X1,' ',L1,INOA) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'CERCLE',L0,IP0, & 'POINT',I1,X1,' ',L1,INOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & 'FLOTTANT',I0,XRAIN,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON',L0,IP0, & 'FLOTTANT',I0,XRAYO,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) IF (IERR.NE.0) RETURN MONINTER = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'CONTACT_INTERIEUR',L0, & IP0,MONINTER,I0,X1,' ',LINTER,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYO XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPNOA = (IDIM + 1) * (INOA - 1) IPNOB = (IDIM + 1) * (INOB - 1) PS = 0.D0 DO 202 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 202 CONTINUE *** write (6,*) ' ps - 3 ',ps IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 34 XPALB(I,7) = XAMON ID1 = 7 ELSE ID1 = 6 ENDIF ID2 = ID1 + IDIM DO 222 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPNOB+ID) - XCOOR(IPNOA+ID) 222 CONTINUE CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) IPLIB(I,1) = IPLAC CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) IPLIB(I,2) = IPLAC * * --- choc {l{mentaire CERCLE_CERCLE_FROTTEMENT * avec ou sans amortissement * ELSE IF (ITYP.EQ.25) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'SUPPORT',L0,IP0, & 'POINT',I1,X1,' ',L1,IMOD) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'EXCENTRATION',L0,IP0, & 'POINT',I1,X1,' ',L1,IEXC) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0, & 'FLOTTANT',I0,XRAIN,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON_BUTEE',L0,IP0, & 'FLOTTANT',I0,XRAYB,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAYON_SUPPORT',L0,IP0, & 'FLOTTANT',I0,XRAYP,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0, & 'FLOTTANT',I0,XGLIS,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0, & 'FLOTTANT',I0,XADHE,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0, & 'FLOTTANT',I0,XRAIT,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0, & IP0,'FLOTTANT',I0,XAMOT,' ',L1,IP1) IF (IERR.NE.0) RETURN MONINTER = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'CONTACT_INTERIEUR',L0, & IP0,MONINTER,I0,X1,' ',LINTER,IP1) IF (IERR.NE.0) RETURN * MONAMO = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0, & MONAMO,I0,XAMON,' ',L1,IP1) IF (IERR.NE.0) RETURN * IPALB(I,1) = ITYP IPALB(I,3) = IDIM IPALB(I,4) = 1 IF (.NOT.LINTER) THEN IPALB(I,4) = 0 ENDIF XPALB(I,1) = XRAIN XPALB(I,2) = XRAYB XPALB(I,3) = XGLIS XPALB(I,4) = XADHE XPALB(I,5) = XRAIT XPALB(I,6) = XAMOT * * normalisation de la normale * IPNV = (IDIM + 1) * (IPOI - 1) IPEX = (IDIM + 1) * (IEXC - 1) PS = 0.D0 DO 30 ID = 1,IDIM XC = XCOOR(IPNV + ID) PS = PS + XC * XC 30 CONTINUE * end do *** write (6,*) ' ps - 4 ',ps IF (PS.LE.0.D0) THEN CALL ERREUR(162) RETURN ENDIF IF (MONAMO.EQ.'FLOTTANT') THEN ID1 = 7 IPALB(I,1) = 26 XPALB(I,7) = XAMON ELSE ID1 = 6 ENDIF ID10 = ID1 + 9*IDIM XPALB(I,ID10+1) = XRAYP ID2 = ID1 + IDIM ID3 = ID1 + 2*IDIM DO 32 ID = 1,IDIM XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 32 CONTINUE * end do CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) IPLIB(I,1) = IPLAC * * --- choc {l{mentaire ..._CERCLE... * * ELSE IF (ITYP.EQ. ) THEN * ... * ... ENDIF * END