C TADVE1    SOURCE    CHAT      12/06/07    21:16:04     7389           

************************************************************************
*
*                             T A D V E 1 
*                             ----------- 
*
* FONCTION: 
* --------- 
*     CREATION DE LA MATRICE DE ADVECTION 
*     GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE 
* 
* PARAMETRES:  (E)=ENTREE    (S)=SORTIE
* ----------- 
*     IPMODE   (E)  POINTEUR SUR LE SEGMENT MMODEL 
*     IPCHEL   (E)  POINTEUR SUR LE SEGMENT MCHELM 
*     IPRIGI   (S)  POINTEUR SUR LE SEGMENT MRIGID 
*
* AUTEUR, DATE DE CREATION: 
* ------------------------- 
*      MARINO ARROYO, 18 MAI 1999 
* 
* LANGAGE: 
* -------- 
*     ESOPE + FORTRAN77 
* 
************************************************************************ 
*
      SUBROUTINE TADVE1 (IPMODE,IPCHEL,IPRIGI,ISYMM)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC CCOPTIO
-INC CCHAMP

-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMMODEL
      POINTEUR nomid1.NOMID
-INC SMRIGID

      INTEGER OOOVAL

      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT

      SEGMENT MPTVAL
        INTEGER IPOS(NS),NSOF(NS), IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT

      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)

      CHARACTER*8 CMATE
      CHARACTER*(LCONMO) CONM
      CHARACTER*10 PEAU

      PARAMETER ( LNUCOQ=5 , LINUM=12 , LINUC=12 )
      INTEGER INUCOQ(LNUCOQ), INUMA(LINUM), INUCO(LINUC) 
* 
*                TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 
      DATA INUMA/   4,   6,   8,  10,  14,  15,  16,  17, 
*                TET4 TET10 PYR5 PY13 
     &             23,   24,  25,  26/ 
*                 SEG2 SEG3 TRI3 TRI6 QUA4 QUA8 
      DATA INUCO /   2,   3,   4,   6,   8,  10,
*                 RAC2 RAC3 LIA3 LIA6 LIA4 LIA8  
     &             12, 13,  18,  19,   20, 21 / 
*                  COQ2  COQ3  COQ6 COQ4 COQ8 
      DATA INUCOQ / 44 , 27  , 56 , 49  ,41 / 

      IPRIGI = 0
C---
C Verification du lieu support du MCHAML de caracteristiques
C---
      CALL QUESUP(IPMODE,IPCHEL,6,0,ISUPCH,IRET)
      IF (ISUPCH.GT.1) RETURN
C---
C Activation du MODELE
C---
      MMODEL = IPMODE
      SEGACT,MMODEL
* selection de la partie advection
      call selmod(mmodel,ipmo,'ADVECTION')
      mmodel=ipmo      
      NBMAIL = KMODEL(/1)
      if( nbmail.eq.0) then
        call erreur (19)
        return
      endif  
C---
C Initialisation de la matrice d'ADVECTION (chapeau de l'objet RIGIDITE)
C---
      NRIGEL = 0
      SEGINI,MRIGID
      MTYMAT = 'RIGIDITE' 
      ICHOLE = 0
      IMGEO1 = 0
      IMGEO2 = 0
C*    IFORIG = IFOMOD
      IFORIG = IFOUR
      ISUPEQ = 0

C---
C BOUCLE SUR LES MODELES ELEMENTAIRES
C---
      DO 10 IMAIL = 1, NBMAIL

        IPINTE = 0
        IPINT1 = 0
        MOMATE = 0
        MOTYPE = 0

C- Recuperation du sous-modele et de la zone elementaire associee
        IMODEL = KMODEL(IMAIL) 
        SEGACT,IMODEL

C- Recuperation d'informations sur le maillage elementaire
        IPT1 = IMAMOD
        SEGACT,IPT1
        NBNOE1 = IPT1.NUM(/1)
        NBELE1 = IPT1.NUM(/2)
        ituy=0
        if(nefmod.eq.269.or.nefmod.eq.270)  ituy=1
C- Quelques informations et verifications sur le modele elementaire
        CONM  = CONMOD
        CMATE = CMATEE
        MATE  = IMATEE

        NF1 = FORMOD(/2) 
        CALL PLACE(FORMOD,NF1,IF1,'CONVECTION')
        CALL PLACE(FORMOD,NF1,IF2,'THERMIQUE')
