Sources Esope | Cast3M

quelqu
C QUELQU    SOURCE    CB215821  22/07/20    15:39:45     11411          
C   OPERATEUR QUELQUONQUE (ie QUELCONQUE ;)
C
      SUBROUTINE QUELQU
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
-INC SMLREEL
      CHARACTER*4 ITSEG(2)
      INTEGER IRETOU,IRETO1,IRETO2,IRETO3
      DATA ITSEG/'SEG2','SEG3'/
      SEGMENT IBUF(0)
      IRETOU=0
      IRETO1=0
      IRETO2=0
      IRETO3=0
 
      CALL LIRMOT(ITSEG,2,ITYP,1)
      IF (IERR.NE.0) RETURN
      SEGINI IBUF
C
      CALL LIROBJ('LISTREEL',MLREE1,0,IRETO1)
      IF(IRETO1.NE.0)THEN
         SEGACT MLREE1
         JG1=MLREE1.PROG(/1)
         IF (IDIM.GE.2) THEN
            CALL LIROBJ('LISTREEL',MLREE2,1,IRETO2)
C ON DOIT LIRE UNE DEUXIEME PROGRESSION
            IF(IRETO2.EQ.0) RETURN
            SEGACT MLREE2
            IF(IDIM.EQ.3)THEN
               CALL LIROBJ('LISTREEL',MLREE3,1,IRETO3)
C ON DOIT LIRE UNE TROISIEME PROGRESSION EN 3 D
               IF(IRETO3.EQ.0)RETURN
               SEGACT MLREE3
            ENDIF
            JG2=MLREE2.PROG(/1)
C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
            IF(JG2.NE.JG1) CALL ERREUR(577)
            IF(IDIM.EQ.3) THEN
               JG3=MLREE3.PROG(/1)
C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
               IF(JG3.NE.JG1)CALL ERREUR(577)
            ENDIF
         ENDIF
C LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR SUFFISANTE
         IF(JG1.LE.ITYP) CALL ERREUR(725)
         IF(ITYP.EQ.2)THEN
C LIGNE CONSTITUEE DE SEG3 :
C   LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR ADEQUATE
            IQUOT=(JG1-3)/2
            IREST=JG1-3-2*IQUOT
            IF(IREST.NE.0) CALL ERREUR(726)
         ENDIF
         YG2=0.D0
         ZG3=0.D0
         DO 10 IG1=1,JG1
            XG1=MLREE1.PROG(IG1)
            IF (IDIM.GE.2) YG2=MLREE2.PROG(IG1)
            IF (IDIM.EQ.3) ZG3=MLREE3.PROG(IG1)
            CALL CREPO1(XG1,YG2,ZG3,IPO)
            IBUF(**)=IPO
 10      CONTINUE
         SEGDES MLREE1
         IF(IRETO2.EQ.1) SEGDES MLREE2
         IF(IRETO3.EQ.1) SEGDES MLREE3
      ELSE
*
 20      CONTINUE
         CALL LIROBJ('POINT ',IP,0,IRETOU)
         IF (IRETOU.NE.0) THEN
            IBUF(**)=IP
            GOTO 20
         ENDIF
         CALL LIROBJ('MAILLAGE',IPT1,0,IRETOU)
         IF (IRETOU.EQ.1) THEN
            SEGACT IPT1
            IF ((IPT1.ITYPEL).NE.1) CALL ERREUR(426)
            NBNN   = IPT1.NUM(/1)
            NBELEM = IPT1.NUM(/2)
            DO 21 I=1,NBELEM
               IBUF(**)= IPT1.NUM(1,I)
 21         CONTINUE
            SEGDES IPT1
         ENDIF
      ENDIF
      NBP=IBUF(/1)
      NBNN=ITYP+1
      NBSOUS=0
      NBREF=0
      NBELEM=(NBP-1)/(NBNN-1)
      IF (NBELEM.LE.0.OR.NBELEM*(NBNN-1).NE.(NBP-1)) CALL ERREUR(20)
      IF (IERR.NE.0) RETURN
      SEGINI MELEME
      ITYPEL=NBNN
      DO 30 IEL=1,NBELEM
         DO 40 IN=1,NBNN
            NUM(IN,IEL)=IBUF((IEL-1)*(NBNN-1)+IN)
 40      CONTINUE
         ICOLOR(IEL)=IDCOUL
 30   CONTINUE
      SEGDES MELEME
      SEGSUP IBUF
      CALL ECROBJ('MAILLAGE',MELEME)
      END