C COMALO    SOURCE    CB215821  24/04/12    21:15:19     11897          
      SUBROUTINE COMALO(ipmode,itruli,ipmel)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*--------------------------------------------------------
* CF DEVALO.ESO et DEVTRA.ESO
* indexe infos deformees modales , deplacements
*--------------------------------------------------------
-INC SMCOORD
-INC DECHE

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCHAML
-INC SMELEME
-INC SMMODEL
-INC SMLENTI
-INC CCREEL
*
      segment wrktvu
        integer jtvu(lilmel(/1))
      endsegment
      segment mwinit
        integer jpdep,jpvit,jrepr
      endsegment
*
*     Segment des variables generalisees:
*
      SEGMENT,MTQ
         REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
         REAL*8 WEXT(NA1,2),WINT(NA1,2)
      ENDSEGMENT
      SEGMENT,MTKAM
         REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
         REAL*8 XOPER(NB1,NB1,NOPER)
      ENDSEGMENT

* Segment pour Champoints
      SEGMENT,MSAM
         integer jplibb(NPLB)
      ENDSEGMENT
*
*** segment sous-structures dynamiques
      segment struli
       integer itlia,itbmod,momoda, mostat,itmail,molia
       integer ldefo(np1),lcgra(np1),lsstru(np1)
       integer nsstru,nndefo,nliab,nsb,na2,idimb
       integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
       INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
* ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
       INTEGER ICHAIN
      endsegment

      SEGMENT MOLIAI
         integer modtla,modtlb
      ENDSEGMENT
*
*     Segment de travail pour reprise force POLYNOMIALE base A
*
      SEGMENT,MTRA
         INTEGER IPLA(NTRA)
      ENDSEGMENT

      SEGMENT,ICPR(nbpts)
      SEGMENT,MCPR(nbpts)
      SEGMENT,MPREF
         INTEGER IPOREF(NPREF)
      ENDSEGMENT
      segment icma(0)
      segment icnna2(0)
      PARAMETER (MDEPL=20)
      LOGICAL REPRIS,LMODYN,RIGIDE,ilogmo,ilogst,ilogre,L0,LVA1,LVAR
      CHARACTER*4 LISDEP(MDEPL),LISVIT(MDEPL),TESDEP
      CHARACTER*6  MO2
      CHARACTER*8 CMOT,TYPRET,MORIGI,CHARRE
      CHARACTER*10 MO1
      CHARACTER*40 MONMOT
      DATA LISDEP/ 'UX  ','UY  ','UZ  ','UR  ','UT  ','RX  ','RY  ',
     &'RZ  ','RT  ','ALFA','BETA','IUX ','IUY ','IUZ ','IUR ','IUT ',
     &'IRX ','IRY ','IRZ ','IRT '/
      DATA LISVIT/ 'VTX ','VTY ','VTZ ','VTR ','VTT ','VWX ','VWY ',
     &'VWZ ','VWT ','VALF','VBET','IVTX','IVTY','IVTZ','IVTR','IVTT',
     &'IVWX','IVWY','IVWZ','IVWT'/
*
*     si IFOMOD = -1  :  mod?le PLAN
*     si IFOMOD =  0  :  mod?le AXIS
*     si IFOMOD =  1  :  mod?le FOUR
*     si IFOMOD =  2  :  mod?le TRID
*
*
      ITREP  = 0
      MTQ    = 0
      MTKAM  = 0
      MTPHI  = 0
      MTLIAA = 0
      MTLIAB = 0
      MTFEX  = 0
      MTPAS  = 0
      MTRES  = 0
      MTNUM  = 0
      MTRA   = 0
      XTINI  = 0.D0
      ITLA = 0
      ITLB = 0
      REPRIS = .FALSE.

      lilmel = ipmel
      struli = itruli
      jliaib = 0
      nmost = 0
      nmost0 = 0
      kovaen = 0
      kovare = 0
* identifie materiau MODAL ou STATIQUE

          itmod = ipmode
