C VARIN6    SOURCE    KICH      11/08/11    21:16:11     7079           
      SUBROUTINE VARIN6(ipmode,icara)
*
* cree compos facultatives modele modal et statique
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC SMCHAML
-INC SMMODEL
-INC CCOPTIO
-INC SMLREEL
-INC SMLMOTS
-INC SMELEME
-INC CCNOYAU
-INC CCREEL
-INC SMLENTI
*
      LOGICAL dricr,dmacr,damcr
      CHARACTER*4 lesinc(8),lesdua(8)
      DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR','UT'/
      DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR','FT'/
      POINTEUR MLENT4.MLENTI,MLENT5.MLENTI,MLENT6.MLENTI,
     &MLENT7.MLENTI,MLENT8.MLENTI,MLENT9.MLENTI,MLEN10.MLENTI
      POINTEUR MLREAM.MLREEL,MLREE4.MLREEL,MLREE5.MLREEL
C
* 0 : point support, 1: imodel, 2: mchaml, 3: defo, 
* 4: ricr , 5: maia, 6, maib, 7: macr, 8: imade, 9: itreac, 10: amcr
      jgn = 4
       if (ifour.eq.2) then
      jgm = 6
      segini mlmots
      iinc = mlmots
      do igm = 1,jgm
       mots(igm) = lesinc(igm)
      enddo
      segini mlmots
      idua = mlmots
      do igm= 1,jgm
       mots(igm) = lesdua(igm)
      enddo
       else if (ifour.lt.0) then
      jgm = 4
      segini mlmots
      iinc = mlmots
       mots(1) = lesinc(1)
       mots(2) = lesinc(2)
       mots(3) = lesinc(4)
       mots(4) = lesinc(5)
      segini mlmots
      idua = mlmots
       mots(1) = lesdua(1)
       mots(2) = lesdua(2)
       mots(3) = lesdua(4)
       mots(4) = lesdua(5)
       else if (ifour.eq.0) then
      jgm = 3
      segini mlmots
      iinc = mlmots
       mots(1) = lesinc(7)
       mots(2) = lesinc(3)
       mots(3) = lesinc(6)
      segini mlmots
      idua = mlmots
       mots(1) = lesdua(7)
       mots(2) = lesdua(3)
       mots(3) = lesdua(6)
       else if (ifour.eq.1) then
* a faire
       endif       

        mchelm = icara
      segact mchelm

      mmodel = ipmode
      segact mmodel
        NBELEM = kmodel(/1)
      do im = 1,kmodel(/1)
        imodel = kmodel(im)
        segact imodel
      enddo

        NBNN = 1
        NBELEM = kmodel(/1)
        JG = NBELEM
        segini mlenti,mlent1,mlent2
        JG = 0

      do im = 1,kmodel(/1)
        imodel = kmodel(im)
        if (cmatee.eq.'STATIQUE'.OR.cmatee.eq.'MODAL') then
         meleme = imamod
         segact meleme
         JG = JG + 1