C  Autre formulation que 'THERMIQUE' ou 'CONVECTION' => Indisponible
        IF ( (IF1.EQ.0.AND.IF2.EQ.0) .OR.
     &       (IF1.NE.0.AND.IF2.NE.0) ) THEN
          CALL ERREUR(251)
          GOTO 1999
        ENDIF 
C  Formulation 'CONVECTION' => Indisponible
        IF (IF1.NE.0) THEN
          CALL ERREUR(251)
          GOTO 1999
        ENDIF
        
C  Seule l'isotropie est disponible en 2D PLAN et AXISYMETRIQUE
        if(ituy.ne.1) then
          IF (MATE.EQ.1) THEN      
            IF (IFOMOD.GT.0) THEN
              WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
     &                      'SEULEMENT LE CAS 2D EST ENVISAGE'
              CALL ERREUR(19)
              GOTO 1999
            ENDIF
          ELSE
            WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
     &                   'SEULEMENT LE CAS ISOTROPE EST ENVISAGE'
            CALL ERREUR(19)
            GOTO 1999
          ENDIF
        endif
*
        IRET = 1
        CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
        IF (IRET.EQ.0) GOTO 1999
*
        NEF  = NEFMOD
        ICOQ = 0
        CALL PLACE2(INUCOQ,LNUCOQ,ICOQ,NEF)
        IMAS = 0
        CALL PLACE2(INUMA,LINUM,IMAS,NEF)
        IF (IMAS.EQ.0.and . ituy.eq.0) THEN
          WRITE(IOIMP,*) '### ERREUR DANS ADVE : ',
     &          'SEULS LES ELEMENTS FINIS MASSIFS SONT ENVISAGES'
          CALL ERREUR(19)
          GOTO 1999
        ENDIF

C- Recuperation d'informations sur l'element fini
        CALL TSHAPE(NEF,'GAUSS',IPINTE)
        IF (IERR.NE.0) GOTO 1999
        MINTE = IPINTE
        SEGACT,MINTE

C- Recuperation des noms des composantes du champ vectoriel (obligatoires)

        if( ituy.eq.0) then
          nbrobl = IDIM
          nbrfac = 0
          SEGINI,nomid  
          IF (IDIM.EQ.1) THEN
            lesobl(1) = 'UX  '
          ELSE IF (IDIM.EQ.2) THEN
            lesobl(1) = 'UX  '
            lesobl(2) = 'UY  '
c*        ELSE IF (IDIM.EQ.3) THEN
          ELSE
            lesobl(1) = 'UX  '
            lesobl(2) = 'UY  '
            lesobl(3) = 'UZ  '
          ENDIF
        else 
          nbrobl=4
          nbrfac = 0
          SEGINI,nomid  
          lesobl(1)= 'VITE'
          lesobl(2)='RHO'
          lesobl(3)='C'
          lesobl(4)='SECT'
        endif  
        NMATO = lesobl(/2)
        NMATF = lesfac(/2)
        NMATT = NMATO + NMATF
        MOMATE = nomid

        nbtype = 1
        SEGINI,notype
        type(1) = 'REAL*8'
        MOTYPE = notype

C- Definition du descripteur IDESCR
        IDESCR = 0
        IF (ICOQ.NE.0 .AND. IF1.NE.0) THEN 
          PEAU = '          '
          IF (MATMOD(/1) .NE. 0) PEAU = MATMOD(1) 
          CALL TCONV2(ICOQ,PEAU,NBNOE1,IDESCR) 
        ELSE 
          CALL TCOND2(ICOQ,NBNOE1,IDESCR) 
        ENDIF 
        descr = IDESCR
        SEGACT,descr
        NLIGRD = LISDUA(/2)
        NLIGRP = LISINC(/2)
        SEGDES,descr
        LRE = NLIGRP
C- Partionnement si necessaire de la matrice de conductivite
C- determinant ainsi le nombre d'objets elementaires de MRIGID
        LTRK = oooval(1,4)
        IF (LTRK.EQ.0) LTRK = oooval(1,1)
* Ajout a la taille en mots de la matrice des infos du segment
        LSEG = LRE*LRE*NBELE1 + 16
        NBLPRT = (LSEG-1)/LTRK + 1
        NBLMAX = (NBELE1-1)/NBLPRT + 1
        NBLPRT = (NBELE1-1)/NBLMAX + 1
*        write(ioimp,*) ' tadve1 : nblprt nblmax = ',nblprt,nblmax,nbele1

