C ADETAT    SOURCE    KICH      12/06/05    21:15:00     7382           
      subroutine adetat
      implicit real*8(a-h,o-Z)
      implicit integer (i-n)
*
* on ene travaille que sur les formulation mecanique et poreux
* et LIAISON (kich)
     
-INC CCOPTIO
-INC SMCHAML
-INC SMCHPOI
-INC SMMODEL
-INC SMCHARG
-INC SMTABLE
      segment limode(0)
      parameter (nnonom=11, nnoind=8, nnofor=5)
      character*22 indic(nnoind)
      dimension ilo(nnoind)
      character*16 mformu(nnofor)
      character*8 ctyp,mtyp,chai1,chai2
      logical ibo
      character*4 init(1),nomc,nonom(nnonom)
      data nonom/'MECA','DIMP','TIMP','DEFI','TECO',
     $           'TERA','Q   ','REAC','CIMP','UIMP','FORC' /
      data init/'NOUV'/ 
      data indic /'DEPLACEMENTS          ','CONTRAINTES           ',
     &            'TEMPERATURES          ','VARIABLES_INTERNES    ',
     &            'DEFINELA              ','PROPORTIONS_PHASE     ',
     &            'CONCENTRATIONS        ','POTENTIELS_ELECTRIQUES'/
      data ilo / 12, 11, 12, 18, 8, 17, 14, 22 /
      data mformu /'MECANIQUE       ','POREUX          ',
     &             'LIAISON         ','DIFFUSION       ',
     &             'ELECTROSTATIQUE '/

      call lirmot(init,1,initia,0)
      if(initia.eq.0)then
         mchelm=0
         call lirobj('MCHAML',mchelm,1,iretou)
         if(ierr.ne.0) return
         segini,mchel2=mchelm
         n1=mchel2.ichaml(/1)
         n3=mchel2.infche(/2)
         l1=16
      else
        n1=0
        n3=6
        l1=16
        segini mchel2
        mchel2.ifoche=ifour
      endif
      mchel2.TITCHE='cree par adetat'
      call lirobj ('MMODEL',mmodel,1,iretou)
      if (ierr.ne.0) then
        segsup,mchel2
        return
      endif

      n1io=n1
      itrouv=0
      SEGACT MMODEL
      NSOUS=MMODEL.KMODEL(/1)
      segini limode
      do im = 1,NSOUS
        imodel = kmodel(im)
        segact imodel
        limode(**) = imodel
        if (formod(1).eq.'MELANGE') then
          if (ivamod(/1).ge.1) then
          itrouv=1
            do ivm1 = 1,ivamod(/1)
              if (tymode(ivm1).eq.'IMODEL') then
                   limode(**) = ivamod(ivm1)
              endif
            enddo
          endif
        endif
      enddo
      if (itrouv.eq.0) go to 1162
      segdes mmodel
* test non redondance
       N1 = 1
      if (limode(/1).gt.1) then
       do 1161 it1 = limode(/1),2,-1
        imode1 = limode(it1)
        segact imode1
         do it2 = (it1 - 1) ,1,-1
          imode2 = limode(it2)
          segact imode2
          if (imode1.imamod.eq.imode2.imamod.and.
     & imode1.conmod.eq.imode2.conmod) then
           limode(it1) = 0
           goto 1161
          endif
         enddo
         N1 = N1 + 1
 1161  continue
      endif

      is1 = 0
      if (limode(/1).gt.0) then
       segini,mmodel
       do is = 1,limode(/1)
         if (limode(is).gt.0) then
           is1 = is1 + 1
           kmodel(is1) = limode(is)
         endif
       enddo
      else
      endif
 1162 continue
      segsup limode
      mmode1=mmodel
      N1=NSOUS
      NZON=0 
      