* a ameliorer si maillage non reduit à un point
         lect(JG) = num(1,1)
         segdes meleme
         mlent1.lect(JG) = imodel
         do isous = 1,imache(/1)
        if (imache(isous).eq.imamod.and.conche(isous).eq.conmod) then
          mchaml = ichaml(isous)
          segact mchaml*mod
          mlent2.lect(JG) = mchaml
        endif
         enddo
        else
         segdes imodel
        endif
      enddo
      segadj mlenti,mlent1,mlent2
      JG0 = JG
      segini mlent3,mlent4,mlent5,mlent6,mlent7,mlent8,mlent9,mlen10
      segini mlream

      do jjgg = 1,mlent1.lect(/1)
        imodel = mlent1.lect(jjgg)
        itreac = 0 
        imade = 0
        idepl = 0
          Xm1 = 0.d0
          mchaml = mlent2.lect(jjgg)
           do ie = 1,ielval(/1)
            if (NOMCHE(IE).eq.'DEFO'.and.mlent3.lect(jjgg).eq.0) then
             MELVA5 = ielval(ie)
             segact melva5
             idepl = melva5.ielche(1,1)
             segdes melva5
             mlent3.lect(jjgg)= idepl
            endif
            if (NOMCHE(IE).eq.'AMOR') then
             MELVA5 = ielval(ie)
             segact melva5
             xam0 = melva5.velche(1,1)
             segdes melva5
             mlream.prog(jjgg)= xam0
            endif
       if (cmatee.eq.'STATIQUE') then
            if (NOMCHE(IE).eq.'MADE') then
             MELVA6 = ielval(ie)
             segact melva6
             imade = melva6.ielche(1,1)
              mlent8.lect(jjgg) = melva6.ielche(1,1)
             segdes melva6
            endif
            if (NOMCHE(IE).eq.'RIDE') then
             MELVA4 = ielval(ie)
             segact melva4
             itreac = melva4.ielche(1,1)
              mlent9.lect(jjgg) = melva4.ielche(1,1)
             segdes melva4
            endif
       endif
           enddo

       if(idepl.le.0) then
         call erreur(26) 
         return
       endif
       if (cmatee.eq.'STATIQUE') then
          if (itreac.le.0.or.imade.le.0) then
           call erreur(26)
           return
          endif
       endif
           
           NBNN = 1
           NBELEM = JG
           NBSOUS = 0
           NBREF = 0

        if(mlent4.lect(jjgg).eq.0) then
            segini mlreel
          mlent4.lect(jjgg) = mlreel
        endif
        if(mlent5.lect(jjgg).eq.0.and.cmatee.eq.'STATIQUE') then
            segini ipt1
          mlent5.lect(jjgg) = ipt1
           ipt1.ITYPEL = 1
        endif
        if(mlent6.lect(jjgg).eq.0) then
            segini ipt1
          mlent6.lect(jjgg) = ipt1
           ipt1.ITYPEL = 1
        endif
        if(mlent7.lect(jjgg).eq.0) then
            segini mlreel
          mlent7.lect(jjgg) = mlreel
        endif
        if(mlen10.lect(jjgg).eq.0) then
            segini mlreel
          mlen10.lect(jjgg) = mlreel
        endif
* boucle jjgg
      enddo
 

      do jjgg = 1,mlent1.lect(/1)
        imodel = mlent1.lect(jjgg)
       if (cmatee.eq.'STATIQUE') then
        itreac = mlent9.lect(jjgg)
        imade = mlent8.lect(jjgg)


          do jg2 = 1,mlent1.lect(/1)
            imode2 = mlent1.lect(jg2)
       if (jg2.lt.jjgg.and.imode2.cmatee.eq.'STATIQUE') goto 21
             idepl = mlent3.lect(jg2)
          Xk1 = 0.d0
          Xm1 = 0.d0
            
          CALL XTY1(idepl,itreac,iinc,idua,Xk1)  
          if (ierr.ne.0) return
          if (dabs(Xk1).gt.dble(xspeti)) then
            mlreel = mlent4.lect(jjgg)
            prog(jg2) = Xk1
* rangement symetrique
            mlreel = mlent4.lect(jg2)
            prog(jjgg) = Xk1
           if (imode2.cmatee.eq.'MODAL')  then
* croisé ALFA - BETA
              ipt1 = mlent5.lect(jjgg)
              ipt1.num(1,jg2) = lect(jg2)
              ipt1 = mlent6.lect(jg2)
              ipt1.num(1,jjgg) = lect(jjgg)
            elseif (imode2.cmatee.eq.'STATIQUE') then
              ipt1 = mlent6.lect(jjgg)
              ipt1.num(1,jg2) = lect(jg2)
              ipt1 = mlent6.lect(jg2)
              ipt1.num(1,jjgg) = lect(jjgg)
            endif
          endif

          xm1 = 0.d0
          if(imade.gt.0) CALL XTY1(idepl,imade,iinc,idua,Xm1)  
          if (ierr.ne.0) return
          if (dabs(xm1).gt.dble(xspeti)) then
            mlreel = mlent7.lect(jjgg)
            prog(jg2) = Xm1
