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