Sources Esope | Cast3M

extr14
C EXTR14    SOURCE    CB215821  20/11/04    21:17:05     10766          
      SUBROUTINE EXTR14(IPCHE1,IENT1,IENT2,IENT3,MOT)
C_____________________________________________________________________
C
C     Extrait une composante d'un MCHAML
C
C  Entrees :
C  ---------
C
C     IPCHE1  Pointeur sur un MCHAML
C     IENT1   Numero de la sous zone
C     IENT2   Numero de l'element
C     IENT3   Numero du point de gauss
C     MOT     Nom de la composante a extraire ou mot cle indiquant
C             l'action a effectuer  (TITR = TYPE ou MAIL)
C
C  JM CAMPENON le 07/91
C  C La Borderie le 21/07/92 :possibilite d'extraire une composante entiere
C  PP 21/12/92 :extension a l'extraction d'un objet de type quelconque
C_____________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCHAML
-INC SMINTE
-INC SMLMOTS
-INC SMELEME
C
      logical ltelq
      REAL*8 FLOX
      CHARACTER*(LOCOMP) MOT
      CHARACTER*(4) MOT4
      CHARACTER*8 TYPOBJ
      CHARACTER*(LOCHAI) CTEXT
C
      MCHELM=IPCHE1
      SEGACT MCHELM
      NSOUS=ICHAML(/1)
C
      MOT4=MOT
      IF ((MOT4.EQ.'TITR').OR.(MOT4.EQ.'TYPE')) THEN
         JGM=1
         JGN=TITCHE(/1)
         CTEXT=TITCHE
         SEGINI MLMOTS
         IPMOTS=MLMOTS
         MOTS(1)=CTEXT
         SEGDES MLMOTS
         CALL ECROBJ('LISTMOTS',IPMOTS)
         RETURN
      ELSEIF (MOT4.EQ.'MAIL') THEN
         N1 = IMACHE(/1)
         IF ( N1 .EQ. 0) THEN
C          Cas du MCHAML VIDE ==> MAILLAGE VIDE
           NBELEM=0
           NBNN  =NBNNE(ILCOUR)
           NBREF =0
           NBSOUS=0
           SEGINI MELEME
           ITYPEL = ILCOUR
           IPP1 = MELEME
         ELSE
           IPP1=IMACHE(1)
           IF(NSOUS.GT.1) THEN
              DO 30 I=2,NSOUS
                 IPP2=IMACHE(I)
                 ltelq=.false.
                 CALL FUSE (IPP1,IPP2,IRET,ltelq)
                 IPP1=IRET
 30          CONTINUE
           ENDIF
         ENDIF
         CALL ACTOBJ('MAILLAGE',IPP1,1)
         CALL ECROBJ('MAILLAGE',IPP1)
         GOTO 555
      ENDIF
C
      IF (IENT1.GT.NSOUS) THEN
C
C        Sous zone inexistante
C
         CALL ERREUR(279)
         GOTO 555
      ENDIF
C
      MELEME=IMACHE(IENT1)
      SEGACT MELEME
      NBELEM=NUM(/2)
      NBPGAU=NUM(/1)
C
      N3=INFCHE(/2)
      IF (N3.GE.4) THEN
         MINTE=INFCHE(IENT1,4)
         IF(MINTE.NE.0)THEN
          SEGACT MINTE
          NBPGAU=POIGAU(/1)
        ENDIF
      ENDIF
C
      IF (IENT3.GT.NBPGAU.OR.IENT2.GT.NBELEM) THEN
C
C        Numero du point de gauss ou de l'element trop grand
C
         CALL ERREUR(281)
         GOTO 555
      ENDIF
C
      MCHAML=ICHAML(IENT1)
      SEGACT MCHAML
      NCOMP=IELVAL(/1)
      DO 100 ICOMP=1,NCOMP
         IF (MOT.EQ.NOMCHE(ICOMP)) GOTO 200
 100  CONTINUE
C
C     Composante inexistante
C
      CALL ERREUR (280)
      GOTO 444
C
 200  CONTINUE
      MELVAL=IELVAL(ICOMP)
      SEGACT MELVAL
C+PP
      IF(TYPCHE(ICOMP)(1:6).EQ.'REAL*8')THEN
         IGMN=MIN(IENT3,VELCHE(/1))
         IBMN=MIN(IENT2,VELCHE(/2))
         FLOX=VELCHE(IGMN,IBMN)
         CALL ECRREE(FLOX)
      ELSE
        TYPOBJ=TYPCHE(ICOMP)(9:16)
        IGMN=MIN(IENT3,IELCHE(/1))
        IBMN=MIN(IENT2,IELCHE(/2))
        IPOOBJ=IELCHE(IGMN,IBMN)
C       Gestion des pointeurs nuls (et oui, ca arrive)
        IF (IPOOBJ.EQ.0) THEN
          MOTERR(1:8)=TYPOBJ
          CALL ERREUR(356)
        ENDIF
        CALL ACTOBJ(TYPOBJ,IPOOBJ,1)
        CALL ECROBJ(TYPOBJ,IPOOBJ)
      ENDIF
C+PP
C
 444  CONTINUE
C
 555  CONTINUE
      END