* rangement symetrique
            mlreel = mlent7.lect(jg2)
            prog(jjgg) = Xm1
           if (dabs(Xk1).le.dble(xspeti)) then
           if (imode2.cmatee.eq.'MODAL')  then
* croisé ALFA - BETA
              ipt1 = mlent5.lect(jjgg)
              ipt1.num(1,jg2) = lect(jg2)
              ipt1 = mlent6.lect(jg2)
              ipt1.num(1,jjgg) = lect(jjgg)
            elseif (imode2.cmatee.eq.'STATIQUE') then
              ipt1 = mlent6.lect(jjgg)
              ipt1.num(1,jg2) = lect(jg2)
              ipt1 = mlent6.lect(jg2)
              ipt1.num(1,jjgg) = lect(jjgg)
            endif
            endif
* amortissement homologue à la masse
            xamo1 = mlream.prog(jg2) 
            xamo2 = mlream.prog(jjgg)
        xamo3 = xamo1*xamo2
         if (xamo3.eq.0.) then
          xamo = 0.
         else
          if (jg2.eq.jjgg) then
           xamo = dsqrt(dabs(xamo3*Xm1*Xk1))
          else
           xamo = dsqrt(dabs(xamo3))*Xm1
          endif
          if (xamo3.lt.0) xamo = xamo * (-1.d0)
          mlreel = mlen10.lect(jjgg)
          prog(jg2) = xamo
          mlreel = mlen10.lect(jg2)
          prog(jjgg) = xamo
         endif
*
          endif


  21        continue
* boucle jg2
          enddo
       endif
* boucle jjgg
      enddo

      do jjgg = 1,mlent5.lect(/1)
        NBELEM = 0
        ipt1 = mlent5.lect(jjgg)
        mlreel = mlent4.lect(jjgg)
       if (mlreel.gt.0) then
        segini,mlree1=mlreel
       else 
        mlreel = -1
       endif
        mlree2 = mlent7.lect(jjgg)
       if (mlree2.gt.0) then
        segini,mlree3=mlree2
       else 
        mlree2 = -1
       endif
*       write(6,*) jjgg, lect(jjgg),(prog(ii), ii = 1,prog(/1))
        mlree4 = mlen10.lect(jjgg)
       if (mlree4.gt.0) then
        segini,mlree5=mlree4
       else 
        mlree4 = -1
       endif
        if (ipt1.gt.0) then
          do jg2 = 1,mlent5.lect(/1)
           if (ipt1.num(1,jg2).ne.0) then 
             NBELEM = NBELEM + 1
            if (jg2.eq.NBELEM) then
            else
             ipt1.num(1,NBELEM) = ipt1.num(1,jg2)
             if (mlreel.gt.0) then
              prog(NBELEM) = mlree1.prog(jg2)
             endif
             if (mlree2.gt.0) then
              mlree2.prog(NBELEM) = mlree3.prog(jg2)
             endif
             if (mlree4.gt.0) then
              mlree4.prog(NBELEM) = mlree5.prog(jg2)
             endif
            endif 
           endif
          enddo
           segadj ipt1
           segdes ipt1
        endif
        if (NBELEM.eq.0) then
         segsup ipt1 
         mlent5.lect(jjgg) = 0
        endif
        ipt1 = mlent6.lect(jjgg)
       JG0 = NBELEM
        NBELEM = 0
        if (ipt1.gt.0) then
          do jg2 = 1,mlent5.lect(/1)