* on compte combien de formulations incluses dans mformu
      DO 1119 I=1,NSOUS
           IMODEL=MMODE1.KMODEL(I)
           SEGACT IMODEL
           NFOR=FORMOD(/2)
           IF(NFOR.EQ.1) THEN
             CALL PLACE(mformu,nnofor,iplac,FORMOD(1))
             if (iplac.EQ.0) GOTO 1119
           ELSE IF(NFOR.EQ.2) THEN
             CALL PLACE(mformu,2,iplac,FORMOD(1))
             if (iplac.EQ.0) GOTO 1119
             CALL PLACE(mformu,2,iplac,FORMOD(2))
             if (iplac.EQ.0) GOTO 1119
           ELSE
            GO TO 1119
           ENDIF
*  on vient ici pour prendre les sous modeles
           NZON=NZON+1            
1119     CONTINUE
*on recommence
         mmodel=mmode1   
         if( nzon.ne.nsous.and.nzon.ne.0) then
            n1=nzon
            nzon=0 
            segini mmodel
            DO 1129 I=1,NSOUS
             IMODEL=MMODE1.KMODEL(I)
             NFOR=FORMOD(/2)
             IF(NFOR.EQ.1) THEN 
               CALL PLACE(mformu,nnofor,iplac,FORMOD(1))
               if (iplac.EQ.0) GOTO 1129
             ELSE IF(NFOR.EQ.2) THEN
               CALL PLACE(mformu,2,iplac,FORMOD(1))
               if (iplac.EQ.0) GOTO 1129
               CALL PLACE(mformu,2,iplac,FORMOD(2))
               if (iplac.EQ.0) GOTO 1129
           ELSE
            GO TO 1129
           ENDIF
*  on vient ici pour prendre les sous modeles
           NZON=NZON+1            
           KMODEL(NZON)=IMODEL
           SEGDES IMODEL
 1129      continue                  
           segdes mmode1
         endif
         NSOUS=n1
      if(ierr.ne.0) return
      n1 = n1io
      do 1 i = 1, 1000
      ctyp='  ' 
      CALL QUETYP(CTYP,0,IRETOU) 
*      write(6,*) ' iretou ctyp' , iretou,ctyp
      if(iretou.eq.0) go to 2 
      if(ctyp.eq.'FLOTTANT'.or.ctyp.eq.'ENTIER') then
         call lirree(xva,1,iret) 
         ctyp='FLOTTANT'
         call lircha(nomc,1,iretou)
      elseif(ctyp.eq.'MOT' ) then
         call lircha(nomc,1,iretou)
         call lirree(xva,1,iret)
         ctyp='FLOTTANT'
      else      
         call lirobj (ctyp,ipo,1,iretou)         
      endif     
      if(ierr.ne.0) return
      
      if(ctyp.eq.'CHPOINT') then                            
        CALL CHAME1(0,MMODEL,IPO,' ',Ipche2,5)
        IF (IERR.NE.0) RETURN
        ipo=ipche2                     
      elseif(ctyp.eq.'FLOTTANT') then
         call ecrcha('STRESSES')
         call ecrree(xva)
         call ecrcha(nomc)
         call ecrobj('MMODEL',mmodel)
         call ecrcha('CHML')
         call manuel
         if(ierr.ne.0) return
         call lirobj('MCHAML',ipo,1,iretou)
      elseif(ctyp.eq.'CHARGEME') then
         mcharg=ipo
         call lirree(xva,1,iret)
         if(ierr.ne.0) then
            return
         endif
         segact mcharg
         ika=0
         do 10 k=1,kcharg(/1)
           nomc=chanom(k)
           do  ka=1,nnonom
             if( nomc.eq.nonom(ka) ) go to 10        
           enddo 
*           write(6,*) ' adetat nomc ', nomc
           ika=ika+1     
           call ecrcha(nomc)
           call ecrree (xva)
           call ecrobj ('CHARGEME',mcharg)
           call tire
           segact mcharg
           call quetyp(ctyp,1,iretou)
           if(ierr.ne.0) return
           call lirobj(ctyp,ipa,1,iretou)
           ipche2=ipa
           if(ctyp.eq.'CHPOINT') then                            
              CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
              IF (IERR.NE.0) RETURN
           elseif (ctyp.eq.'MCHAML') then
