Télécharger masq.eso

Retour à la liste

masq
C MASQ      SOURCE    PV        20/04/28    21:15:14     10593          
      SUBROUTINE MASQ
************************************************************************
*                                                                      *
*                    OPERATEUR MASQUE                                  *
*                                                                      *
************************************************************************
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
 
-INC PPARAM
-INC CCOPTIO
*
      PARAMETER (LMOT=8,LSOM=1,LTYP=4)
      CHARACTER*4 MMOT(LMOT),MSOM(LSOM),MOT1
      CHARACTER*8 MTYP(LTYP)
      CHARACTER*8 LETYP,CHA8
      INTEGER IOB,IOB1,IOB2
      INTEGER I1,I2
      INTEGER ICLE,IRET,IRET2,ISOM
      REAL*8 X1,X2
*
      DATA MMOT/'SUPE','EGSU','EGAL','EGIN','INFE','DIFF','COMP','EXIS'/
      DATA MSOM/'SOMM'/
      DATA MTYP/'MCHAML','CHPOINT','LISTREEL','LISTENTI'/
*
      LETYP=' '
      IOB=0
      IOB1=0
      IOB2=0
      ICLE=0
      X1=0.D0
      X2=0.D0
      I1=0
      I2=0
      IRET=0
      IRET2=0
      ISOM=0
 
*
*     ============================
*     LECTURE DES DONNEES D'ENTREE
*     ============================
*
*     LECTURE OBLIGATOIRE DU MOT-CLE PRINCIPAL
      CALL LIRMOT(MMOT,LMOT,ICLE,1)
      IF (IERR.NE.0) RETURN
*
*     LECTURE FACULTATIVE DU MOT-CLE "SOMM"
      ISOM=0
      CALL LIRMOT(MSOM,LSOM,ISOM,0)
      IF (IERR.NE.0) RETURN
*      
*     LECTURE DE L'OBJET PRINCIPAL
      CALL QUETYP(LETYP,1,IRET)
      IF (IERR.NE.0) RETURN
      CALL PLACE(MTYP,LTYP,ITYP,LETYP)
      IF (ITYP.EQ.0) THEN
         MOTERR(1:8)=LETYP
         CALL ERREUR(39)
         RETURN
      ENDIF
      CALL LIROBJ(LETYP,IOB,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ(LETYP,IOB,1)
      IF (IERR.NE.0) RETURN
*
*     LECTURE DU CRITERE DU MASQUE
      IRET1=0
      MOT1='TOUS'
*     cas du test d'existence ('EXIS') : on veut un nom de composante
      IF(ICLE.EQ.8) THEN
         ISOM=0
         CALL LIRCHA(MOT1,0,IRETOU)
         IF(IERR.NE.0) RETURN  
         IF(IRETOU.EQ.0) MOT1='TOUS'
         IRET1=1
         GOTO 1
      ENDIF
*     cas des tests de relation algebrique ('SUPE' ...) : 
      CALL QUETYP(CHA8,1,IRETOU)
      IF (CHA8.EQ.'ENTIER') THEN
         CALL LIRENT(I1,1,IRET1)
         IF (IERR.NE.0) RETURN
         X1=I1
      ELSEIF (CHA8.EQ.'FLOTTANT'.AND.ITYP.NE.4) THEN
         CALL LIRREE(X1,1,IRET1)
         IF (IERR.NE.0) RETURN
      ELSEIF (CHA8.EQ.LETYP) THEN
         CALL LIROBJ(LETYP,IOB1,1,IRETOU)
         IF (IERR.NE.0) RETURN
         CALL ACTOBJ(LETYP,IOB1,1)
         IF (IERR.NE.0) RETURN
      ELSE
         MOTERR(1:8)=CHA8
         CALL ERREUR(39)
         RETURN
      ENDIF
 
*     LECTURE D'UN DEUXIEME CRITERE POUR LE MOT-CLE "COMPRIS"
      IRET2=0
      IF (ICLE.EQ.7) THEN
         CALL QUETYP(CHA8,1,IRETOU)
         IF (CHA8.EQ.'ENTIER') THEN
            CALL LIRENT(I2,1,IRET2)
            IF (IERR.NE.0) RETURN
            X2=I2
         ELSEIF (CHA8.EQ.'FLOTTANT'.AND.ITYP.NE.4) THEN
            CALL LIRREE(X2,1,IRET2)
            IF (IERR.NE.0) RETURN
         ELSEIF (CHA8.EQ.LETYP) THEN
            CALL LIROBJ(LETYP,IOB2,1,IRETOU)
            IF (IERR.NE.0) RETURN
            CALL ACTOBJ(LETYP,IOB2,1)
            IF (IERR.NE.0) RETURN
         ELSE
            MOTERR(1:8)=CHA8
            CALL ERREUR(39)
            RETURN
         ENDIF
      ENDIF
 
*     ==================
*     CREATION DU MASQUE
*     ==================
 
   1  CONTINUE
      GOTO(100,200,300,300) ITYP
*
*     CAS D'UN OBJET MCHAML
 100  CONTINUE
      IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
         CALL MASCHE(X1,X2,IOB,MOT1,ICLE,IRET,ISOM,IRETER)
      ELSEIF (IRET1.NE.0) THEN
         CALL MSCHE1(IOB2,0,X1,1,IOB,ICLE,IRET,ISOM,IRETER)
      ELSE
         CALL MSCHE1(IOB1,IOB2,X2,-IRET2,IOB,ICLE,IRET,ISOM,IRETER)
      ENDIF
      IF (IRETER.EQ.0.OR.IERR.NE.0) RETURN
      GOTO 1000
*
*     CAS D'UN OBJET CHPOINT
 200  CONTINUE
      IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
         CALL MASCHP(X1,X2,IOB,ICLE,IRET,ISOM)
      ELSEIF (IRET1.NE.0) THEN
         CALL MSCHP1(IOB2,0,X1,1,IOB,ICLE,IRET,ISOM)
      ELSE
         CALL MSCHP1(IOB1,IOB2,X2,-IRET2,IOB,ICLE,IRET,ISOM)
      ENDIF
      IF (IERR.NE.0) RETURN
      GOTO 1000
*
*     CAS D'UN OBJET LISTENTI OU LISTREEL
 300  CONTINUE
      IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
         CALL MASLIS(LETYP,IOB,ICLE,X1,I1,X2,I2,IRET,ISOM)
      ELSEIF (IRET1.NE.0) THEN
         CALL MSLIS1(LETYP,IOB,ICLE,IOB2,0,X1,I1,1,IRET,ISOM)
      ELSE
         CALL MSLIS1(LETYP,IOB,ICLE,IOB1,IOB2,X2,I2,-IRET2,IRET,ISOM)
      ENDIF
      IF (IERR.NE.0) RETURN
 
 
*     ====================
*     FIN DE LA SUBROUTINE
*     ==================== 
 
 1000 CONTINUE
      IF (ISOM.NE.0) THEN
         CALL ECRENT(IRET)
      ELSE
         CALL ACTOBJ(LETYP,IRET,1)
         CALL ECROBJ(LETYP,IRET)
      ENDIF
 
      END
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales