Sources Esope | Cast3M

dyn205
C DYN205    SOURCE    BP208322  19/02/25    21:15:55     10120          
      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 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 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,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,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,'AXE_ROTATION',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.
         CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
     &                    IP0,MONPER,I0,X1,CHARRE,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
         IF(LPERM) IPALB(I,4)=2
         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