C INOMID    SOURCE    FANDEUR   12/07/18    21:15:47     7435           
      SUBROUTINE INOMID(iqmod,ityp,iret,luvari,lumato,lumatf,lupaex)
* 
*  iqmod est un pointeur sur un segment imodel de l'objet modele, il est
*  supposé actif
*
*  A)  ITYP= '        '    
*     creation des segments de noms de composantes des MCHAML  
*     CREES PAR LE MODELE ELEMENTAIRE
*      en entree luvari ,lumate et lupaex sont des listmots pour les :
*   variables internes , materiaux ,parametre externes s'ils ont été définis
*   attention : une modele de mecanique ne peut creer de composantes thermiques
*  ou phases metallurgiques ! 
*  fortement inspire de comou2
*
*  B) ITYP different de '    '  on renvoie dans iret le nomid associé. 
*
      IMPLICIT INTEGER(I-N)
       IMPLICIT REAL*8(A-H,O-Z)

-INC CCOPTIO
-INC SMMODEL
-INC SMLMOTS 

      parameter(ninc=13)
      pointeur nomid1.nomid
       logical dcmate
       character*8 nomtyp(14),ityp
      CHARACTER*4 lesinc(ninc),lesdua(ninc)
      DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR','UT','RT',           
     1'LX','P','ALFA','BETA'/  
      DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR','FT','MT',            
     1'FLX','FP','FALF','FBET'/    
       data nomtyp/ 'DEPLACEM', 'FORCES  ', 'GRADIENT', 'CONTRAIN',
     1              'DEFORMAT', 'MATERIAU', 'CARACTER', 'TEMPERAT',
     1              'PRINCIPA', 'VARINTER', 'GRAFLEXI', 'VINMETAL',
     1              'DEFINELA', 'PARAMEXT' /

       dcmate = .false.
       nimcom = 0
*
* on suppose le sous-modele (imodel) est actif 
         imodel = iqmod
         segact imodel*mod
            do im = 1,matmod(/2)
             if (matmod(im).eq.'IMPEDANCE') then
               dcmate = .true.
               if (luvari.gt.0) then
                 mlmot5 = luvari
                 luvari = 0
                 mlmot6 = lumato
                 lumato = 0
                 segact mlmot5,mlmot6
                 nimcom = mlmot5.mots(/2)
                 nbrobl = nimcom*2
                 nbrfac = 0
                 segini nomid,nomid1
                 do inim = 1,nimcom
                  CALL PLACE(lesinc,ninc,IMOT,mlmot5.mots(inim))
                  if (imot.eq.0) call erreur(26)
                  lesobl(inim) = mlmot5.mots(inim)
                  nomid1.lesobl(inim) = lesdua(imot)
                  CALL PLACE(lesinc,ninc,IMOT,mlmot6.mots(inim))
                  if (imot.eq.0) call erreur(26)
                  lesobl(nimcom+inim) = mlmot6.mots(inim)
                  nomid1.lesobl(nimcom+inim) = lesdua(imot)
                 enddo
                 segdes nomid,nomid1
               endif
             endif
            enddo

         if (ityp.eq.'        ') then
              ideb=1
              ifin=14
         else
               do ideb=1,14
                 if(ityp.eq.nomtyp(ideb))go to 100
               enddo
*               write(ioimp,*) ' INOMID demande incompatible'
               stop
  100          iret = lnomid (IDEB)
               nomid=iret
               segact nomid
               return 
         endif

        NFOR=formod(/2)
        CALL PLACE(formod,NFOR,ITHEHY,'THERMOHYDRIQUE')
        CALL PLACE(formod,NFOR,ITHER,'THERMIQUE')
        CALL PLACE(formod,NFOR,IMAGN,'MAGNETODYNAMIQUE')
        CALL PLACE(formod,NFOR,IELEC,'ELECTROSTATIQUE')
        CALL PLACE(formod,NFOR,IDIFF,'DIFFUSION')
        CALL PLACE(formod,NFOR,ILIAIS,'LIAISON') 
        CALL PLACE(formod,nfor,iconta,'CONTACT')
*        MELEME=IMAMOD
         MELE=nefmod
         MFR2=nummfr(mele)
        do jn=1,matmod(/2)
         if (matmod(jn).eq.'MODAL'.or.matmod(jn).eq.'STATIQUE') 
     &     MFR2= infele(13)
        enddo
         IF (ITHEHY.EQ.1) MFR2=65
         IF (IELEC.EQ.1) MFR2=71
         IF (IDIFF.EQ.1) MFR2=73
         npint3=0  
         if(infmod(/1).ne.0) npint3=infmod(1)