*
         call ecrcha('MODAL')
          call ecrcha('MATE')
          call ecrobj('MMODEL',ITMOD)
          call exis
          call lirlog(ilogmo,0,iret)
         IF (ilogmo) THEN
           call ecrcha('MECANIQUE')
           call ecrcha('FORM')
           call ecrobj('MMODEL',ITMOD)
           call extrai
           call lirobj('MMODEL',momod1,0,iret)
           call ecrcha('MODAL')
           call ecrcha('MATE')
           call ecrobj('MMODEL',momod1)
           call extrai
           call lirobj('MMODEL',ipmodz,0,iret)
           momoda = ipmodz
           mmode1 = ipmodz
           segact mmode1
           nmost0 = mmode1.kmodel(/1)
           nmost = nmost + nmost0
         ENDIF
          call ecrcha('STATIQUE')
          call ecrcha('MATE')
          call ecrobj('MMODEL',ITMOD)
          call exis
          call lirlog(ilogst,0,iret)
         IF (ilogst) THEN
            call ecrcha('MECANIQUE')
           call ecrcha('FORM')
           call ecrobj('MMODEL',ITMOD)
           call extrai
           call lirobj('MMODEL',momod1,0,iret)
           call ecrcha('STATIQUE')
           call ecrcha('MATE')
           call ecrobj('MMODEL',momod1)
           call extrai
           call lirobj('MMODEL',ipmodz,0,iret)
           mostat = ipmodz
           mmode1 = ipmodz
           segact mmode1
           nmost = nmost + mmode1.kmodel(/1)
         ENDIF
         na1 = nmost
         mmode2 = itlia
         segact mmode2
         nliat = mmode2.kmodel(/1)
         mmode1 = ipmode
         segact mmode1
         ilogre = (mmode1.kmodel(/1) - na1 - nliat).gt.0

         n1 = nmost
         segini mmodel
         mmode1 = momoda
         do im = 1,nmost0
           kmodel(im) = mmode1.kmodel(im)
         enddo
         IF (ilogst) THEN
         mmode1 = mostat
         do im = 1,mmode1.kmodel(/1)
           kmodel(nmost0 + im) = mmode1.kmodel(im)
         enddo
         ENDIF
         itbmod = mmodel
         np1 = nmost
         segadj struli
*
* collecte deplacements, vitesses, deformation , centre gravite
          segini wrktvu
          iptvu = wrktvu
          do 2010 mvu = 1,lilmel(/1)
           deche = lilmel(mvu)
           if(ilogmo) then
            if (nomdec.eq.'ALFA    '.and.indec.eq.1) then
              jtvu(mvu) = 101
              goto 2010
            endif
            if (nomdec.eq.'ALFA    '.and.indec.gt.1) then
              jtvu(mvu) = 102
              goto 2010
            endif
            if (nomdec.eq.'FALF    '.and.indec.gt.1) then
              jtvu(mvu) = 105
              goto 2010
            endif
            if (nomdec.eq.'VALF    '.and.indec.eq.1) then
              jtvu(mvu) = 106
              goto 2010
            endif
            if (nomdec.eq.'VALF    '.and.indec.gt.1) then
              jtvu(mvu) = 107
              goto 2010
            endif
           endif
           if(ilogst) then
             if (nomdec.eq.'BETA    '.and.indec.eq.1) then
              jtvu(mvu) = 201
              goto 2010
            endif
            if (nomdec.eq.'BETA    '.and.indec.gt.1) then
              jtvu(mvu) = 202
              goto 2010
            endif
            if (nomdec.eq.'FBET    '.and.indec.gt.1) then
              jtvu(mvu) = 205
              goto 2010
            endif
            if (nomdec.eq.'VBET    '.and.indec.eq.1) then
              jtvu(mvu) = 206
              goto 2010
            endif
            if (nomdec.eq.'VBET    '.and.indec.gt.1) then
              jtvu(mvu) = 207
              goto 2010
            endif
           endif
           if(ilogmo.or.ilogst) then
            if (nomdec.eq.'DEFO    '.and.indec.gt.1) then
               jtvu(mvu)= 302
               goto 2010
            endif
            if (nomdec.eq.'AMOR    '.and.indec.gt.1) then
               jtvu(mvu)= 305
               goto 2010
            endif
           endif
           if(ilogmo) then
            if (nomdec.eq.'CGRA    '.and.indec.gt.1) then
               jtvu(mvu)= 303
               goto 2010
            endif
            if (nomdec.eq.'FREQ    '.and.indec.gt.1) then
               jtvu(mvu)= 304
               goto 2010
            endif
            if (nomdec.eq.'MASS    '.and.indec.gt.1) then
               jtvu(mvu)= 305
               goto 2010
            endif
           endif
          if (ilogre) then
           do mdep = 1,MDEPL
             if (nomdec(1:4).eq.lisdep(mdep)) then
               jtvu(mvu)= mdep
               goto 2010
             endif
             if (nomdec(1:4).eq.lisvit(mdep)) then
               jtvu(mvu)= mdep * (-1)
               goto 2010
             endif
           enddo
          endif

          if (nomdec.eq.'SORT    ') then
            jtvu(mvu) = 501
            goto 2010
          endif

          if (nomdec.eq.'VAEN    ') then
            jtvu(mvu) = 506
            kovaen = kovaen + 1
            goto 2010
          endif

          if (nomdec.eq.'VARE    ') then
            jtvu(mvu) = 507
            kovare = kovare + 1
            goto 2010
          endif


          jtvu(mvu) = -100

 2010     continue

      IK = 0
      SEGINI,ICPR
      LCPR = nbpts

       MMODEL = itbmod
       segact MMODEL
       do 60 im = 1,kmodel(/1)
         imodel = kmodel(im)
         segact imodel*nomod
          meleme = imamod
          segact meleme
