Sources Esope | Cast3M

extr24
C EXTR24    SOURCE    CB215821  20/11/25    13:28:42     10792          
************************************************************************
* NOM         : extr24
* DESCRIPTION : Extrait les valeurs d'un LISTCHPO en un noeud donne
************************************************************************
* APPELÉ PAR : extrai.eso ; crevlc.eso
************************************************************************
* ENTRÉES :: aucune
* SORTIES :: aucune
************************************************************************
* SYNTAXE (GIBIANE) :
*
*          LREEL1 = EXTR LCHPO1 'VALE' (MOT1 | LMOT1) (POIN1) ;
*
************************************************************************
      SUBROUTINE EXTR24(ILCHP,ILMOT,IPOIN,ILREE)
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER NBNO
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMLCHPO
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
-INC SMLREEL
-INC SMLMOTS
*
*     NOMBRE D'OBJETS CHPOINT CONTENUS DANS LE LISTCHPO
      NBNO = 0
      MLCHPO=ILCHP
      SEGACT,MLCHPO
      NCH=ICHPOI(/1)
*
*
*     INITIALISATION DE LA LISTE DE REELS RENVOYEE EN SORTIE
      MLMOTS=ILMOT
      IF (ILMOT.EQ.0) THEN
        NCO=1
        KCO=1
        JG=NCH        
      ELSE
         SEGACT,MLMOTS
         NCO=MOTS(/2)
         JG=NCH*NCO
         IF (NCO.EQ.0) THEN
            CALL ERREUR(643)
            RETURN
         ENDIF
      ENDIF
      SEGINI,MLREEL
      ILREE=MLREEL
 
 
      ICH=0
 
*     (label 1 = boucle sur les CHPOINT)
    1 CONTINUE
      IF (ICH.EQ.NCH) RETURN
      ICH=ICH+1
      MCHPOI=ICHPOI(ICH)
      SEGACT,MCHPOI
      NSOUPO=IPCHP(/1)
 
      IF (ILMOT.EQ.0.AND.NSOUPO.GT.1) GOTO 999
 
      ISOUPO=0
 
*     (label 10 = boucle sur les SOUPO)
   10 CONTINUE
      IF (ISOUPO.EQ.NSOUPO) THEN
         SEGDES,MCHPOI
         GOTO 1
      ENDIF
      ISOUPO=ISOUPO+1
      MSOUPO=IPCHP(ISOUPO)
      SEGACT,MSOUPO
 
      NCOCH=NOCOMP(/2)
      IF (ILMOT.EQ.0.AND.NCOCH.GT.1) GOTO 999
 
      ICO=0
 
*     (label 20 = boucle sur les composantes demandees dans le LISTMOTS)
   20 CONTINUE
      IF (ICO.EQ.NCO) GOTO 90
      ICO=ICO+1
 
*     on recherche la composante requise dans le SOUPO/NOCOMP courant
      IF (ILMOT.NE.0) THEN
         DO KCO=1,NCOCH
            IF (NOCOMP(KCO).EQ.MOTS(ICO)) GOTO 30
         ENDDO
         KCO=0
         GOTO 20
      ENDIF
*
   30 CONTINUE
      MELEME=IGEOC
      MPOVAL=IPOVAL
      SEGACT,MELEME,MPOVAL
      NPOI1=NUM(/2)
*
*     on recherche le noeud requis dans le SOUPO/MPOVAL courant
      DO KNO=1,NPOI1
          IF (NUM(1,KNO).EQ.IPOIN) GOTO 40
      ENDDO
      GOTO 90
*
   40 CONTINUE
      PROG((ICO-1)*NCH+ICH)=VPOCHA(KNO,KCO)
      GOTO 20
*
*
*
   90 IF (KCO.GT.0) SEGDES,MELEME,MPOVAL
      SEGDES,MSOUPO
      GOTO 10
*
************************************************************************
*    
  999 CALL ERREUR(641)
      RETURN
*
*
      RETURN
*
      END
*
*