C DEPIMP    SOURCE    CHAT      09/10/09    21:17:07     6519           
      SUBROUTINE DEPIMP

      IMPLICIT INTEGER(I-N)
      CHARACTER*4 charm,charre
      REAL*8 XXA,vval,X0,X1
      LOGICAL ISCALA
C
C  ****  CE SUBROUTINE SERT A IMPOSER DES VALEURS DE DEPLACEMENTS
C  ****  IMPOSES NON NULS.
C
C   SYNTAXE  TOTO = DEPIMPOSE   BRIG  FLOT
C
C     OU     TOTO = DEPIMPOSE   BRIG  CHPSCAL
C            TOTO = DEPIMPOSE   BRIG  CHPOI ( COMPOSANTES PRIMALES)
C
C  EN ENTREE :    BRIG  OBJET RIGIDITE DE TYPE  BLOQUAGE
C                 FLOT LA VALEUR DU DEPLACEMENT A IMPOSER
C                 CHPSCAL  EST UN CHPOINT DE SCALAIRE QUI PRECISE LA
C                 VALEUR A IMPOSER EN CHAQUE POINT.
C
C  EN SORTIE UN OBJET DE TYPE CHPOINT
C
-INC SMRIGID
-INC SMCHPOI
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC SMTABLE

      SEGMENT SCOLOR
       CHARACTER*4 COLOR(NBELEM)
      ENDSEGMENT
      POINTEUR SCOL1.SCOLOR,SCOL2.SCOLOR,SCOL3.SCOLOR
      SEGMENT ICPR(NNN)
      segment irelat
         logical lrelat(nnn)
      end segment
      logical lllblo,lllrel

c lecture table liaisons statiques
      CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
      if (iretou.ne.0) goto 1100
C
C  ****  LECTURE D'UN OBJET DE TYPE RIGIDITE
C
      CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU)
      IF(IERR.NE.0) RETURN
C
C  LECTURE D'UNE VALEUR SI ECHEC LECTURE D'UN CHPOINT DE SCALAIRES
C  OU DE  COMPOSANTES PRIMALES DES BLOQUAGES
C
      CALL LIRREE(XXA,0,IREVAL)
      VVAL=XXA
      IF(IREVAL.EQ.0) THEN
          CALL LIROBJ('CHPOINT ',ISCA,1,IRETOU)
          IF(IERR.NE.0) RETURN
          MCHPO1=ISCA
          SEGACT MCHPO1
          nbszch = MCHPO1.ipchp(/1)
          if(nbszch.lt.1) then
             segdes,MCHPO1
             moterr(1:8)='CHPOINT '
             interr(1)=isca
             call erreur(356)
          endif
          msoup1 = MCHPO1.ipchp(1)
          segact msoup1
          nbcomp = msoup1.noharm(/1)
c     ... ISCALA = .TRUE. correspond au traitement d'un CHPOINT
c         contenant une seule zone dans laquelle il y a une seule
c         composante et dont le nom peut être quelconque. Pour
c         l'instant on s'en sert pour vérifier si le CHPOINT est bel
c         et bien SCALAIRE ...
          if(nbszch.eq.1.AND.nbcomp.eq.1) then
             iscala = .TRUE.
          else
             ISCALA = .FALSE.
          endif
      ENDIF
c
c  ... test si la RIGIDITE n'est pas vide, si OUI on créé un CHPOINT
c      vide puis on s'en va ...
c
      MRIGID=IPOIRI
      SEGACT,MRIGID
      NNN=IRIGEL(/2)
      IF (NNN.EQ.0) THEN
         NSOUPO=0
         NAT=1
         SEGINI MCHPOI
         MTYPOI='FLX'
         JATTRI(1) = 2
      MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
     #  ' DEPIMP'
         IFOPOI = IFOUR
         SEGDES MCHPOI
         GO TO 252
      ENDIF

      IPT2=0
      NOHA=0
C
C BOUCLE SUR LES SOUS RIGIDITES . ON VERIFIE QUE LAMBDA EXISTE ET ON
C CONSTRUIT LE SEGMENT GEOMETRIE LX1 LX2 NNOE, DANS scol1.COLOR ON MET LE
C NOM DE L'INCONNUE
C
      segini,irelat
      DO 1 NN=1,NNN
         DESCR=IRIGEL(3,NN)
         MELEME=IRIGEL(1,NN)
         NOHAR=IRIGEL(5,NN)
         IF(NOHA.NE.0.AND.NOHA.NE.NOHAR) THEN
            CALL ERREUR ( 25 )
            RETURN
         ENDIF
         lrelat(nn) = .false.
c    ... on va chercher les multiplicateurs dans DESCR ...
         SEGACT,DESCR
         IA=LISINC(/2)
         DO 2 I=1,IA
            IF(LISINC(I).EQ.'LX  ') GO TO 3
    2    CONTINUE