*
*  AM  21/5/08
*  SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE 
*  SI CE N'EST PAS POSSIBLE, ON VA EN 10
*
               CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
               IF(IRET.EQ.0) THEN
                 GO TO 10
               ENDIF
*
               CALL  CHASUP(MMODEL,IPA2,IPche2,IRET,5)
           endif
           mchel3=ipche2
           segact mchel3
           n13= mchel3.ichaml(/1)
           n33= mchel3.infche(/2)
           iy=n1
           n1 = n1 + n13
           n3= max(n3,n33)
           segadj mchel2
           do kk=1,n13
             mchel2.conche(iy+kk)=mchel3.conche(kk)
             mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)           
             mchel2.imache(iy+kk)=mchel3.imache(kk) 
             do jk=1,n33
               mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
             enddo                     
           enddo
   10   continue
        segdes mcharg
        go to 1
      elseif(ctyp.eq.'TABLE') then
        ika=0
        mtable=ipo
        segact mtable
        ika=0 
        do  11 k=1,nnoind
          mtyp=' '
          call ACCTAB(mtable,'MOT     ',IJ,XJ,indic(k)(1:ilo(k)),ibo,IU,
     $                    MTYP,IK,XK,CHAI1,IBO,IPA)
          segact mtable
          if(MTYP.EQ.' ') go to  11
          if(MTYP.eq.'CHPOINT ') then
              CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5)
              IF (IERR.NE.0) RETURN
          elseif(mtyp.eq.'MCHAML' ) then
*
*  AM  21/5/08
*  SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE 
*  SI CE N'EST PAS POSSIBLE, ON VA EN 11
*
               CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE)
               IF(IRET.EQ.0) THEN
                 GO TO 11
               ENDIF
*
              CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5)
          else
              go to 11
          endif
          mchel3=ipche2
          segact mchel3
          n13= mchel3.ichaml(/1)
          n33= mchel3.infche(/2)
          iy=n1
          n1 = n1 + n13
          n3= max(n3,n33)
          segadj mchel2
          do kk=1,n13
            mchel2.conche(iy+kk)=mchel3.conche(kk)
            mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)            
            mchel2.imache(iy+kk)=mchel3.imache(kk)  
            do jk=1,n33
              mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
            enddo          
          enddo   
   11   continue
        segdes mtable   
        go to 1                                                              
      endif             
      mchel3=ipo
*  PV
      CALL CHASUP(MMODEL,mchel3,mchpv,IRET,5)
      IF (IRET.NE.0) CALL ERREUR(IRET)
      if (ierr.ne.0) return
      mchel3=mchpv
      segact mchel3
      n13= mchel3.ichaml(/1)
      n33= mchel3.infche(/2)
      iy=n1
      n1 = n1 + n13
      n3= max(n3,n33)
      segadj mchel2
      do kk=1,n13
         mchel2.conche(iy+kk)=mchel3.conche(kk)
         mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)       
         mchel2.imache(iy+kk)=mchel3.imache(kk) 
         do jk=1,n33
            mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
         enddo           
      enddo       
   1  continue
   2  continue
      if( n1.eq.0) then
*       call erreur (19) 
        call ecrobj('MCHAML',mchel2)
      else
* on va essayer de regrouper les supports de chamelem car plusieurs
* opérateurs partent du principes que si un modèle à n sous -zones le
* chamelem doit avoir le meme nombre de sous zones 
*
        iprio=5
*        call zpchel (mchel2,1)
        call confor(mchel2,mchel1, mmodel,iprio)
*        call zpchel( mchel1,1)
        call ecrobj('MCHAML',mchel1)
      endif
      return
      end