Sources Esope | Cast3M

dyna14
C DYNA14    SOURCE    PV        20/03/30    21:18:04     10567          
      SUBROUTINE DYNA14(ITREFR,KTLIAA)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*--------------------------------------------------------------------*
*                                                                    *
*     Operateur DYNE : algorithme de Fu - de Vogelaere               *
*     ________________________________________________               *
*                                                                    *
*     Remplissage du tableau contenant les parametres de liaison en  *
*     cas de reprise (liaison POLYNOMIALE ou COUPLAGE_DEPLACEMENT    *
*     avec convolution en base A)                                    *
*                                                                    *
*     Parametres:                                                    *
*                                                                    *
*     ITREFR    Table contenant les variables internes des liaisons  *
*               sauvegardees dans la table de reprise                *
*     KTLIAA    Description des liaisons en base A                   *
*                                                                    *
*     Auteur, date de creation:                                      *
*                                                                    *
*     Denis ROBERT-MOUGIN : le 14 mai 1992                           *
*                                                                    *
*--------------------------------------------------------------------*
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
-INC SMTABLE
-INC SMLREEL
-INC SMCOORD
*
      SEGMENT,ICPR(nbpts)
      SEGMENT,MTLIAA
         INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA)
         REAL*8  XPALA(NLIAA,NXPALA)
      ENDSEGMENT
*
      LOGICAL L0,L1
      CHARACTER*(8) TYPIND
*
      MTLIAA = KTLIAA
      NLIAA = XPALA(/1)
      IF (IIMPI.EQ.333) THEN
         WRITE(IOIMP,*)'Entree dans DYNA14'
         WRITE(IOIMP,*)'NLIAA = ',NLIAA
      ENDIF
*
*     Boucle sur les liaisons en base A (I) sauvegardees (IPOLY)
*
      IPOLY = 0
      DO 10 I = 1,NLIAA
         ITYP = IPALA(I,1)
c          IF(IIMPI.EQ.333) WRITE(IOIMP,*)'Liaison ',I,': ITYP = ',ITYP
 
*        Liaison acceptees = 5 (avec convolution) et 6
         IF(ITYP.EQ.5) THEN 
           IFONC=IPALA(I,3)
c            WRITE(IOIMP,*)'dyna14: Liaison ',I,': ITYP = ',ITYP,IFONC
           IF(IFONC.NE.100.AND.IFONC.NE.101) GOTO 10
         ELSEIF(ITYP.NE.6) THEN
c            WRITE(IOIMP,*)'dyna14: Liaison ',I,': ITYP = ',ITYP
           GOTO 10
         ENDIF
 
*        Attention : les liaisons doivent etre dans le meme ordre 
*        dans la table ITREFI que la table des liaisons !
         IPOLY = IPOLY + 1
         CALL ACCTAB(ITREFR,'ENTIER',IPOLY,X0,' ',L0,IP0,
     &                      'TABLE',I1,X1,' ',L1,ITREFI)
         IF (IERR.NE.0) RETURN
         CALL ACCTAB(ITREFI,'MOT',I0,X0,'TYPE',L0,IP0,
     &                      'ENTIER',ITYPR,X1,' ',L1,ITR)
         IF (IERR.NE.0) RETURN
         IF (ITYPR.NE.ITYP) THEN
           WRITE(ioimp,*) 'Incoherence table de reprise liaison',I
           CALL ERREUR(21)
           RETURN
         ENDIF   
 
*     -- Cas des liaisons couplage deplacement avec convolution --
         IF (ITYP.EQ.5) THEN
 
            CALL ACCTAB(ITREFI,'MOT',I0,X0,'DEPLACEMENT',
     &                  L0,IP0,'LISTREEL',I1,X1,' ',L1,IPLR2)
            IF (IERR.NE.0) RETURN
c             IPALA(I,5)=IPLR2
c           On recopie dans le nouveau listreel les deplacements deja 
c           calcules avant reprise
c           IFONC=100 : convolution generale via un listreel fourni
c             IF(IFONC.EQ.100) THEN
              MLREE2=IPALA(I,5)
c           IFONC=101 : convolution via le modele de granger_paidoussis
c           --> optimisation : on retrouve les memes indices ...
c             ELSEIF(IFONC.EQ.101) THEN
c               MLREE2=IPALA(I,6)
c             ENDIF
            MLREEL=IPLR2
            segact,MLREEL
            JG2=PROG(/1)
            do i2=1,JG2
              MLREE2.PROG(i2)=PROG(i2)
            enddo
            CALL ACCTAB(ITREFI,'MOT',I0,X0,'DEPLACEMENT_1/2',
     &                  L0,IP0,'LISTREEL',I1,X1,' ',L1,IPLR3)
            IF (IERR.NE.0) RETURN
c             IPALA(I,6)=IPLR3
c           On recopie dans le nouveau listreel les deplacements deja 
c           calcules avant reprise
c             IF(IFONC.EQ.100) THEN
              MLREE3=IPALA(I,6)
c           IFONC=101 : convolution via le modele de granger_paidoussis
c           --> optimisation : on retrouve les memes indices ...
c             ELSEIF(IFONC.EQ.101) THEN
c               MLREE3=IPALA(I,7)
c             ENDIF
            MLREEL=IPLR3
            segact,MLREEL
            JG3=PROG(/1)
            do i3=1,JG3
              MLREE3.PROG(i3)=PROG(i3)
            enddo
 
 
*     -- Cas des liaisons polynomiales --
         ELSEIF (ITYP.EQ.6) THEN
 
            CALL ACCTAB(ITREFI,'MOT',I0,X0,
     &                  'POINTS_LIAISON_POLYNOMIALE',
     &                  L0,IP0,'LISTENTI',I1,X1,' ',L1,IPLEN1)
            IF (IERR.NE.0) RETURN
            CALL ACCTAB(ITREFI,'MOT',I0,X0,
     &               'VARIABLES_LIAISON_POLYNOMIALE',
     &               L0,IP0,'LISTREEL',I1,X1,' ',L1,IPLRE1)
            IF (IERR.NE.0) RETURN
*
            IF(IIMPI.EQ.333) WRITE(IOIMP,*)'Lecture des points'
            MLENTI = IPLEN1
            SEGACT MLENTI
            NP = LECT(/1)
            NPJ = NP / 2
            DO 20 J=1,NPJ
               K = J * 2
               IKX = LECT(K)
               IPLIA(I,J) = IKX
               K = (J * 2) - 1
               JPLIA(IKX) = LECT(K)
 20         CONTINUE
*****PV     SEGSUP MLENTI
*
            IF(IIMPI.EQ.333) WRITE(IOIMP,*)'Lecture des deplacements'
            MLREEL = IPLRE1
            SEGACT MLREEL
            NV = PROG(/1)
            DO 30 J=1,NV
               XPALA(I,J) = PROG(J)
 30         CONTINUE
*****PV     SEGSUP MLREEL
 
         ENDIF
 
 10   CONTINUE
*
      END