C DYN205 SOURCE CHAT 05/01/12 23:10:52 5004 SUBROUTINE DYN205(I,ITLB,ITYP,KTLIAB,NPLB) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Operateur DYNE : algorithme de Fu - de Vogelaere * * ________________________________________________ * * * * Remplissage des tableaux de description des liaisons sur * * la base a partir des informations contenues dans la * * TABLE ILIB (LIAISON DE TYPE POINT_POINT_ROTATION_PLASTIQUE). * * * * Parametres: * * * * e I Numero 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 creation: * * * * Nicolas WECXSTEEN 04/96 point-point- ... -plastique * * * *--------------------------------------------------------------------* -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,LELAS,LECRO CHARACTER*8 MONAMO,CHARRE,MONPER,MONELA,TYPRET CHARACTER*20 MONECR * MTLIAB = KTLIAB * * --- choc elementaire POINT_POINT_ROTATION_PLASTIQUE avec ou sans * amortissement * IF (ITYP.EQ.50) THEN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0, & 'POINT',I1,X1,' ',L1,INOA) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0, & 'POINT',I1,X1,' ',L1,INOB) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I0,X0,'AXE_ROTATION',L0,IP0, & 'POINT',I1,X1,' ',L1,IPOI) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0, & 'FLOTTANT',I0,XJEU,' ',L1,IP1) IF (IERR.NE.0) RETURN CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0, & 'EVOLUTIO',I1,X1,' ',L1,IPEVO) IF (IERR.NE.0) RETURN * MONPER = ' ' LPERM = .FALSE. CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0, & IP0,MONPER,I0,X1,' ',LPERM,IP1) IF (IERR.NE.0) RETURN TYPRET = ' ' CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0, & IP0,TYPRET,I0,X1,MONECR,L1,IP1) IF (IERR.NE.0) RETURN LECRO = (TYPRET.EQ.'MOT') MONELA = ' ' LELAS = .FALSE. CALL ACCTAB(ITLB,'MOT',I1,X0,'COMPORTEMENT_ELASTIQUE',L0, & IP0,MONELA,I0,X1,' ',LELAS,IP1) IF (IERR.NE.0) RETURN IPERM = 0 * * iperm = -2 : liaison elastique permanente * iperm = -1 : choc elastique * iperm = 0 : donnees incoherentes ou insuffisantes * iperm = 1 : choc plastique * iperm = 2 : liaison plastique isotrope * iperm = 3 : liaison plastique cinematique * IF (LPERM) THEN IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2 IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2 IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3 IF (.NOT.(XJEU.EQ.0.)) THEN * WRITE(*,*) 'Liaison permanente, mise a zero du jeu.' XJEU = 0.D0 ENDIF ELSE IF (.NOT.LECRO) THEN IF (LELAS) THEN IPERM = -1 ELSE IPERM = 1 ENDIF ENDIF ENDIF IF (IPERM.EQ.0) THEN CALL ERREUR(905) RETURN 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 = MLREE1.PROG(/1) NIP = XABSCI(/2) * DO 10 MM=1,NIP XABSCI (I,MM) = MLREE1.PROG(MM) XORDON (I,MM) = MLREE2.PROG(MM) 10 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 IPALB(I,5) = IPERM XPALB(I,1) = XJEU * * normalisation de l'axe de rotation * 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 IF (MONAMO.EQ.'FLOTTANT') THEN IPALB(I,1) = 51 XPALB(I,2) = XAMON DO 22 ID = 1,IDIM ID2 = 2 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 22 CONTINUE * end do ELSE DO 24 ID = 1,IDIM ID2 = 1 + ID XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 24 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 elementaire POINT_POINT... * * ELSE IF (ITYP.EQ. ) THEN * ... * ... ENDIF * END