c    ... on n'a pas trouvé de multiplicateurs, donc bye ...
         SEGDES,DESCR
         CALL ERREUR(245)
         RETURN
c    ... on a trouvé les multiplicateurs ...
   3     CONTINUE
         SEGACT,MELEME
         NBNN=2
         NBELEM=NUM(/2)
         NBREF=0
         NBSOUS=0
         SEGINI,IPT1,SCOL1
c    ... boucle sur les éléments de blocage ...
         DO 4 J=1,NUM(/2)
            JB=0
c       ... JA sert à compter les multiplicateurs dans chaque
c           élément, normalement il y en a 2 ...
            JA=0
c       ... boucle sur les noeuds de ces éléments ...
            DO 4 K=1,NUM(/1)
c          ... si c'est un support de multiplicateur, on met son n°
c              dans IPT1 (position 1 ) ...
               IF(LISINC(K).EQ.'LX  ') THEN
                  JA=JA+1
                  IPT1.NUM(JA,J)=NUM(NOELEP(K),J)
c          ... sinon ...
               ELSE
c             ... on teste si c'est le premier DDL <<physique>>, si OUI ...
                  IF(JB.EQ.0) THEN
c                ... on met son n° dans IPT1 (position 2) ...
                     JB=2
                     IPT1.NUM(JB,J)=NUM(NOELEP(K),J)
C                ... et le nom du DDL dans SCOL1.COLOR ...
                     SCOL1.COLOR(J)=LISINC(K)
c             ... sinon (c.à d. ceci est une relation et non un blocage) ...
                  ELSE
c                ... on teste si le support n'est pas le même que 
c                    celui du premier DDL <<physique>> ...
                     IF(IPT1.NUM(JB,J).NE.NUM(NOELEP(K),J)) THEN
c                   ... si c'est le cas on sert une ERREUR en cas de lecture d'un CHPOINT ...
                        IF(IREVAL.ne.1) then
                           CALL ERREUR(794)
                           RETURN
                        endif
                     ENDIF
c                ... et de toute façon on efface le nom du DDL de SCOL1.COLOR ...
                     SCOL1.COLOR(J)=' '
                     lrelat(nn) = .true.
                  ENDIF
               ENDIF
    4    CONTINUE

C
C  SI NN= 1 IPT2 = IPT1; SINON IPT3 = IPT2 + IPT1, PUIS IPT2 = IPT3
C
         SEGDES,DESCR
         IF(IPT2.NE.0) GO TO 5
         IPT2=IPT1
         SCOL2=SCOL1
         SEGDES,MELEME
         GO TO 1
    5    CONTINUE
         NA=IPT1.NUM(/2)
         NB=IPT2.NUM(/2)
         NBELEM=NA+NB
         SEGINI,IPT3,SCOL3
         DO 71 I=1,NA
            SCOL3.COLOR(I)=SCOL1.COLOR(I)
            DO 72 J=1,2
               IPT3.NUM(J,I)=IPT1.NUM(J,I)
   72       CONTINUE
   71    CONTINUE
         DO 8 I=1,NB
            SCOL3.COLOR(I+NA)=SCOL2.COLOR(I)
            DO 9 J=1,2
               IPT3.NUM(J,I+NA)=IPT2.NUM(J,I)
    9       CONTINUE
    8    CONTINUE
         SEGSUP IPT1,SCOL1
         SEGSUP,IPT2,SCOL2
         IPT2=IPT3
         SCOL2=SCOL3
         SEGDES,MELEME
    1 CONTINUE
      SEGDES,MRIGID
