C SUPDEP    SOURCE    PV        10/10/13    21:15:47     6781           
      SUBROUTINE SUPDEP
c=================================================================
c cette procedure est appelée par SUPER
c A partir du champ de deplacements interface et du champ d efforts
c sur la sous structure, elle determine le champ de déplacement
c sur toute la sous-structure 
c=================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMSUPER
-INC SMELEME
-INC CCOPTIO
-INC SMMATRI 
-INC SMCHPOI
-INC SMVECTD
-INC SMRIGID
c ????????????????????????????????????????????????????????????????
      SEGMENT/BID/(BIDON(IIMAX+10)*D)
c ????????????????????????????????????????????????????????????????
c de la meme facon que dans MONDES , on va charger la maximum de
c lignes en memoire pendant que l'on va gerer les efforts
c IPLIG : première ligne en mémoire
c IDLIG : dernière ligne en mémoire 
c----------------------------------------------------------------
        PARAMETER (LPCRAY=10000)
        segment ITRAA(NENS)
        integer OOOVAL
        logical leffort 

c creation d'une pile MRU
        call OOOMRU(1)
        call lirobj('SUPERELE',MSUPER,1,IRETOU)
        if (ierr.ne.0) RETURN
c lecture du déplacement interface
        call lirobj('CHPOINT ',MDEPI,1,IRETOU)
        if (ierr.ne.0) RETURN
c lecture du  champ d'efforts si il existe 
c  27/11/2009  lecture obligatoire car risque d'erreur utilisateur
c              due  a une mauvaise comprehension de l'operation
        call lirobj('CHPOINT ',MFORC,1,IRETOU)
        if (ierr.ne.0) RETURN
        if (iretou .eq. 0) then 
            leffort = .false. 
        else
            leffort = .true. 
        end if

        segact MSUPER
*       write(6,*) MRIGTO,MSUPEL,MSURAI,MBLOQU,MSUMAS,MCROUT
c
c recherche du nombre d'inconnues maitres
        MRIGID = MSURAI
        segact MRIGID
        xMATRI = IRIGEL(4,1)
        lagdua=msuper.islag
*       write (6,*) ' msurai lagdua dans supdep ', mrigid,lagdua
        segdes MRIGID
        segact xMATRI
*        XMATRI = IMATTT(1)
*        segdes IMATRI
*        segact XMATRI
        nligra = RE(/1)
        segdes XMATRI
c
        MCROUX = MCROUT
* creation du meleme  des noeuds maitres
       MRIGID=MRIGTO
       SEGACT MRIGID

        meleme=msupel
 
        MRIGID = MSURAI
c sauvegarde du deplacement interface
        call reduir(MDEPI,MELEME,MDEPint)
        call adchpo(mdepi,mdepint,mdext,1.d0,-1.d0)
*       call ecchpo(mdepi,0)
*       call ecchpo(mdepint,0)
*        write (6,*) ' mdext '
*       call ecchpo(mdext,0)
c transformation du champ de déplacement en vecteur
*       call ecmail(lagdua,0)
**      call dbbch(mdepint,lagdua)
        call chv1(MCROUX,MDEPInt,MVECTX,1)
c normalisation
        MMATRI = MCROUT
        segact MMATRI
        MDNOR = IDNORM
        segact MDNOR
        INC = DNOR(/1)
c inbine : intger nombre inconnues esclaves

        inbine = INC - Nligra
*       write (6,*) ' inbine inc nligra ',inbine,inc,nligra
        MVECTD = MVECTX
        segact MVECTD*mod
        do 1 ii1 = inbine+1,INC
           VECTBB(ii1) = VECTBB(ii1) / DNOR(ii1)
 1      continue 

        MVECT1 = MVECTD
        MILIGN = IILIGN
        segact MILIGN
        NNOE = ILIGN(/1)

c ????? idem que dans MONDES ??????
        LTRK = MAX(1+LPCRAY,OOOVAL(1,4))       
        IIMAX = (((IJMAX+LTRK)/LTRK)+1)*LTRK
c
***********************************************************************
***********************************************************************
c pb à résoudre : L1t X +  L2t DEPI = D(-1) L1(-1) F  
c
*  commencons par traiter le terme en effort
c transformation du CHPOINT en vecteur
        if (leffort) then 
          MCHPOI = MFORC
          MRIGID = MRIGTO
          segdes MRIGID
          call copie2(mchpoi,mchpo1)
          SEGACT MCHPO1
        DO 432 I=1,mchpo1.IPCHP(/1)
           MSOUPO=mchpo1.IPCHP(I)
           SEGACT MSOUPO*MOD
           IPT4=IGEOC
           SEGINI,ipt5=ipt4
           SEGDES ipt4
           IGEOC=ipt5
  432     CONTINUE
          call dbbch(mchpo1,lagdua)