C- Ajout de la matrice d'ADVECTION a la matrice globale
        NRIGE0 = IRIGEL(/2)
        NRIGEL = NRIGE0 + NBLPRT
        SEGADJ,MRIGID

        descr  = IDESCR
        meleme = IPT1
        nbnn   = NBNOE1
        nbelem = NBELE1
        nbsous = 0
        nbref  = 0

C====
C Boucle sur les PARTITIONS elementaires de la matrice
C====
        DO 200 irige = 1, NBLPRT

          IF (NBLPRT.GT.1) THEN
C-- Partitionnement du maillage support de la matrice elementaire
            SEGACT,IPT1
            ielem = (irige-1)*NBLMAX
            nbelem = MIN(NBLMAX,NBELE1-ielem)
*            write(ioimp,*) 'tadve1 : creation segment ',nbnn,nbelem
            SEGINI,meleme
            itypel = IPT1.itypel
            DO ielt = 1, nbelem
              jelt = ielt + ielem
              DO inoe = 1, nbnn
                num(inoe,ielt) = IPT1.NUM(inoe,jelt)
              ENDDO
              icolor(ielt) = IPT1.ICOLOR(jelt)
            ENDDO
C-- Recopie du descripteur
            des1 = IDESCR
            SEGINI,descr=des1
            SEGDES,descr
          ENDIF
          ipmail = meleme
          ipdesc = descr

C-- Initialisation de la matrice de rigidite elementaire (xmatri)
          NELRIG = nbelem
          SEGINI,xmatri
          ipmatr = xmatri

C-- Recuperation des valeurs des caracteristiques necessaires
          IVAMAT = 0
          CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
          IF (IERR.NE.0) GOTO 2999
          IF (ISUPCH.EQ.1) THEN
            CALL VALCHE(IVAMAT,NMATT,IPINTE,0)
            IF (IERR.NE.0) THEN
              ISUPCH = 0
              GOTO 2999
            ENDIF
          ENDIF
           
C-- Calcul de la matrice elementaire pour la zone irige (ipmail) et
C-- Remplissage de la matrice globale (ipmatr)
C Note : actuellement uniquement les elements massifs
       if(imas.ne.0) then
          CALL TADVE8(NEF,ipmail,IPINTE,MATE,IVAMAT,NMATT,ISYMM,
     &                  ipmatr,LRE)
       elseif(ituy.ne.0) then
         call adtuy(nef,ipmail,ipinte,mate,ivamat,nmatt, ipmatr,
     &        lre)
       else
          call erreur(19)
       endif
C-- Un peu de menage dans les segments
 2999     CONTINUE
          IF (ISUPCH.EQ.1 .OR. NBLPRT.NE.1) THEN
            CALL DTMVAL(IVAMAT,3)
          ELSE
            CALL DTMVAL(IVAMAT,1)
          ENDIF
C-- Sortie prematuree en cas d'erreur
          IF (IERR.NE.0) GOTO 1999

          xmatri = ipmatr
          SEGDES,xmatri
          IF (NBLPRT.GT.1) THEN
            meleme = ipmail
            SEGDES,meleme
          ENDIF
C-- Stockage de la matrice
          jrige = NRIGE0 + irige
          COERIG(jrige)   = 1.
          IRIGEL(1,jrige) = ipmail
          IRIGEL(2,jrige) = 0
          IRIGEL(3,jrige) = ipdesc
          IRIGEL(4,jrige) = ipmatr
          IRIGEL(5,jrige) = NIFOUR
          IRIGEL(6,jrige) = 0
          IRIGEL(7,jrige) = 0
          IF (ISYMM.NE.1) IRIGEL(7,jrige) = 2
          IRIGEL(8,jrige) = 0

 200    CONTINUE
C====
C FIN DE LA BOUCLE SUR LES PARTITIONS
C====

C- Un peu de menage dans les segments
 1999   CONTINUE
        SEGDES,IPT1
        SEGDES,IMODEL 
        IF (IPINTE.NE.0) THEN
          MINTE = IPINTE
          SEGDES,MINTE
        ENDIF
        IF (MOMATE.NE.0) THEN
          nomid = MOMATE
          SEGSUP,nomid
        ENDIF
        IF (MOTYPE.NE.0) THEN
          notype = MOTYPE
          SEGSUP,notype
        ENDIF
        IF (IERR.NE.0) GOTO 999

 10   CONTINUE
C---
C FIN DE LA BOUCLE SUR LES MODELES ELEMENTAIRES
C---

      IPRIGI = MRIGID
      SEGDES,MRIGID

 999  CONTINUE
      SEGDES,MMODEL

      RETURN
      END