Esope source files

   1 : C EXTR14    SOURCE    PV        09/03/12    21:22:06     6325           
   2 :       SUBROUTINE EXTR14(IPCHE1,IENT1,IENT2,IENT3,MOT)
   3 : *_____________________________________________________________________
   4 : *
   5 : *     Extrait une composante d'un MCHAML
   6 : *
   7 : *  Entrees :
   8 : *  ---------
   9 : *
  10 : *     IPCHE1  Pointeur sur un MCHAML
  11 : *     IENT1   Numero de la sous zone
  12 : *     IENT2   Numero de l'element
  13 : *     IENT3   Numero du point de gauss
  14 : *     MOT     Nom de la composante a extraire ou mot cle indiquant
  15 : *             l'action a effectuer  (TITR = TYPE ou MAIL)
  16 : *
  17 : *  JM CAMPENON le 07/91
  18 : *  C La Borderie le 21/07/92 :possibilite d'extraire une composante entiere
  19 : *  PP 21/12/92 :extension a l'extraction d'un objet de type quelconque
  20 : *_____________________________________________________________________
  21 : *
  22 :       IMPLICIT INTEGER(I-N)
  23 :       IMPLICIT REAL*8(A-H,O-Z)
  24 : *
  25 : -INC CCOPTIO
  26 : -INC SMCHAML
  27 : -INC SMINTE
  28 : -INC SMLMOTS
  29 : -INC SMELEME
  30 : *
  31 :       logical ltelq
  32 :       REAL*8 FLOX
  33 :       CHARACTER*4 MOT
  34 :       CHARACTER*8 TYPOBJ
  35 :       CHARACTER*72 CTEXT
  36 : *
  37 :       MCHELM=IPCHE1
  38 :       SEGACT MCHELM
  39 :       NSOUS=ICHAML(/1)
  40 : *
  41 :       IF ((MOT.EQ.'TITR').OR.(MOT.EQ.'TYPE')) THEN
  42 :          JGM=1
  43 :          JGN=TITCHE(/1)
  44 :          CTEXT=TITCHE
  45 :          SEGDES MCHELM
  46 :          SEGINI MLMOTS
  47 :          IPMOTS=MLMOTS
  48 :          MOTS(1)=CTEXT
  49 :          SEGDES MLMOTS
  49 :          CALL ECROBJ('LISTMOTS',IPMOTS)
  50 :          RETURN
  51 :       ELSE IF (MOT.EQ.'MAIL') THEN
  52 :          IPP1=IMACHE(1)
  53 :          IF(NSOUS.GT.1) THEN
  54 :             DO 30 I=2,NSOUS
  55 :                IPP2=IMACHE(I)
  56 :                ltelq=.false.
  56 :                CALL FUSE (IPP1,IPP2,IRET,ltelq)
  57 :                IPP1=IRET
  58 :  30        CONTINUE
  59 :          ENDIF
  59 :          CALL ECROBJ('MAILLAGE',IPP1)
  60 :          GOTO 555
  61 :       ENDIF
  62 : *
  63 :       IF (IENT1.GT.NSOUS) THEN
  64 : *
  65 : *        Sous zone inexistante
  66 : *
  66 :          CALL ERREUR(279)
  67 :          GOTO 555
  68 :       ENDIF
  69 : *
  70 :       MELEME=IMACHE(IENT1)
  71 :       SEGACT MELEME
  72 :       NBELEM=NUM(/2)
  73 :       NBPGAU=NUM(/1)
  74 :       SEGDES MELEME
  75 : *
  76 :       N3=INFCHE(/2)
  77 :       IF (N3.GE.4) THEN
  78 :          MINTE=INFCHE(IENT1,4)
  79 :          IF(MINTE.NE.0)THEN
  80 :           SEGACT MINTE
  81 :           NBPGAU=POIGAU(/1)
  82 :           SEGDES MINTE
  83 :         ENDIF
  84 :       ENDIF
  85 : *
  86 :       IF (IENT3.GT.NBPGAU.OR.IENT2.GT.NBELEM) THEN
  87 : *
  88 : *        Numero du point de gauss ou de l'element trop grand
  89 : *
  89 :          CALL ERREUR(281)
  90 :          GOTO 555
  91 :       ENDIF
  92 : *
  93 :       MCHAML=ICHAML(IENT1)
  94 :       SEGACT MCHAML
  95 :       NCOMP=IELVAL(/1)
  96 :       DO 100 ICOMP=1,NCOMP
  97 :          IF (MOT.EQ.NOMCHE(ICOMP)) GOTO 200
  98 :  100  CONTINUE
  99 : *
 100 : *     Composante inexistante
 101 : *
 101 :       CALL ERREUR (280)
 102 :       GOTO 444
 103 : *
 104 :  200  CONTINUE
 105 :       MELVAL=IELVAL(ICOMP)
 106 :       SEGACT MELVAL
 107 : C+PP
 108 :       IF(TYPCHE(ICOMP)(1:6).EQ.'REAL*8')THEN
 109 :          IGMN=MIN(IENT3,VELCHE(/1))
 110 :          IBMN=MIN(IENT2,VELCHE(/2))
 111 :          FLOX=VELCHE(IGMN,IBMN)
 111 :          CALL ECRREE(FLOX)
 112 :       ELSE
 113 :         TYPOBJ=TYPCHE(ICOMP)(9:16)
 114 :         IGMN=MIN(IENT3,IELCHE(/1))
 115 :         IBMN=MIN(IENT2,IELCHE(/2))
 116 :         IPOOBJ=IELCHE(IGMN,IBMN)
 116 :         CALL ECROBJ(TYPOBJ,IPOOBJ)
 117 :       ENDIF
 118 : C+PP
 119 :       SEGDES MELVAL
 120 : *
 121 :  444  CONTINUE
 122 :       SEGDES MCHAML
 123 : *
 124 :  555  CONTINUE
 125 :       SEGDES MCHELM
 126 :       RETURN
 127 :       END
 128 :  
 129 :  
 130 :  
 131 :