*         call ecchpo(mchpo1 ,0)
          call chv2(MCROUX,MCHPO1,MVECTX,1)
          MVECTD = MVECTX
c attention CHV2 desactive tout
          segact MMATRI
          segact MILIGN
          segact MVECTD*MOD
          MDIAG = IDIAG 
          segact MDIAG 
c
c il faut normaliser ce vecteur
c on va de plus recuperer l'indice du premier terme non nul
          dnorma = 0.D0 
          inbi=vectbb(/1)
*         write (6,*) ' inbine ',inbine
*         write (6,*) ' vectbb-1 ',(vectbb(i),i=1,vectbb(/1))
*         write (6,*) ' dnor     ',(dnor  (i),i=1,vectbb(/1))


          do 2 ii1=1,inbine
              VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1) 
              dnorma = max(dnorma,abs(VECTBB(ii1)))
 2        continue
*         write (6,*) ' vectbb-2 ',(vectbb(i),i=1,vectbb(/1))
          dnorma = dnorma * 1.D-12
c
c recherche du premier terme non nul
          do 3 ii1=1,inbine
             if (abs(VECTBB(ii1)).GE.dnorma) GOTO 4 
 3        continue 
*          write(6,*) ' attention vecteur force nulle'
 4        continue 
          ipremf = ii1
          if(dnorma.eq.0.d0) ipremf=max(1,inbine)

* effectuons maintenant le produit (L1)-1 EFFORT 
*-------------------------------------------------
c ????????????
          segini BID 
          ivalma = 0
c ????????????
c d'ou le bloc associé
          INPREM = IPNO(ipremf)
c et le bloc de la dernière ligne
          INDERn=-1
          if(inbine.ne.0)INDERN = IPNO(inbine)

c
          IPLIG = INPREM
          do 10 ii0=INPREM,INDERN
             LIGN = ILIGN(ii0)
             segact /ERR=20/ LIGN
             IPRELL = IPREL
             IVALMA = IVALMA+VAL(/1)
*pvpv            if (IVALMA.GT.NGMAXY) GOTO 20
             NA = IMMM(/1)
             call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1),
     >         na,inumli,inbine,ipremf,iprel)
 10       continue
          segsup BID
          IDLIG = INDERN
          GOTO 60
c on a eu des problèmes de memoire
 20       continue
          SEGSUP BID
          IDLIG = ii0 - 1 
          itemp1 = ii0 
c c'est reparti
          do 30 ii0=itemp1,INDERN          
            LIGN = ILIGN(ii0)
            segact /ERR=22/ LIGN
            NA = IMMM(/1)
            IPRELL = IPREL
            call supde2(IPPVV(1),IVPO(1),VAL(1),VECTBB(1),
     >         na,inumli,inbine,ipremf,iprel)
            segdes LIGN*(NOMOD,MRU)
            GOTO 30
c il y a encore des problèmes
 22         CONTINUE
c il va falloir faire de la place ==> desactivation d'une ligne
c reste-t-il des lignes à desactiver ?
            if (IDLIG .lt. IPLIG) then
              CALL ERREUR(5)
            else
              LIGN=ILIGN(IDLIG)
              SEGDES LIGN*(NOMOD,MRU)
              IDLIG=IDLIG-1
            end if
 30       continue
c
c muliplions maintenant par D-1
c---------------------------------
 60       continue
          do 70 i=1,inbine
             VECTBB(i) = VECTBB(i) / DIAG(i)
 70       continue
          segdes MDIAG 
        else
c il n y a pas d'efforts
           segini MVECTD
c il faut preciser qu il n y a aucune ligne chargée
           IDLIG = 0
           IPLIG = NNOE
        end if
c 
c
***********************************************************************
***********************************************************************
c Il faut maintenant effectuer le calcul L1t X1 + L2t X2 = Nouveau F
c il ne s'agit que d'une remontée
c
c on va en profiter pour compter les mouvements d'ensemble
        iaa = 0
        segini itraa