*         write(6,*) ' inomid formod', (formod(iou),iou=1,nfor)
*         write(6,*) ' mele MFR2 ',mele,mfr2

       DO 200 ino = ideb,ifin
         mocomp=0
*
*       AIGUILLAGE SUIVANT MOT CLE
        GOTO ( 1, 2,3,4,5,6,7,8,9, 10,11,12,13,14) ino
*
   1    if (dcmate.and.nimcom.gt.0) then
         nobl = nimcom*2
         nfac = 0
         mocomp=nomid
        else 
          if(ITHER.NE.0) THEN
           CALL IDTEMP(MFR2,IFOUR,npint3,MOCOMP,NOBL,NFAC)
          elseif(iconta.eq.0) then 
           CALL IDDEPL(MFR2,IFOUR,MOCOMP,NOBL,NFAC)           
          endif
          modepz=mocomp
        endif
        IF (IDIFF.EQ.1) THEN
          nomid = mocomp
          segact,nomid*MOD
          lesobl(1) = TYMODE(1)
        ENDIF      
*         write(6,*) ' modepl  MFR2 ' , mocomp,MFR2
        GOTO 120
*
   2    if (dcmate.and.nimcom.gt.0) then
         nobl = nimcom*2
         nfac = 0
         mocomp=nomid1
        elseif(iconta.eq.0) then 
          if( ither.eq.0) then
            CALL IDFORC(MFR2,IFOUR,MOCOMP,NOBL,NFAC)
          else
            nomid1=modepz
C*          segact nomid1
            segini,nomid=nomid1
            mocomp=nomid             
            do iou=1,lesobl(/2)
              if(lesobl(iou).EQ.'T' ) LESOBL(iou)='Q'
              if( lesobl(iou).EQ.'TSUP' ) LESOBL(iou)='QSUP'
              if( lesobl(iou).EQ.'TINF' ) LESOBL(iou)='QINF'
            enddo
C*          segdes nomid1
          endif
        endif
        IF (IDIFF.EQ.1) THEN
          nomid = mocomp
          segact,nomid*MOD
          lesobl(1) = TYMODE(2)
        ENDIF
*        write(6,*) ' moforc  MFR2 ' , mocomp,MFR2
        GOTO 120
*
   3    if(ither.ne.0) then
          IF (MFR2.EQ.1) THEN
            MDM=29
          ELSE IF (MFR2.EQ.3.OR.MFR2.EQ.5.OR.MFR2.EQ.9) THEN
            MDM=39
          ENDIF
        ELSEIF(IMAGN.NE.0)then
            MDM=69
        ELSE
          MDM=MFR2
        ENDIF
        IF( iconta.eq.0)CALL IDGRAD(MDM,IFOUR,MOCOMP,NOBL,NFAC)
        IF (IDIFF.EQ.1) THEN
          nomid = mocomp
          segact,nomid*MOD
          DO i = 1,lesobl(/2)
C*8         lesobl(i)(1:6) = TYMODE(1)(1:6)
            lesobl(i)(1:2) = TYMODE(1)(1:2)
          ENDDO
        ENDIF
*           write(6,*) ' mograd  mfr ' , mocomp,mdm
        GOTO 120
*
   4    if(iconta.eq.0)CALL IDCONT(IMODEL,IFOUR,MOCOMP,NOBL,NFAC)
*           write(6,*) ' mocont  ' , mocomp
        if (dcmate.and.nimcom.gt.0) then
         nbrobl = nimcom
         nbrfac = nfac
         nomid = mocomp
         segadj nomid
        endif
        GOTO 120
*
   5    if(iconta.eq.0)CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NOBL,NFAC)
*        write(6,*) ' modefo ',mocomp
        if (dcmate.and.nimcom.gt.0) then
         nbrobl = nimcom
         nbrfac = nfac
         nomid = mocomp
         segadj nomid
        endif
        GOTO 120