* a priori 1 seul point
          do ip = 1,num(/2)
            knoe = num(1,ip)
            IF (KNOE.NE.0) THEN
               IF (ICPR(KNOE).EQ.0) THEN
                  IK = IK + 1
                  ICPR(KNOE) = IK
      IF (IIMPI.EQ.333) THEN
      WRITE(IOIMP,*)'COMALO : basemo. ICPR(',KNOE,')=',ICPR(KNOE)
      ENDIF
               ENDIF
            ENDIF
          enddo
 60    continue
*

*
*     5/ Cr{ation du segment d{finissant les points supports:
*
      NPREF = IK
      SEGINI,MPREF
      KPREF = MPREF
      ikpref = KPREF
      DO 100 I=1,LCPR
         IF (ICPR(I).NE.0) THEN
            IREF = ICPR(I)
            IPOREF(IREF) = I
            IF (IIMPI.EQ.333) THEN
               WRITE(IOIMP,*)'COMALO : IPOREF(',IREF,')=',IPOREF(IREF)
            ENDIF
         ENDIF
 100  CONTINUE

*
* creation et remplissage MTQ (revoir indices dans DYNE 1=actuel 2=avant)
*
      NA1 = nmost
      NB1K = 1
      NB1C = 1
      NB1M = 1
      NB1  = 1
      NOPER = 0
      segini MTQ,MTKAM
      ktq = MTQ
      ktkam = MTKAM
      do ia1 = 1,na1
        xk(ia1,1) = 1.d0
      enddo
      mmodel = itbmod

      do 3010 mvu = 1,lilmel(/1)
        if (jtvu(mvu).ne.101.and.jtvu(mvu).ne.102.and.
     &jtvu(mvu).ne.106.and.jtvu(mvu).ne.107.and.
     &jtvu(mvu).ne.201.and.jtvu(mvu).ne.202.and.
     &jtvu(mvu).ne.206.and.jtvu(mvu).ne.207.and.
     &jtvu(mvu).ne.105.and.jtvu(mvu).ne.205.and.
     &jtvu(mvu).ne.304.and.jtvu(mvu).ne.305) goto 3010
           deche = lilmel(mvu)
              melval = ABS(ieldec)
**            segact melval

            do 3050 im = 1,kmodel(/1)
             imodel = kmodel(im)
             if (imadec.ne.imamod.or.
     &           condec(1:LCONMO).ne.conmod(1:LCONMO)) goto 3050
              meleme = imamod
              IA = ICPR(num(1,1))
* en gros ordre du MMODEL
           if (nomdec.eq.'ALFA    '.or.nomdec.eq.'BETA    ') then
              if (indec.eq.1) Q1(ia,2) = velche(1,1)
              if (indec.gt.1) Q1(ia,1) = velche(1,1)
              q1(ia,3) = q1(ia,2)
           endif
           if (nomdec.eq.'VALF    '.or.nomdec.eq.'VBET    ') then
              if (indec.eq.1) Q2(ia,2) = velche(1,1)
              if (indec.gt.1) Q2(ia,1) = velche(1,1)
              q2(ia,3) = q2(ia,2)
           endif
           if (nomdec.eq.'FALF    '.or.nomdec.eq.'FBET    ') then
              if (indec.gt.1) then
                Q3(ia,2) = velche(1,1)
              endif
           endif
           if (nomdec.eq.'FREQ    ') then
             OMEGA = velche(1,1) * 2.d0* xpi
             xk(ia,1) = xk(ia,1) * omega * omega
           endif
           if (nomdec.eq.'MASS    ') then
             xm(ia,1) = velche(1,1)
             xk(ia,1) = velche(1,1) * xk(ia,1)
           endif
           if (nomdec.eq.'AMOR    ') then
             xasm(ia,1) = velche(1,1)
           endif
           goto 3009
 3050       continue
 3009        continue
***           segdes melval

 3010 continue
         segsup icpr

 5001    continue

*  (kich : traitement sur base modale-stat pour l instant)
*
         ipmodz = itbmod
         call ecrcha('MAIL')
         call ecrobj('MMODEL',ipmodz)
         call extrai
         call lirobj('MAILLAGE',ipt1,0,iret)
         itmail = ipt1
         if (ierr.ne.0) return
         if (iret.ne.1) then
          write(6,*) 'pb developpement comalo'
          ierr = 2
          return
         endif
         segact ipt1
         segini mcpr
         do ie = 1,ipt1.num(/2)
          mcpr(ipt1.num(1,ie)) = 1
         enddo

         mmodel = itlia
         segact mmodel
         n1 = kmodel(/1)
         segini mmode1,mmode2
         klia = 0
         klib = 0
         do ik = 1,kmodel(/1)
           imodel = kmodel(ik)
* liaisons issues de DYNE
           segact imodel
           meleme = imamod
           if (imatee.lt.23) then
           segact meleme

           if (mcpr(num(1,1)).gt.0) then
             klia = klia + 1
             mmode1.kmodel(klia) = imodel
           else
             klib = klib + 1
             mmode2.kmodel(klib) = imodel
           endif

           endif
         enddo
         nliady = klia+klib
         n1 = klia
         itla = mmode1
         segadj mmode1
         n1 = klib
         segadj mmode2
         itlb = mmode2
         segsup mcpr
         segini moliai
         modtla = itla
         if (klia.eq.0) modtla = 0
         modtlb = itlb
         if (klib.eq.0) modtlb = 0
* distingue liaisons A et B
         IMOLIA = MOLIAI
         molia = moliai

* recense variables internes de continuation, rustique !
         if (kovare.eq.kovaen.and.kovare.eq.klia + klib) then
           segsup wrktvu
           return
         endif

*
* dimensionnement MTPHI : repere les deformees modales
       wrktvu =iptvu

       segini icma,icnna2
       MMODEL = itbmod
       segact MMODEL
       kstru = 0
       kdefo = 0
       do 50 im = 1,kmodel(/1)
         imodel = kmodel(im)
         segact imodel*nomod
          meleme = imamod
          segact meleme
** recherche sommaire nombre de sous-structures independantes (NSB)
** nombre maxi de modes pour une meme sous-structure (NA2)
        do 46 in = 1,jtvu(/1)
          if (jtvu(in).ne.302.and.jtvu(in).ne.303) goto 46
          deche = lilmel(in)
          if (condec(1:16).ne.conmod(1:16).or.imamod.ne.imadec) goto 46

* assume point support reduit a 1 point
            if (nomdec(1:4).eq.'CGRA') then
* recherche corps rigide
              if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
              if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
              melval = ABS(ieldec)
**            segact melval
              icdg = ielche(1,1)
              lcgra(im) = icdg
**            segdes melval
            else if (nomdec(1:4).eq.'DEFO') then
              melval = ABS(ieldec)
**            segact melval
* assume que le maillage modele  se reduit au point support
              icdef1 = ielche(1,1)
**            segdes melval
              call ecrcha('NOMU')
              call ecrcha('MAIL')
              call ecrobj('CHPOINT ',icdef1)
              call extrai
              call lirobj('MAILLAGE', icmaio,1,iret)
              if (ierr.ne.0) return
              if (kstru.eq.0)  goto 44

                ipt5 = icmaio
                do ic = 1,kstru
                  icmic = icma(ic)
                  CALL INTERB(icmaio,icmic,IRETIB,icinte)
                  if (iretib.eq.0) then
                     ipt6 = icinte
                     segact ipt6,ipt5
                     if (ipt5.num(/2).eq.ipt6.num(/2)) then
                       segsup ipt6
                       icnna2(ic) = icnna2(ic) + 1
                       lsstru(im) = ic
                       goto 45
                     endif
                     segsup ipt6
                  endif
                enddo
 44            continue
                kstru = kstru + 1
                icma(**) = icmaio
                icnna2(**) = 1
                lsstru(im) = kstru
 45            continue
            do ism = 1,im
             if (icdef1.ne.0.and.icdef1.eq.ldefo(ism)) then
c        write(6,*) 'deformee ',icdef1,'utilisee autre support', ism,im
            call erreur(26)
             return
             endif
            enddo
            ldefo(im) = icdef1
            kdefo = kdefo + 1
              goto 46
            endif
 46     continue
            if (ldefo(im).eq.0) then
c               write(6,*) 'manque deformee modale pour support', imamod
               call erreur(26)
               return
            endif

  47     continue
 49      continue
 50      continue
            NSB = icma(/1)
            NA2 = icnna2(1)
            do ic = 1,icnna2(/1)
             na2 = MAX(icnna2(ic),NA2)
            enddo
            nsstru = kstru
            nndefo = kdefo
            if (nndefo.ne.nmost) then
                call erreur(26)
                return
            endif
         if (nsstru.ne.nsb) then
                call erreur(26)
                return
            endif
            segsup icma,icnna2
         segsup wrktvu
*
      RETURN
      END