Sources Esope | Cast3M

sore
C SORE      SOURCE    CB215821  24/04/12    21:17:16     11897          
 
************************************************************************
*
*                             SORE
*                             ----
*
* FONCTION:
* ---------
*     CREATION D UNE MATRICE DE CONDUCTIVITE  ASSOCIEE A L EFFET SORET
*              INTEGRATION DE    N DIV(GRAD T)
*        ELEMENTS MASSIFS UNIQUEMENT
*
* PHRASE D'APPEL (EN GIBIANE):
* ----------------------------
*
*     CND1 = SORE  MOD1 MAT1  MCHAM1 CHPO1  ;
*
* OPERANDES ET RESULTAT:
* ----------------------
*
*     CND1     'RIGIDITE'  MATRICE DE CONDUCTIVITE
*
*     MOD1     'MODELE'    STRUCTURE MODELISEE
*     MAT1     'MCHAML'    PROPRIETES  DU MATERIAU
*     MCHAM1   'MCHAML'    CHAMP DES FACTEURS DU POTENTIEL
*     CHPO1    'CHPOINT'   POTENTIEL DONT LE GRADIENT EST LA 'FORCE MOTRICE'
*
*
* AUTEUR,DATE DE CREATION:
* ------------------------
*
*     J.M.BAZE   AVRIL 97
*
* LANGAGE:
* --------
*
*       ESOPE + FORTRAN77
*
************************************************************************
 
      SUBROUTINE SORE
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
 
-INC SMCHAML
-INC SMMODEL
-INC SMCHPOI
 
      CHARACTER*8 LETYPE
      PARAMETER ( LINUM=14,LINUC=12)
      INTEGER INUMA(LINUM)
 
*                TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15
      DATA INUMA/   4,   6,   8,  10,  14,  15,  16,  17,
*                TET4 TET10 PYR5 PY13 T1D2 T1D3
     1             23,   24,  25,  26, 191, 192 /
 
 
      MOTERR(1:8)=' MODELE '
      CALL MESLIR(-137)
      CALL LIROBJ('MMODEL  ',IPMODE,1,iretou)
      CALL ACTOBJ('MMODEL  ',IPMODE,1)
      IF (IERR.NE.0) RETURN
*
      CALL MESLIR(-135)
      CALL LIROBJ('MCHAML  ',IPIN,1,iretou)
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      IF (IERR.NE.0) RETURN
      CALL REDUAF(IPIN,IPMODE,IPCHEL,0,IR,KER)
      IF (IR  .NE.1) CALL ERREUR(KER)
      IF (IERR.NE.0) RETURN
*  pour eviter un plantage ulterieur
      segact mcoord
*
*     TEST SUR LE SOUS-TYPE DE LE CHAMELEM
*
      MCHELM=IPCHEL
      SEGACT,MCHELM
*
      LETYPE = TITCHE
      IF (LETYPE.NE.'CARACTER') THEN
         SEGDES,MCHELM
         MOTERR='CARACTERISTIQUES'
         CALL ERREUR(291)
         RETURN
      ENDIF
*
      MOTERR(1:8)='MCHAML  '
      CALL MESLIR(-137)
      CALL LIROBJ('MCHAML  ',IPIN,1,iretou)
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      IF (IERR.NE.0) RETURN
      CALL REDUAF(IPIN,IPMODE,IPCHE1,0,IR,KER)
      IF(IR   .NE. 1) CALL ERREUR(KER)
      IF(IERR .NE. 0) RETURN
 
      MOTERR(1:8)='CHPOINT '
      CALL MESLIR(-137)
      CALL LIROBJ('CHPOINT ',IPCHPO,1,iretou)
      CALL ACTOBJ('CHPOINT ',IPCHPO,1)
      IF (IERR.NE.0) RETURN
 
      MMODEL = IPMODE
      NSOUS = KMODEL(/1)
      N1    = NSOUS
      SEGINI,MMODE1
      ITHER = 0
      IDIFF = 0
      ICOUR = 0
      IMOD1=MMODE1
 
C     Extraction des formulations THERMIQUES 'CONDUCTION' et DIFFUSION 'FICK'
      DO ISOUS = 1, NSOUS
        IMODEL = KMODEL(ISOUS)
        NMAT = MATMOD(/2)
        IF     (FORMOD(1).EQ.'DIFFUSION       ') THEN
          CALL PLACE(MATMOD,NMAT,ipl,'FICK')
          IF (ipl .NE. 0) THEN
            IDIFF = IDIFF + 1
            ICOUR = ICOUR + 1
            MMODE1.KMODEL(ICOUR) = IMODEL
          ENDIF
 
        ELSEIF (FORMOD(1).EQ.'THERMIQUE       ') THEN
          CALL PLACE(MATMOD,NMAT,ipl,'CONDUCTION')
          IF (ipl.NE.0) THEN
            ITHER = ITHER + 1
            ICOUR = ICOUR + 1
            MMODE1.KMODEL(ICOUR) = IMODEL
          ENDIF
        ENDIF
      ENDDO
      N1 = ITHER + IDIFF
      IF (N1 .LT. NSOUS) SEGADJ,MMODE1
 
C  Verification que le modele contienne le necessaire
      IF (N1 .EQ. 0) THEN
        CALL ERREUR(21)
        RETURN
      ENDIF
 
      CALL SORE1(IMOD1,IPCHEL,IPCHE1,IPCHPO,IPRIGI)
      IF (IERR.NE.0) RETURN
 
      SEGSUP,MMODE1
 
      CALL ECROBJ('RIGIDITE',IPRIGI)
 
      END