c
c inumli : numero de la ligne en cours
        inumli = INC 
        do 120 ii0=NNOE,1,-1
           LIGN = ILIGN(ii0)
 122       continue
           if ((ii0.gt.IDLIG).or.(ii0.lt.IPLIG)) then
             segact /ERR=124/ LIGN
           else
             IDLIG = IDLIG - 1 
           end if
           NA = IMMM(/1)
         IFIB=IVPO(/1)
           call supde1(IPPVV(1),IVPO(1),VAL(1),VECTBB(1),
     &      MVECT1.VECTBB(1),na,inumli,inbine,iprel,ifib)
           do ibb=1,NA
            if (IMMM(ibb) .ne. 0) then
             iaa = iaa+1
             itraa(iaa)=iprel+ibb-1
            end if
           end do
           segdes LIGN*(NOMOD,MRU)
           GOTO 120
 124       CONTINUE 
c encore des problèmes mémoires
           if  (IDLIG .lt. IPLIG) then
             CALL ERREUR(5)
           else
             LIG1=ILIGN(IDLIG)
             SEGDES LIG1*(NOMOD,MRU)
             IDLIG=IDLIG-1
                 GOTO 122 
           end if
 120    continue

        segsup MVECTD
        MVECTD = MVECT1 
c
*******************************************************************************
*******************************************************************************
c gestion des déplacements de corps rigide
c meme chose que dans MONDES
c                     ------
c
      if (nens .ne. 0) then
        MINCPO = IINCPO
        MIMIK = IIMIK
        segact MINCPO,MIMIK
        ipt2 = IGEOMA
        segact ipt2
        NNOE = INCPO(/2)
        IINC1=INCPO(/1)
c
        XMA = 0.
        do kk=1,INC
         XMA=MAX(XMA,ABS(VECTBB(kk))) 
        end do
        XMA = XMA * 1.E-10
c boucle sur les mouvements d'ensemble
        do 200 ia=1,NENS
          i1=itraa(ia)
          j=IPNO(i1)
          do 210 k=1,iinc1
            if(INCPO(K,J).eq.i1) goto 220
 210      continue
          call erreur(5)
          return
 220      continue
          if ((ittr(i1).eq.0).and.(ABS(VECTBB(i1)).le.XMA)) GOTO 250
          if ((ittr(i1).ne.0).and.(ABS(VECTBB(i1)).le.XMA*1E7)) GOTO 250
          MOTERR(1:4)=IMIK(k)
          INTERR(1)=ipt2.NUM(1,J)
          CALL ERREUR(149)
          RETURN
 250      continue
          jjk = ipt2.NUM(1,J)
          IF(ITTR(I1).EQ.0) WRITE(IOIMP,280) JJK,IMIK(K)

          IF (IIMPI.NE.0 .AND. ITTR(I1).NE.0)
     &                WRITE(IOIMP,290) JJK,IMIK(K)

 200    continue
  280 FORMAT(' INDETERMINATION DETECTEE AU NOEUD ',I6,' INCONNUE ',
     *   A4,/,' INDETERMINATION LEVEE PAR LA MISE A ZERO DE ',
     * 'LA SUSDITE')
  290 FORMAT(' INDETERMINATION ENTRE CONDITIONS IMPOSEES DETECTEE ',
     * 'AU NOEUD ',I6,' INCONNUE ',A4,/,' INDETERMINATION LEVEE ',
     * 'PAR LA SUPPRESSION DE LA CONDITION REDONDANTE ')

        segdes MINCPO,MIMIK
          segdes ipt2
      end if
c
*******************************************************************************
*******************************************************************************
* un petit coup de normalisation
        do 300 ii1=1,INC
            VECTBB(ii1) = VECTBB(ii1) * DNOR(ii1)
 300    continue

        segdes MDNOR
        segdes MVECTD
        MVECTX = MVECTD
        MMATRX = MMATRI
        MRIGTX = MRIGTO
*        write(6,*) ' mrigto mmatri mvectx ', mrigto,mmatri,mvectx
c il faut transformer ce vecteur en chpoint
        call VCH1(MMATRX,MVECTX,ISOLU,MRIGTX)
        if (lagdua.ne.0) call dbbcf(isolu,lagdua)
**      write (6,*) ' mdext '
**      call ecchpo(mdext,0)
**      write (6,*) ' isolu '
**      call ecchpo(isolu,0)
        call adchpo(isolu,mdext,mchpoi,1.d0,1.d0)
*       mchpoi=isolu
        segact MCHPOI*mod
        JATTRI(1)=1
        segdes MCHPOI
 
        segdes MMATRI
c il faut maintenant rajouter les déplacements imposés éliminés (jrcond)
        MRIGID = MRIGTO
*        segact MRIGID
        segdes MRIGID
c
        segdes MSUPER
c il faut ajuster le type du champ

c on rajoute les multiplicateurs interfaces
        call ecrobj('CHPOINT ',mchpoi)

c désactivation de la pile MRU
        call OOOMRU(0)
        return 
        end