Sources Esope | Cast3M

sore1
C SORE1     SOURCE    CB215821  24/04/12    21:17:15     11897          
 
************************************************************************
*
*                             SORE1
*                             _____
* FONCTION:
* ---------
*     CREATION DE LA MATRICE DE CONDUCTIVITE   N DIV(GRAD T)
*     POUR DES ELMENTS MASSIFS UNIQUEMENT
*     GESTION DES SEGMENTS ET TESTS DE COMPATIBILITE
*
* PARAMETRES:  (E)=ENTREE    (S)=SORTIE   (+)=CONTENU DANS UN COMMUN
* -----------
*
*     IPMODE   (E)  POINTEUR SUR LE MMODEL
*     IPCHEL   (E)  POINTEUR SUR LE CHAMP CARACTERISTIQUES (MATER)
*     IPCHE4   (E)  POINTEUR SUR LE CHAMP  FACTEUR DE GRAD(T)
*     IPCHP1   (E)  POINTEUR SUR LE CHPOINT de TEMPERATURE
*     IPRIGI   (S)  POINTEUR SUR LE SEGMENT MRIGID
*
* VARIABLES:
* ----------
*     NBNN        NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
*     NEF         NUMERO DE L'ELEMENT FINI DANS NOMTP
*     NBMAIL      NOMBRE DE MAILLAGES ELEMENTAIRES
*     NBELEM      NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*     J.M.BAZE  AVRIL 97
*
* LANGAGE:
* --------
*     ESOPE + FORTRAN77
************************************************************************
      SUBROUTINE SORE1 (IPMODE,IPCHEL,IPCHE4,IPCHP1,IPRIGI)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
 
-INC SMRIGID
-INC SMCHAML
-INC SMELEME
-INC SMMODEL
-INC SMCHPOI
 
      CHARACTER*4 MOPRIM,MODUAL
      INTEGER NBROBL
      INTEGER NBRFAC
      INTEGER MODEPL
      POINTEUR nomcom.NOMID
 
      IPRIGI = 0
 
* Determination du LIEU SUPPORT du MCHAML DE CARACTERISTIQUES
      CALL QUESUP(0,IPCHEL,0,0,iretou,ISUPCA)
      IF (ISUPCA.GT.900 .OR. IERR.NE.0) RETURN
* Si le MCHAML est appuye aux NOEUDS ou au GRAVITE, on change le SUPPORT
* pour les points de GAUSS.
* Attention pour l'instant, on met en ISUPCA = 6, mais il faudrait 
* distinguer les formulations et les supports...
      IF (ISUPCA.EQ.1 .OR. ISUPCA.EQ.2) THEN
*  On change plus bas le support pour 6...
      ELSE
        IPCHE1 = IPCHEL
        IF (ISUPCA.NE.6) THEN
          write(ioimp,*) 'SORE1 : SUPPORT ISUPCA = ',ISUPCA
        ENDIF
      ENDIF
      IF (ISUPCA.NE.6) THEN
        ISUPCA = 6
        CALL CHASUP(IPMODE,IPCHEL,IPCHE1,iretou,ISUPCA)
        IF (iretou.NE.0) THEN
          CALL ERREUR(iretou)
          RETURN
        ENDIF
      ENDIF
 
*     CHPOINT de TEMPERATURE ---> MCHAML AUX NOEUDS
      CALL CHAME1(0,IPMODE,IPCHP1,' ',IPCHE2,1)
      IF (IERR.NE.0) RETURN
      ICHCAR = 0
 
*     GRADIENT de TEMPERATURE
      NBROBL=1
      NBRFAC=0
      SEGINI nomcom
      nomcom.LESOBL(1)='T       '
      MODEPL=nomcom
 
      CALL GRAD1(IPMODE,MODEPL,IPCHE2,ICHCAR,IPCHE3,iretou)
      SEGSUP NOMCOM
      IF (iretou.NE.1 .OR. IERR.NE.0) RETURN
 
*     VERIFICATION DES SUPPORTS
*
       MCHELM = IPCHE1
       SEGACT,MCHELM
       NBMAIC=IMACHE(/1)
c*       SEGDES MCHELM
 
      MMODEL = IPMODE
      SEGACT,MMODEL
      NSOUS = mmodel.KMODEL(/1)
*       IL MANQUE LES CARACTERISTIQUES D'UNE OU PLUSIEURS PARTIES
*       DU MODELE
      IF (NSOUS.GT.NBMAIC) THEN
        CALL ERREUR(404)
        SEGDES,MMODEL
        GOTO 900
       ENDIF
*
*     INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
*
      NRIGEL = NSOUS
      SEGINI,MRIGID
      mrigid.ICHOLE = 0
      mrigid.IMGEO1 = 0
      mrigid.IMGEO2 = 0
      mrigid.IFORIG = IFOUR
      mrigid.ISUPEQ = 0
      mrigid.MTYMAT = 'RIGIDITE'
      IPRIGI = MRIGID
*
*     BOUCLE SUR LES MAILLAGES ELEMENTAIRES,ZONE IMAIL
 
      DO 50 isous = 1, NSOUS
 
        IMODEL=KMODEL(isous)
        SEGACT,IMODEL
 
        NEF    = imodel.NEFMOD
 
        MELEME = imodel.IMAMOD
        SEGACT,MELEME
        NBNN   = meleme.NUM(/1)
        NBELEM = meleme.NUM(/2)
 
C       Recuperation des Noms de composante PRIMALES et DUALES
        nomid = imodel.LNOMID(1)
        SEGACT,nomid
        MOPRIM = nomid.LESOBL(1)
        SEGDES,nomid
        nomid = imodel.LNOMID(2)
        SEGACT,nomid
        MODUAL = nomid.LESOBL(1)
        SEGDES,nomid
 
*       REMPLIR LE SEGMENT DESCRIPTEUR DE L'OBJET RIGIDITE
*
        NLIGRP = NBNN
        NLIGRD = NBNN
        SEGINI,DESCR
        DO IB = 1, NLIGRP
          LISINC(IB) = MOPRIM
          LISDUA(IB) = MODUAL
          NOELEP(IB) = IB
          NOELED(IB) = IB
        ENDDO
        SEGDES,DESCR
        IDESCR = DESCR
 
        NELRIG = NBELEM
        SEGINI,xMATRI
        xMATRI.SYMRE = 2
 
        mrigid.COERIG(isous) = 1.D0
        mrigid.IRIGEL(1,isous) = IMAMOD
        mrigid.IRIGEL(2,isous) = 0
        mrigid.IRIGEL(3,isous) = IDESCR
        mrigid.IRIGEL(4,isous) = xMATRI
        mrigid.IRIGEL(5,isous) = 0
        mrigid.IRIGEL(6,isous) = 0
        mrigid.IRIGEL(7,isous) = 2
        mrigid.IRIGEL(8,isous) = 0
 
        CALL SORE2(NEF,isous,IMODEL,IPCHE1,IPCHE3,IPCHE4, IPRIGI)
 
        SEGDES,xMATRI
        SEGDES,MELEME
        IF (IERR.NE.0) GOTO 900
 
 50   CONTINUE
 
 900  CONTINUE
      DO isous = 1, NSOUS
         IMODEL = mmodel.KMODEL(isous)
         SEGDES,IMODEL
      ENDDO
      SEGDES,MMODEL
      IF (IPRIGI.NE.0) THEN
        SEGDES,MRIGID
      ELSE
        SEGSUP,MRIGID
      ENDIF
 
      MCHELM = IPCHE3
      SEGSUP,MCHELM
 
      RETURN
      END