C TCONVE    SOURCE    FANDEUR   11/07/19    21:17:32     7042           

C=======================================================================
C=                            T C O N V E                              =
C=                            -----------                              =
C=                                                                     =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=  Calcul de la matrice de CONDUCTIVITE de sous-type CONVECTION       =
C=                                                                     =
C=  Parametres :  (E)=Entree  (S)=Sortie                               =
C=  ------------                                                       =
C=  IPMODE  (E)  Segment IMODEL (modele elementaire)           (ACTIF) =
C=  IPCHEL  (E)  Segment MCHELM de CARACTERISTIQUES            (?)     =
C=  ISUPMA  (E)  Support du champ de caracteristiques materiau         =
C=  IPRIGI (E/S) Segment MRIGID CONVECTION                     (ACTIF) =
C=======================================================================

      SUBROUTINE TCONVE(IPMODE,IPCHEL,ISUPMA, IPRIGI)

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

-INC CCOPTIO
-INC CCREEL

-INC SMCHAML
-INC SMCOORD
-INC SMELEME
-INC SMINTE
-INC SMMODEL
-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

      SEGMENT MMAT1
        REAL*8 CEL(LRE,LRE),XE(3,NNNN)
        REAL*8 SHP(6,NNNN),FORME(NNNN)
      ENDSEGMENT

      PARAMETER ( NINF=3 )
      DIMENSION INFOS(NINF)

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

C=  LEFCON   Liste des numeros d'elements finis supportant la CONVECTION
C=  NEFCON   Longueur de cette liste                                   =
C=  LEFCOQ   Liste des numeros d'elements finis COQUEs
C=  NEFCOQ   Longueur de cette liste                                   =
      PARAMETER ( NEFCON = 13 , NEFCOQ=5 )
      DIMENSION LEFCON(NEFCON), LEFCOQ(NEFCOQ)
C ============
C  Elements         SEG2 SEG3 TRI3 TRI6 QUA4 QUA8 RAC2 RAC3 LIA3 LIA6
C  CONVECTION       LIA4 LIA8 POI1
      DATA LEFCON /    2,   3,   4,   6,   8,  10,  12,  13,  18,  19,
     &                20,  21,   1 /
C ============
C  Elements COQUEs  COQ2 COQ3 COQ6 COQ4 COQ8
      DATA LEFCOQ /   44,  27,  56,  49,  41 /

C  1 - INITIALISATIONS ET VERIFICATIONS
C ======================================
C 1.0 - Matrice de CONDUCTIVITE
C ===
      MRIGID = IPRIGI
c*      SEGACT,MRIGID
      NRIGE0 = IRIGEL(/2)

C 1.1 - Recuperation du sous-modele et de la zone elementaire associee
C ===
      IMODEL=IPMODE
c*      SEGACT,IMODEL
c
      CMATE = CMATEE
      MATE  = IMATEE
      PEAU  = MATMOD(1)
c
      CONM = CONMOD
      NEF  = NEFMOD

c Element fini de type COQUE ?
      ICOQ = 0
      CALL PLACE2(LEFCOQ,NEFCOQ,ICOQ,NEF)

      NLG = NUMGEO(NEF)
      IF ((IDIM.EQ.1).AND.(NEF.EQ.2)) NLG = 1
C ERREUR : Element fini non implemente
      CALL PLACE2(LEFCON,NEFCON,ICON,NLG)
      IF (ICON.EQ.0) THEN
        CALL ERREUR(19)
        RETURN
      ENDIF
c
      IPT1 = IMAMOD
      SEGACT,IPT1
      NBNOE1 = IPT1.NUM(/1)
      NBELE1 = IPT1.NUM(/2)

      IPINTE = 0
      IVAMAT = 0
      MOMATE = 0
      MOTYPE = 0

C 1.2 - Remplissage du tableau INFOS
C ===
      IRET = 1
      CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
      IF (IRET.EQ.0) GOTO 9990

C 1.3 - Recuperation d'informations sur l'element fini
C ===
      CALL TSHAPE(NLG,'GAUSS',IPINTE)
      IF (IERR.NE.0) GOTO 9990
      MINTE = IPINTE
      SEGACT,MINTE
      NBPGAU = POIGAU(/1)

C 1.4 - Recuperation des caracteristiques materielles (obligatoires)
C ===
      nbrobl = 1
      nbrfac = 0
      SEGINI,nomid
      lesobl(1) = 'H   '
      NMATO = nbrobl
      NMATF = nbrfac
      NMATT = NMATO + NMATF
      MOMATE = nomid
C
      NBTYPE = 1
      SEGINI,notype
      TYPE(1) = 'REAL*8'
      MOTYPE = notype

C 1.5 - Definition du descripteur IDESCR
C ===
      IDESCR = 0
      CALL TCONV2(ICOQ,PEAU,NBNOE1,IDESCR)
      descr = IDESCR
      SEGACT,descr
      NLIGRP = LISINC(/2)
      NLIGRD = LISDUA(/2)
      SEGDES,descr