*
   6    IF(lumato.EQ.0) THEN
          CALL IDMATR(MFR2,IMODEL,MOCOMP,NOBL,NFAC)
        ELSE
          mlmots=lumato
          segact MLMOTS
          nbrobl=mots(/2)
          nbrfac=0
          IF (lumatf.NE.0) THEN
            mlmot1=lumatf
            segact mlmot1
            nbrfac=mlmot1.mots(/2)
          ENDIF
          SEGINI,nomid
          DO io=1,nbrobl
            lesobl(io)=mots(io)
          enddo
          segdes,mlmots
          if(lumatf.ne.0) then
            do io=1,nbrfac
              lesfac(io)=mlmot1.mots(io)
            enddo 
            segdes,mlmot1
          endif
          mocomp=nomid
        ENDIF 
*        write(6,*) ' momatr ',mocomp
        GOTO 120
*
   7    CONTINUE
* attention pas de caracteristiques pour  materiaux modal,statique,impedance
* et pour formulation liaison on bidonne en appelant avec mele = 14 (cub8)  
        melee=mele 
        do jn=1,matmod(/2)
         if (matmod(jn).eq.'MODAL'.or.matmod(jn).eq.'STATIQUE'.or.
     &       matmod(jn).eq.'IMPEDANCE') Melee=14  
        enddo 
        if(iliais.ne.0) melee=14 
        if(iconta.eq.0)CALL IDCARB(MELEe,IFOUR,MOCOMP,NOBL,NFAC)
*        write(6,*) ' mocara ',mocomp   
        GOTO 120
*
   8    mocomp=0
        if(ither.eq.0.and.iconta.eq.0)
     $    CALL IDTEMP(MFR2,IFOUR,npint3,MOCOMP,NOBL,NFAC) 
*        write(6,*) ' motemp ',mocomp   
        GOTO 120
*
   9    if(iconta.eq.0)CALL IDPRIN(MFR2,IFOUR,MOCOMP,NOBL,NFAC)
*        write(6,*) ' moprin ',mocomp   
        GOTO 120
*
  10    CONTINUE
*        if(LUVARI.EQ.0) then
         if(iconta.eq.0) CALL IDVARI(MFR2,IMODEL,MOCOMP,NOBL,NFAC)
*        else
          if(luvari.ne.0) then
            mlmots=luvari
            segact MLMOTS
            nomid= mocomp
            if (nomid.ne.0) then
              segact nomid*mod         
              ndej=lesobl(/2)
              if(ndej.eq.1) ndej=0
              nbrobl=mots(/2)+ndej
              nbrfac=0
              ista=ndej+1
              segadj nomid
              iau=1
              do io=ista,nbrobl
                lesobl(io)=mots(iau)
                iau=iau+1
              enddo
            else
              nbrobl=mots(/2)
              nbrfac=0
              segini nomid
              do io=1,nbrobl
                lesobl(io)=mots(io)
              enddo
            endif
            segdes mlmots
            mocomp=nomid
          endif
*        endif
*          write(6,*) ' movari ', mocomp 
        GOTO 120
*
  11    if(iconta.eq.0)CALL IDGRAF(MFR2,IFOUR,MOCOMP,NOBL,NFAC)
*          write(6,*) ' movari ', mocomp 
        GOTO 120
*
  12    if(iconta.eq.0)CALL IDPHAS(MFR2,IMODEL,MOCOMP,NOBL,NFAC)
*          write(6,*) ' mophas ', mocomp 
        GOTO 120
*
  13    if(iconta.eq.0)CALL IDDEIN(IMODEL,IFOUR,MOCOMP,NOBL,NFAC)
*          write(6,*) ' modein ', mocomp 
        GOTO 120

* le parametre externe est deja sous forme de listmots
  14    MOCOMP=LUPAEX  
        if (LUPAEX.NE.0) THEN
          mlmots=lupaex
          segact MLMOTS
          nbrobl=mots(/2)
          nbrfac=0
          segini nomid
          do  io=1,nbrobl
          lesobl(io)=mots(io)
          enddo
          mocomp=nomid
*         write(6,*)'  mopaex ',nomid
         ENDIF
        GOTO 120
*
  120   CONTINUE 
        nomid = mocomp
        lnomid(ino)=mocomp
        IF (nomid.NE.0) SEGDES,nomid

*      if (nomid.NE.0) THEN
*        segact nomid
*       write(6,*) ' type ' , nomtyp(ino)
*        write(6,*) ' lesobl(/2) ', lesobl(/2)
*        write(6,*) (lesobl(iou),iou=1,lesobl(/2))
*        write(6,*) ' lesfac ' , (lesfac(iou),iou=1,lesfac(/2)) 
*        segdes,nomid
*      endif

 200  CONTINUE

      RETURN
      END