*        write(6,*) ipt1,jg2,ipt1.num(1,jg2)
          if (ipt1.num(1,jg2).ne.0) then 
             NBELEM = NBELEM + 1
            if (jg2.eq.NBELEM) then
            else
             ipt1.num(1,NBELEM) = ipt1.num(1,jg2)
            endif 
*          write(6,*) jg2, NBELEM, mlree1.prog(jg2)
             if (mlreel.gt.0) then
              prog(JG0+NBELEM) = mlree1.prog(jg2)
             endif
             if (mlree2.gt.0) then
              mlree2.prog(JG0+NBELEM) = mlree3.prog(jg2)
             endif
             if (mlree4.gt.0) then
              mlree4.prog(JG0+NBELEM) = mlree5.prog(jg2)
             endif
           endif
          enddo
           segadj ipt1
           segdes ipt1
        endif
        JG = JG0 + NBELEM
        if (JG.GT.0 ) then
         if (mlreel.gt.0) then
          segadj mlreel
          segdes mlreel
          segsup mlree1
         endif
         if (mlree2.gt.0) then
          segadj mlree2
          segdes mlree2
          segsup mlree3
         endif
         if (mlree4.gt.0) then
          segadj mlree4
          segsup mlree5
          do iam=1,JG
           if (mlree4.prog(iam).ne.0) goto 32
          enddo
          segsup mlree4
          mlen10.lect(jjgg) = 0
          goto 33
 32       segdes mlree4
 33       continue 
        endif
        else
         if (mlreel.gt.0) then
          segsup mlreel,mlree1
          mlent4.lect(jjgg) = 0
         endif
         if (mlree2.gt.0) then
          segsup mlree2,mlree3
          mlent7.lect(jjgg) = 0
         endif
         if (mlree4.gt.0) then
          segsup mlree4,mlree5
          mlen10.lect(jjgg) = 0
         endif
        endif
        if (NBELEM.eq.0) then
         segsup ipt1 
         mlent6.lect(jjgg) = 0
        endif
      enddo


            N1PTEL=0
            N1EL  =0
            N2PTEL=1
            N2EL  =1
           
      do jjgg = 1,mlent1.lect(/1)
        imodel = mlent1.lect(jjgg)
          mchaml = mlent2.lect(jjgg)
          dricr = .true.
          dmacr = .true.
          damcr = .true.
          nu2 = ielval(/1)
          nu20 = nu2
           do ie = 1,nu20

          if (nomche(ie)(1:4).eq.'RICR'.and.mlent4.lect(jjgg).gt.0) then
              MELVA5 = ielval(ie)
              segact melva5
              mlree1 = melva5.ielche(1,1)
              segdes melva5
              mlreel = mlent4.lect(jjgg)
              segact mlreel,mlree1
              do 211 ig = 1,prog(/1)
                do ig1 = 1,mlree1.prog(/1)
          if(dabs(prog(ig) - mlree1.prog(ig1)).lt.
     &dble(xspeti)*dabs(mlree1.prog(ig1))) goto 211
                enddo
* non concordance données utilisateurs / calcul
                call erreur(26)
                return
 211          continue
              dricr = .false.
* on ne pousse pas trop la verif
          endif
          if (nomche(ie)(1:4).eq.'MACR'.and.mlent7.lect(jjgg).gt.0) then
              MELVA5 = ielval(ie)
              segact melva5
              mlree1 = melva5.ielche(1,1)
              segdes melva5
              mlreel = mlent7.lect(jjgg)
              segact mlreel,mlree1
              do 311 ig = 1,prog(/1)
                do ig1 = 1,mlree1.prog(/1)
          if(dabs(prog(ig) - mlree1.prog(ig1)).lt.
     &dble(xspeti)*dabs(mlree1.prog(ig1))) goto 311
                enddo
* non concordance données utilisateurs / calcul
                call erreur(26)
                return
 311          continue
              dmacr = .false.