C 1.6 - Comme on traite la CONVECTION et les echanges FACE A FACE, on
C       introduit le nombre de NOEUDS pour les elements FACE A FACE.
C ===
      NBN2 = NBNOE1
      IF ((NEF.EQ.12) .OR. (NEF.EQ.13) .OR. (NEF.EQ.18) .OR.
     &    (NEF.EQ.19) .OR. (NEF.EQ.20) .OR. (NEF.EQ.21) .OR.
     &    ((IDIM.EQ.1).AND.(NEF.EQ.2)) )
     &  NBN2 = NBNOE1 / 2
C equivalent a ?  IF (ICON.GE.7) NBN2 = NBNOE1 / 2

C 1.7 - Partionnement si necessaire de la matrice de conductivite
C       determinant ainsi le nombre d'objets elementaires de MRIGID
C ===
      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,*) ' tconve : nblprt nblmax = ',nblprt,nblmax,nbele1

C 2 - Ajout de la matrice de CONVECTION a la matrice globale
C ==========================================================
      NRIGEL = NRIGE0 + NBLPRT
      SEGADJ,MRIGID

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

C Petit segment de travail :
      LRE  = NLIGRD
      NNNN = NBNOE1
      SEGINI,MMAT1

C 3 - Boucle sur les PARTITIONS elementaires de la matrice
C=========================================================
      DO 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,*) ' 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

        CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
        IF (IERR.NE.0) GOTO 9991
        IF (ISUPMA.EQ.1) THEN
          CALL VALCHE(IVAMAT,NMATT,IPINTE,0)
          IF (IERR.NE.0) THEN
            ISUPMA = 0
            GOTO 9991
          ENDIF
        ENDIF
C Preparation du champ de caracteristiques 'H'
        MPTVAL = IVAMAT
        MELVAL = IVAL(1)
        IVEL1 = VELCHE(/1)
        IVEL2 = VELCHE(/2)

C 3.2 - Boucle sur les elements du maillage elementaire (ipmail)
C ==============================================================
        DO iel = 1, nbelem

          iemn = MIN(iel,IVEL2)
C- Mise a zero de la matrice de CONVECTION de l'element iel
          CALL ZERO(CEL,LRE,LRE)
C- Recuperation des coordonnees GLOABLES des noeuds de l'element
          CALL DOXE(XCOOR,IDIM,NBNN,NUM,iel,XE)

C- BOUCLE sur les points de Gauss de l'element iel
          iFois = 0
          DO igau = 1, NBPGAU

C-- Calcul du jacobien, des fonctions de forme et de leurs
C-- derivees au point de Gauss igau
            CALL TCONV3(NLG,igau,NBNN,NBN2,XE,SHPTOT,SHP,FORME,DJAC)
            IF (IERR.NE.0) GOTO 9991
            IF (DJAC.LT.XZERO) iFois=iFois+1
            DJAC = ABS(DJAC)
C-- Erreur si le jacobien est nul en ce point de Gauss
            IF (DJAC.LT.XPETIT) THEN
              INTERR(1) = iel
              CALL ERREUR(259)
              GOTO 9991
            ENDIF
C-- Calcul du terme .Vol en ce point de Gauss
            igmn = MIN(igau,IVEL1)
            COEF = DJAC * POIGAU(igau) * VELCHE(igmn,iemn)
C-- Calcul de la contribution du point de Gauss a la matrice de 
C-- CONVECTION elementaire pour cet element fini
            CALL NTNST(FORME,COEF,LRE,1,CEL)
          ENDDO
C- FIN DE LA BOUCLE sur les points d'integration de l'element iel

C- Erreur si, en un point de Gauss, le jacobien change de signe.
          IF (iFois.NE.0.AND.iFois.NE.NBPGAU) THEN
            INTERR(1) = iel
            CALL ERREUR(195)
            GOTO 9991
          ENDIF
C- Stockage de la matrice de CONVECTION pour cet element fini :
C- remplissage de xmatri
          CALL REMPMT(CEL,LRE,xmatri.re(1,1,iel))

        ENDDO
C= FIN DE LA BOUCLE sur les elements

 9991   CONTINUE
        IF (ISUPMA.EQ.1 .OR. NBLPRT.NE.1) THEN
          CALL DTMVAL(IVAMAT,3)
        ELSE
          CALL DTMVAL(IVAMAT,1)
        ENDIF
        IF (IERR.NE.0) GOTO 9990

        xmatri = ipmatr
        SEGDES,xmatri
        IF (NBLPRT.GT.1) THEN
          meleme = ipmail
          SEGDES,meleme
        ENDIF

        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
        IRIGEL(8,jrige) = 0

      ENDDO

      IPRIGI = MRIGID

C MENAGE : desactivation/destruction de segments
C ==============================================
 9990 CONTINUE
      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
      SEGDES,IPT1
c*      SEGDES,MRIGID
c*      SEGDES,IMODEL

      RETURN
      END