Sources Esope | Cast3M

excoor
C EXCOOR    SOURCE    PASCAL    21/06/22    21:15:04     11039          
C   EXTRAIT LA IEME COORDONNEE D'UN POINT. SI IDIM+1 REND LA DENSITE
C     SI PAS DE NOMBRE SPECIFIE REND TOUTES LES COORDONNEES
C     DANS LE CAS D'OBJET MELEME FAIT LA MEME CHOSE SAUF QU'IL CREE
C     AUTANT DE CHPOIN QUE IDIM
 
      SUBROUTINE EXCOOR
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMCHAML
 
      PARAMETER ( NBTYP = 5 )
      CHARACTER*8 LISTYP(NBTYP),MOTYPE
*
      DATA LISTYP/'POINT   ','MAILLAGE','MCHAML  ', 'CHPOINT ',
     &            'MMODEL  '/
*
      segact mcoord
*  LECTURE DE LA COMPOSANTE ( EVENTUELLE )
*
      CALL LIRENT(ICOMP,0,IRT2)
*
      CALL QUETYP(MOTYPE,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
         CALL ERREUR ( 533)
         RETURN
      ENDIF
      CALL PLACE(LISTYP,NBTYP,IPOS,MOTYPE)
      IF (IPOS.EQ.0) THEN
        MOTERR(1:8)=MOTYPE
        CALL ERREUR(39)
        RETURN
      ENDIF
      CALL LIROBJ(MOTYPE,IRT1,1,IRETOU)
*
      IF(IPOS.NE.1) THEN
      IF((ICOMP.LE.0.OR.ICOMP.GT.IDIM+1).AND.IRT2.EQ.1)  THEN
          INTERR(1)=ICOMP
          CALL ERREUR(36)
          RETURN
          ENDIF
      IF(IRT2.EQ.0) THEN
         IVAL=0
      ELSE
         IVAL=ICOMP
      ENDIF
      ENDIF
*
      GO TO (100,200,300,400,500),IPOS
C
C  CAS DU POINT
C
  100 CONTINUE
      IP=IRT1
      IC=ICOMP
      IF (IRT2.EQ.1.AND.(IC.LE.0.OR.IC.GT.IDIM+1)) CALL ERREUR(36)
      IF (IERR.NE.0) RETURN
      SEGACT MCOORD
      IREF=(IP-1)*(IDIM+1)
      IF(IRT2.EQ.0) GOTO 10
      XRET=XCOOR(IREF+IC)
      CALL ECRREE(XRET)
      GOTO 20
  10  CONTINUE
      DO 11 I=1,IDIM
      II=IDIM+1-I
      XRET=XCOOR(IREF+II)
      CALL ECRREE(XRET)
  11  CONTINUE
  20  CONTINUE
      RETURN
C
C  CAS DU MELEME
C
  200 CONTINUE
      CALL CHPCOO(IVAL,IRT1)
      RETURN
C
C  CAS DU MCHAML
C
  300 CONTINUE
      IPCHE1=0
      IPCHE2=0
      IPCHE3=0
      MCHEL1=IRT1
  350 CONTINUE
      CALL ACTOBJ('MCHAML',MCHEL1,1)
      I1=MCHEL1.IMACHE(/1)
C  MCHAML VIDE
      IF (I1.EQ.0) THEN
        N1=0
        N3=0
        L1=8
        SEGINI,MCHEL2
        MCHEL2.IFOCHE=IFOUR
        MCHEL2.TITCHE='        '
        IPCHE1=MCHEL2
        IF (IVAL.EQ.0) THEN
          IF (IDIM.EQ.2) THEN
            SEGINI,MCHEL3
            MCHEL3.IFOCHE=IFOUR
            MCHEL3.TITCHE='        '
            IPCHE2=MCHEL3
          ELSEIF (IDIM.EQ.3) THEN
            SEGINI,MCHEL3
            MCHEL3.IFOCHE=IFOUR
            MCHEL3.TITCHE='        '
            IPCHE2=MCHEL3
            SEGINI,MCHEL4
            MCHEL4.IFOCHE=IFOUR
            MCHEL4.TITCHE='        '
            IPCHE3=MCHEL4
          ENDIF
        ENDIF
C  MCHAML NON VIDE
      ELSE
        CALL CHELCO(IVAL,MCHEL1,IPCHE1,IPCHE2,IPCHE3)
      ENDIF
      IF(IERR.EQ.0)THEN
          CALL ACTOBJ('MCHAML',IPCHE1,1)
          CALL ECROBJ('MCHAML',IPCHE1)
          IF(IPCHE2.NE.0)THEN
            CALL ACTOBJ('MCHAML',IPCHE2,1)
            CALL ECROBJ('MCHAML',IPCHE2)
          ENDIF
          IF(IPCHE3.NE.0)THEN
            CALL ACTOBJ('MCHAML',IPCHE3,1)
            CALL ECROBJ('MCHAML',IPCHE3)
          ENDIF
      ENDIF
      RETURN
C
C  CAS DU CHPOINT
C
  400 CONTINUE
      CALL CHPTCO(IVAL,IRT1)
      RETURN
 
C
C  CAS DU MMODEL
C
  500 CONTINUE
C     IRT1 : pointeur sur objet MMODEL
      CALL ACTOBJ('MMODEL  ',IRT1,1)
      IF (IERR.NE.0) RETURN
      CALL ZEROP(IRT1,'NOEUD',MCHEL1)
      IF (IERR.NE.0) RETURN
      GOTO 350
 
      END