* on ne pousse pas trop la verif
          endif
          if (nomche(ie)(1:4).eq.'AMCR'.and.mlen10.lect(jjgg).gt.0) then
              MELVA5 = ielval(ie)
              segact melva5
              mlree1 = melva5.ielche(1,1)
              segdes melva5
              mlreel = mlen10.lect(jjgg)
              segact mlreel,mlree1
              do 411 ig = 1,prog(/1)
                do ig1 = 1,mlree1.prog(/1)
          if(dabs(prog(ig) - mlree1.prog(ig1)).lt.
     &dble(xspeti)*dabs(mlree1.prog(ig1))) goto 411
                enddo
* non concordance données utilisateurs / calcul
                call erreur(26)
                return
 411          continue
              damcr = .false.
* on ne pousse pas trop la verif
          endif

           enddo

          n2 = nu2 + 5
          segadj mchaml

        if(mlent4.lect(jjgg).gt.0.and.dricr) then
          nu2 = nu2 + 1
          typche(nu2)='POINTEURLISTREEL'
          nomche(nu2)='RICR'
            SEGINI,MELVAL
            IELVAL(nu2) = MELVAL
            ielche(1,1) = mlent4.lect(jjgg)
        endif
        if(mlent5.lect(jjgg).gt.0.and.(dmacr.or.dricr)) then
          nu2 = nu2 + 1
          typche(nu2)='POINTEURMAILLAGE'
          nomche(nu2)='MAIA'
            SEGINI,MELVAL
            IELVAL(nu2) = MELVAL
            ielche(1,1) = mlent5.lect(jjgg)
        endif
        if(mlent6.lect(jjgg).gt.0.and.(dmacr.or.dricr)) then
          nu2 = nu2 + 1
          typche(nu2)='POINTEURMAILLAGE'
          nomche(nu2)='MAIB'
            SEGINI,MELVAL
            IELVAL(nu2) = MELVAL
            ielche(1,1) = mlent6.lect(jjgg)
        endif
        if(mlent7.lect(jjgg).gt.0.and.dmacr) then
          nu2 = nu2 + 1
          typche(nu2)='POINTEURLISTREEL'
          nomche(nu2)='MACR'
            SEGINI,MELVAL
            IELVAL(nu2) = MELVAL
            ielche(1,1) = mlent7.lect(jjgg)
        endif
        if(mlen10.lect(jjgg).gt.0.and.damcr) then
          nu2 = nu2 + 1
          typche(nu2)='POINTEURLISTREEL'
          nomche(nu2)='AMCR'
            SEGINI,MELVAL
            IELVAL(nu2) = MELVAL
            ielche(1,1) = mlen10.lect(jjgg)
        endif

        n2 = nu2
        segadj mchaml
        segdes mchaml
        segdes imodel
      enddo


       mlmots = idua
       segsup mlmots
       mlmots = iinc
       segsup mlmots
*
      do im = 1,kmodel(/1)
        imodel = kmodel(im)
        segact imodel
        if (cmatee.eq.'STATIQUE'.OR.cmatee.eq.'MODAL') then
         do isous = 1,imache(/1)
        if (imache(isous).eq.imamod.and.conche(isous).eq.conmod) then
          mchaml = ichaml(isous)
          segact mchaml
          n2 = ielval(/1)
          do in = 1,n2 
           melval = ielval(in)
           segact melval
            if(nomche(in).eq.'MAIA') then
               ipt1 = ielche(1,1)
               segact ipt1
            endif
            if(nomche(in).eq.'MAIB') then
               ipt1 = ielche(1,1)
               segact ipt1
            endif
          enddo
        endif
         enddo
       endif
      enddo
*
       segsup mlenti,mlent1,mlent2,mlent3,mlent4,mlent5,mlent6,mlent7
       segsup mlent8,mlent9,mlen10
       segsup mlream
       segdes mmodel
       segdes mchelm

      RETURN
      END