C MASCHE SOURCE PV 09/03/12 21:27:50 6325 SUBROUTINE MASCHE( X1, MCH,ICLE,IPCHMA,ISOM,IRET) *********************************************************************** * OPERATEUR MASQ (APPELE PAR MASQ) * * ENTREES : * --------- * X1 :NB AVEC LEQUEL SONT COMPAREES LES VALEURS DU MCHAML * MCH :POINTEUR SUR UN MCHAML * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON * ISOM =1 SI L ON VEUT LA SOMME * 0 SINON * * * SORTIES : * --------- * IPCHMA :- POINTEUR SUR UN MCHALM RESULTAT SI ISOM=0 * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1 * IRET =1 OU 0 SUIVANT SUCCES OU PAS * * * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91 * *********************************************************************** IMPLICIT INTEGER(I-N) REAL*8 X1 * -INC CCOPTIO -INC SMCHAML -INC SMLREEL -INC SMCOORD * IRET=1 IPCHAM=1 IF(ISOM.EQ.0) THEN MCHEL1 = MCH SEGINI,MCHELM=MCHEL1 ELSE MCHELM = MCH SEGACT MCHELM IPCHMA=0 ENDIF * DO 1 ISOUS=1,ICHAML(/1) IF(ISOM.EQ.0) THEN MCHAM1=ICHAML(ISOUS) SEGINI,MCHAML=MCHAM1 ICHAML(ISOUS)=MCHAML ELSE MCHAML=ICHAML(ISOUS) SEGACT MCHAML ENDIF * NCOMP=IELVAL(/1) * DO 30 ICOMP=1,NCOMP MELVAL=IELVAL(ICOMP) IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN ICOD=1 ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN ICOD=2 ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN ICOD=3 ELSE MOTERR(1:4)=NOMCHE(ICOMP) CALL ERREUR(197) IRET=0 IF (ISOM.EQ.0) THEN SEGSUP MCHAML,MCHELM ELSE SEGDES MCHAML,MCHELM ENDIF RETURN ENDIF * SEGACT MELVAL N1PTEL=VELCHE(/1) N1EL =VELCHE(/2) N2PTEL=IELCHE(/1) N2EL =IELCHE(/2) * IF(ISOM.EQ.1) GOTO 10 * SEGINI MELVA1 IELVAL(ICOMP)=MELVA1 * * IF(ICLE.EQ.1) THEN IF (ICOD.EQ.1) THEN DO 21 J=1,N1EL DO 21 L=1,N1PTEL IF (VELCHE(L,J).GT.X1) MELVA1.VELCHE(L,J)=1.D0 21 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 22 J=1,N2EL DO 22 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 211 IPROG=1,JG IF (PROG(IPROG).GT.X1) MLREE1.PROG(IPROG)=1.D0 211 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 22 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 23 J=1,N2EL DO 23 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 231 IC=1,IDIM IF (XCOOR(IREF+IC).GT.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 231 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 23 CONTINUE ENDIF ELSE IF ( ICLE.EQ.2) THEN IF (ICOD.EQ.1) THEN DO 31 J=1,N1EL DO 31 L=1,N1PTEL IF (VELCHE(L,J).GE.X1) MELVA1.VELCHE(L,J)=1.D0 31 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 32 J=1,N2EL DO 32 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 311 IPROG=1,JG IF (PROG(IPROG).GE.X1) MLREE1.PROG(IPROG)=1.D0 311 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 32 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 33 J=1,N2EL DO 33 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 331 IC=1,IDIM IF (XCOOR(IREF+IC).GE.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 331 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 33 CONTINUE ENDIF ELSE IF ( ICLE.EQ.3) THEN IF (ICOD.EQ.1) THEN DO 41 J=1,N1EL DO 41 L=1,N1PTEL IF (VELCHE(L,J).EQ.X1) MELVA1.VELCHE(L,J)=1.D0 41 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 42 J=1,N2EL DO 42 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 411 IPROG=1,JG IF (PROG(IPROG).EQ.X1) MLREE1.PROG(IPROG)=1.D0 411 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 42 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 43 J=1,N2EL DO 43 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 431 IC=1,IDIM IF (XCOOR(IREF+IC).EQ.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 431 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 43 CONTINUE ENDIF ELSE IF ( ICLE.EQ.4) THEN IF (ICOD.EQ.1) THEN DO 51 J=1,N1EL DO 51 L=1,N1PTEL IF (VELCHE(L,J).LE.X1) MELVA1.VELCHE(L,J)=1.D0 51 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 52 J=1,N2EL DO 52 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 511 IPROG=1,JG IF (PROG(IPROG).LE.X1) MLREE1.PROG(IPROG)=1.D0 511 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 52 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 53 J=1,N2EL DO 53 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 531 IC=1,IDIM IF (XCOOR(IREF+IC).LE.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 531 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 53 CONTINUE ENDIF ELSE IF ( ICLE.EQ.5) THEN IF (ICOD.EQ.1) THEN DO 61 J=1,N1EL DO 61 L=1,N1PTEL IF (VELCHE(L,J).LT.X1) MELVA1.VELCHE(L,J)=1.D0 61 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 62 J=1,N2EL DO 62 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 611 IPROG=1,JG IF (PROG(IPROG).LT.X1) MLREE1.PROG(IPROG)=1.D0 611 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 62 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 63 J=1,N2EL DO 63 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 631 IC=1,IDIM IF (XCOOR(IREF+IC).LT.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 631 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 63 CONTINUE ENDIF ELSE IF ( ICLE.EQ.6) THEN IF (ICOD.EQ.1) THEN DO 71 J=1,N1EL DO 71 L=1,N1PTEL IF (VELCHE(L,J).NE.X1) MELVA1.VELCHE(L,J)=1.D0 71 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 72 J=1,N2EL DO 72 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) SEGINI MLREE1 DO 711 IPROG=1,JG IF (PROG(IPROG).NE.X1) MLREE1.PROG(IPROG)=1.D0 711 CONTINUE MELVA1.IELCHE(L,J)=MLREE1 SEGDES MLREEL,MLREE1 72 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 73 J=1,N2EL DO 73 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 731 IC=1,IDIM IF (XCOOR(IREF+IC).NE.X1) THEN XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 ELSE XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 ENDIF 731 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) IELCHE(L,J)=NBPTS 73 CONTINUE ENDIF ENDIF SEGDES MELVA1 GO TO 20 * 10 CONTINUE * IF(ICLE.EQ.1) THEN IF (ICOD.EQ.1) THEN DO 121 J=1,N1EL DO 121 L=1,N1PTEL IF (VELCHE(L,J).GT.X1) IPCHMA=IPCHMA+1 121 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 122 J=1,N2EL DO 122 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1122 IPROG=1,JG IF (PROG(IPROG).GT.X1) IPCHMA=IPCHAM+1 1122 CONTINUE SEGDES MLREEL 122 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 123 J=1,N2EL DO 123 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1123 IC=1,IDIM IF (XCOOR(IREF+IC).GT.X1) IPCHMA=IPCHAM+1 1123 CONTINUE 123 CONTINUE ENDIF ELSE IF ( ICLE.EQ.2) THEN IF (ICOD.EQ.1) THEN DO 131 J=1,N1EL DO 131 L=1,N1PTEL IF (VELCHE(L,J).GE.X1) IPCHMA=IPCHMA+1 131 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 132 J=1,N2EL DO 132 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1132 IPROG=1,JG IF (PROG(IPROG).GE.X1) IPCHMA=IPCHMA+1 1132 CONTINUE SEGDES MLREEL 132 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 133 J=1,N2EL DO 133 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1133 IC=1,IDIM IF (XCOOR(IREF+IC).GE.X1) IPCHMA=IPCHMA+1 1133 CONTINUE 133 CONTINUE ENDIF ELSE IF ( ICLE.EQ.3) THEN IF (ICOD.EQ.1) THEN DO 141 J=1,N1EL DO 141 L=1,N1PTEL IF (VELCHE(L,J).EQ.X1) IPCHMA=IPCHMA+1 141 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 142 J=1,N2EL DO 142 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1142 IPROG=1,JG IF (PROG(IPROG).EQ.X1) IPCHMA=IPCHMA+1 1142 CONTINUE SEGDES MLREEL 142 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 143 J=1,N2EL DO 143 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1143 IC=1,IDIM IF (XCOOR(IREF+IC).EQ.X1) IPCHMA=IPCHMA+1 1143 CONTINUE 143 CONTINUE ENDIF ELSE IF ( ICLE.EQ.4) THEN IF (ICOD.EQ.1) THEN DO 151 J=1,N1EL DO 151 L=1,N1PTEL IF (VELCHE(L,J).LE.X1) IPCHMA=IPCHMA+1 151 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 152 J=1,N2EL DO 152 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1152 IPROG=1,JG IF (PROG(IPROG).LE.X1) IPCHMA=IPCHMA+1 1152 CONTINUE SEGDES MLREEL 152 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 153 J=1,N2EL DO 153 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1153 IC=1,IDIM IF (XCOOR(IREF+IC).LE.X1) IPCHMA=IPCHMA+1 1153 CONTINUE 153 CONTINUE ENDIF ELSE IF ( ICLE.EQ.5) THEN IF (ICOD.EQ.1) THEN DO 161 J=1,N1EL DO 161 L=1,N1PTEL IF (VELCHE(L,J).LT.X1) IPCHMA=IPCHMA+1 161 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 162 J=1,N2EL DO 162 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1162 IPROG=1,JG IF (PROG(IPROG).LT.X1) IPCHMA=IPCHMA+1 1162 CONTINUE SEGDES MLREEL 162 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 163 J=1,N2EL DO 163 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1163 IC=1,IDIM IF (XCOOR(IREF+IC).LT.X1) IPCHMA=IPCHMA+1 1163 CONTINUE 163 CONTINUE ENDIF ELSE IF ( ICLE.EQ.6) THEN IF (ICOD.EQ.1) THEN DO 171 J=1,N1EL DO 171 L=1,N1PTEL IF (VELCHE(L,J).NE.X1) IPCHMA=IPCHMA+1 171 CONTINUE ELSE IF (ICOD.EQ.2) THEN DO 172 J=1,N2EL DO 172 L=1,N2PTEL MLREEL=IELCHE(L,J) SEGACT MLREEL JG=PROG(/1) DO 1172 IPROG=1,JG IF (PROG(IPROG).NE.X1) IPCHMA=IPCHMA+1 1172 CONTINUE SEGDES MLREEL 172 CONTINUE ELSE IF (ICOD.EQ.3) THEN DO 173 J=1,N2EL DO 173 L=1,N2PTEL IP=IELCHE(L,J) IREF=(IP-1)*(IDIM+1) * DO 1173 IC=1,IDIM IF (XCOOR(IREF+IC).NE.X1) IPCHMA=IPCHMA+1 1173 CONTINUE 173 CONTINUE ENDIF ENDIF 20 CONTINUE SEGDES MELVAL 30 CONTINUE SEGDES MCHAML 1 CONTINUE IF(ISOM.EQ.0) THEN SEGDES MCHELM IPCHMA=MCHELM ENDIF SEGDES MCHELM RETURN END