Sources Esope | Cast3M

thcond
C THCOND    SOURCE    PV090527  26/04/30    21:16:40     12529          
 
C=======================================================================
C=                            T H C O N D                              =
C=                            -----------                              =
C=                      (TCONDU dans le cas de la thermique)           =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=  Creation de la matrice de CONDUCTIVITE THERMIQUE (type RIGIDITE).  =
C=                                                                     =
C=  Parametres :  (E)=Entree   (S)=Sortie                              =
C=  ------------                                                       =
C=   IPMODE   (E)   Segment IMODEL pour un 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 : CONDUCTIVITE              (ACTIF) =
C=                                                                     =
C=   Zakaria HABIBI le 30 juin 2008.                                   =
C=======================================================================
 
      SUBROUTINE THCOND (IPMODE,IPCHEL,ISUPMA, IPRIGI)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCGEOME
 
-INC SMELEME
-INC SMINTE
-INC SMMODEL
-INC SMRIGID
 
      INTEGER OOOVAL
 
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
 
      CHARACTER*8 CMATE
      CHARACTER*(LCONMO) CONM
 
      PARAMETER ( NINF=3 )
      DIMENSION INFOS(NINF)
 
C=  LEFMAS   Liste des numeros d'elements finis MASSIFs supportant la  =
C            la formulation thermohydrique                             =
C=  NEFMAS   Longueur de cette liste                                   =
      PARAMETER ( NEFMAS = 14 )
      DIMENSION LEFMAS(NEFMAS)
 
C ==========
C  Elements        TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 TET4 TE10
C  MASSIFs         PYR5 PY13 T1D2 T1D3
C ==========
      DATA LEFMAS /   4,   6,   8,  10,  14,  15,  16,  17,  23,  24,
     &               25,  26, 191, 192 /
 
      IPINTE = 0
      IPINT1 = 0
      MOMATE = 0
      MOTYPE = 0
 
C- Matrice de CONDUCTIVITE
      MRIGID = IPRIGI
c*      SEGACT,MRIGID
      NRIGE0 = IRIGEL(/2)
 
C- Recuperation du sous-modele et de la zone elementaire associee
      IMODEL = IPMODE
c*      SEGACT,IMODEL
 
      NEF  = NEFMOD
C Test sur l'element fini
      IMAS = 0
      CALL PLACE2(LEFMAS,NEFMAS,IMAS,NEF)
C ERREUR : Element fini non implemente actuellement
      IF (NEF.EQ.22 .OR. IMAS.EQ.0) THEN
        CALL ERREUR(19)
        GOTO 9990
      ENDIF
 
C- Recuperation d'informations sur le maillage elementaire
      IPT1 = IMAMOD
      SEGACT,IPT1
      NBNOE1 = IPT1.NUM(/1)
      NBELE1 = IPT1.NUM(/2)
 
C- Quelques informations sur le modele
      CONM  = CONMOD
      CMATE = CMATEE
      MATE  = IMATEE
 
      IRET = 1
      CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
      IF (IRET.EQ.0) GOTO 9990
 
C- Recuperation d'informations sur l'element fini
      CALL TSHAPE(NEF,'GAUSS',IPINTE)
      IF (IERR.NE.0) GOTO 9990
      MINTE = IPINTE
      SEGACT,MINTE
 
      IF (MATE.EQ.2 .OR. MATE.EQ.3) THEN
        NLG = NUMGEO(NEF)
        CALL RESHPT(1,NBNOE1,NLG,NEF,0,IPINT1,IOK)
        IF (IOK.EQ.0) GOTO 9990
        MINTE1 = IPINT1
        SEGACT,MINTE1
      ENDIF
 
C- Recuperation des caracteristiques materielles
      nomid = LNOMID(6)
      SEGACT,nomid
      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
      CALL THCOND2(NBNOE1,IDESCR)
      descr = IDESCR
      SEGACT,descr
      NLIGRD = lisdua(/2)
      NLIGRP = lisinc(/2)
      SEGDES,descr
      LRE = NLIGRD
 
C- Partionnement si necessaire de la matrice thermohydrique
C- determinant ainsi le nombre d'objets elementaires de MRIGID
      LTRK = oooval(1,4)
      IF (LTRK.EQ.0) LTRK = oooval(1,1)
      LTRK=MAX(LTRK,2**24)
* 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,*) ' thcond1 : nblprt nblmax = ',nblprt,nblmax,nbele1
 
C Ajout de la matrice de CONDUCTVITE THERMOHYDRIQUE a la matrice globale
C ======================================================================
      NRIGEL = NRIGE0 + NBLPRT
      SEGADJ,MRIGID
 
      descr  = IDESCR
      meleme = IPT1
      nbnn   = NBNOE1
      nbelem = NBELE1
      nbsous = 0
      nbref  = 0
 
C  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
        rigrel=0
        SEGINI,xmatri
        ipmatr = xmatri
 
        IVAMAT = 0
        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,MOMATE,NEF)
          IF (IERR.NE.0) THEN
            ISUPMA = 0
            GOTO 9991
          ENDIF
        ENDIF
C===
C- Calcul de la matrice elementaire pour
C        remplissage de la matrice globale (ipmatr)
C =====
C-- Elements MASSIFs a integration NUMERIQUE
        IF (IMAS.NE.0) THEN
          CALL THNUMAC(NEF,ipmail,ipinte,ipint1,IVAMAT,NMATT,ipmatr,LRE)
        ELSE
          CALL ERREUR(5)
        ENDIF
 
C- Un peu de menage
 9991   CONTINUE
        IF (ISUPMA.EQ.1 .OR. NBLPRT.GT.1) THEN
          CALL DTMVAL(IVAMAT,3)
        ELSE
          CALL DTMVAL(IVAMAT,1)
        ENDIF
        IF (IERR.NE.0) GOTO 9990
 
        xmatri = ipmatr
        IF (NBLPRT.GT.1) THEN
          meleme = ipmail
          SEGDES,meleme
        ENDIF
 
C- Remplissage de la
        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) = 2
        IRIGEL(8,jrige) = 0
        xmatri.symre=2
        SEGDES,xmatri
 
      ENDDO
 
C  4 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
C ====================================================
 9990 CONTINUE
c*      SEGDES,MRIGID
c*      SEGDES,IMODEL
      SEGDES,IPT1
      IF (IPINTE.GT.0) THEN
        MINTE = IPINTE
        SEGDES,MINTE
      ENDIF
      IF (IPINT1.GT.0) THEN
        MINTE = IPINT1
        SEGDES,MINTE
      ENDIF
      IF (MOMATE.NE.0) THEN
        nomid = MOMATE
        SEGDES,nomid
      ENDIF
      IF (MOTYPE.NE.0) THEN
        notype = MOTYPE
        SEGSUP,notype
      ENDIF
 
      RETURN
      END