c
c ... on va vérifier si la matrice contient seulement les blocages, ou seulement
c     les relations (on en a seulement besoin en cas de lecture d'un CHPOINT) ...
c
      if(ireval.eq.0) then
         lllblo = .true.
         lllrel = .true.
         do 77 i=1,nnn
            lllblo = lllblo .and. (.not.lrelat(i))
            lllrel = lllrel .and.       lrelat(i)
 77      continue
         segsup,irelat
c    ... si les deux sont faux, on a un mélange de blocages et de relations ...
         if(.not.lllblo .and. .not.lllrel) then
            call erreur(795)
            return
         endif
c    ... si on n'a que des relations, le CHPOINT doit être scalaire ...
         if(lllrel .and. .not.iscala) then
            call erreur(796)
            return
         endif
      else
         segsup,irelat
      endif
C
C ON VIENT DE CREER IPT2 CONTENANT DES ELEMENTS COMPOSES DE LX1  NOE
C DANS COLOR ON A LE NOM DE L'INCONNUE A METTRE EN FACE DE NNOE
C
      NSOUPO=1
      NAT=1
      SEGINI,MCHPOI
      MTYPOI='FLX'
      JATTRI(1) = 2
      MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
     #  ' DEPIMP'
      IFOPOI=IFOUR

      NC=1
      SEGINI,MSOUPO
      IPCHP(1)=MSOUPO
      SEGDES,MCHPOI
      NOCOMP(1)='FLX'
      NOHARM(1)=NOHAR
      write (charm,fmt='(A4)') nohar
      if (charm.eq.'NOHA') noharm(1)=nifour
C
C  CREATION DE L'ELEMENT SUPPORT GEOMETRIQUE ET EN MEME TEMPS DES
C  VALEURS VPOCHA
C
      NBNN=1
      NBELEM=IPT2.NUM(/2)
      SEGINI MELEME
      IGEOC=MELEME
      ITYPEL=1

      N=IPT2.NUM(/2)
      SEGINI,MPOVAL
      IPOVAL=MPOVAL
      SEGDES,MSOUPO

c ... Si on a lu un réél, il n'y a pas grand chose à faire ...
      IF(IREVAL.NE.0) GO TO 250
C
C  CAS DU CHPOINT SCALAIRE, on peut mettre un teste qui porte seulement
C  sur ISCALA car on a déjà vérifié que cela va ensemble avec LLLREL
C
      IF(ISCALA) THEN
          MSOUP1=MCHPO1.IPCHP(1)
          SEGACT MSOUP1
          MPOVA1=MSOUP1.IPOVAL
          SEGACT MPOVA1
          NNN=XCOOR(/1)/(IDIM+1)
          SEGINI ICPR
          IPT3=MSOUP1.IGEOC
          SEGACT IPT3
          NNU=IPT3.NUM(/2)
          DO 25 IUY=1,NNU
             ICPR(IPT3.NUM(1,IUY))=IUY
  25      CONTINUE
          DO 26 IU=1,IPT2.NUM(/2)
             JA=IU
             NUM(1,JA)=IPT2.NUM(1,IU)
             ID=ICPR(IPT2.NUM(2,IU))
             IF( ID.EQ.0) THEN
                CALL ERREUR(244)
                RETURN
             ELSE
                XXA=MPOVA1.VPOCHA(ID,1)
                VPOCHA(JA,1)=XXA
             ENDIF
   26     CONTINUE
          SEGDES MPOVA1,MSOUP1,MCHPO1
          SEGDES IPT3
          SEGSUP ICPR
       ELSE
C
C  CAS DU CHPOINT D'INCONNUES PRIMALES
C
         NNN=XCOOR(/1)/(IDIM+1)
         SEGINI ICPR
         JB=1
         DO 36 J=1,IPT2.NUM(/2)
            NUM(1,JB)=IPT2.NUM(1,J)
            JB=JB+1
   36    CONTINUE
         DO 31 I=1,MCHPO1.IPCHP(/1)
            DO 40 J=1,NNN
               ICPR(J)=0
   40       CONTINUE
            MSOUP1=MCHPO1.IPCHP(I)
            SEGACT MSOUP1
            MPOVA1=MSOUP1.IPOVAL
            SEGACT MPOVA1
            IPT1=MSOUP1.IGEOC
            SEGACT IPT1
            IA=0
            DO 32 J=1,IPT1.NUM(/2)
               ID=IPT1.NUM(1,J)
               IF(ICPR(ID).EQ.0) THEN
                  IA=IA+1
                  ICPR(ID)=IA
               ELSE
                  CALL ERREUR(245)
                  RETURN
               ENDIF
  32        CONTINUE
            DO 33 J=1,IPT2.NUM(/2)
               ID=IPT2.NUM(2,J)
               JB=JB+2
               IF(ICPR(ID).EQ.0) GO TO 33
               DO 34 K=1,MSOUP1.NOCOMP(/2)
                  IF(MSOUP1.NOCOMP(K).EQ.SCOL2.COLOR(J)) GO TO 35
   34          CONTINUE
               GO TO 33
   35          CONTINUE
               JD=ICPR(ID)
               XXA=MPOVA1.VPOCHA(JD,K)
               JA=J
               VPOCHA(JA,1)=XXA
   33       CONTINUE
            SEGDES MSOUP1,MPOVA1,IPT1
   31    CONTINUE
         SEGSUP ICPR
      ENDIF
      GO TO 251

C ... En cas de lecture d'un réél le remplissage du segment MPOVAL est assez simple ...
  250 CONTINUE
      DO 10 I=1,N
         VPOCHA(I,1)=VVAL
   10 CONTINUE
c ... celui du segment MELEME n'est pas plus compliqué ...
      DO 11 I=1,IPT2.NUM(/2)
         JA=I
         NUM(1,JA)=IPT2.NUM(1,I)
   11 CONTINUE

  251 CONTINUE
      SEGSUP IPT2,SCOL2
      SEGDES,MPOVAL,MELEME
  252 CONTINUE
      CALL ECROBJ('CHPOINT ',MCHPOI)
      RETURN

 1100 CONTINUE
      call depim2(ipt)
      return

      END