C MSCHE1 SOURCE PV 09/03/12 21:29:06 6325 SUBROUTINE MSCHE1(IPCHE2,IPCHE1,ICLE,IPCHMA,ISOM,IRET) ***************************************************************** * OPERATEUR MASQ * * ENTREES : * --------- * IPCHE1 :POINTEUR SUR LE PREMIER CHAMELEM * IPCHE2 :POINTEUR SUR UN SECOND CHAMELEM * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON * ISOM =1 SI ON VEUT LA SOMME * =0 SINON * * SORTIE : * -------- * IPCHMA :- POINTEUR SUR LE CHAMELEM RESULTAT SI ISOM=0 * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1 * IRET =1 OU 0 SUIVANT SUCCES OU PAS * * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 01/91 * ***************************************************************** IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC SMCHAML -INC SMLREEL -INC SMCOORD * CHARACTER*4 MOK CHARACTER*16 CONCH1,CONCH2 CHARACTER*72 TIT1,TIT2,TITC PARAMETER (NINF=3) INTEGER INFOS(NINF) * SEGMENT MTRAA INTEGER ITRAA(LX) ENDSEGMENT * IRET=1 * * POUR INFERIEUR ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2 * IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN IKKK=IPCHE2 IPCHE2=IPCHE1 IPCHE1=IKKK IF (ICLE.EQ.4) ICLE=2 IF (ICLE.EQ.5) ICLE=1 ENDIF * CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET) * IF(IRET.EQ.0) RETURN * IF(K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN CALL ERREUR(488) IRET=0 RETURN ENDIF MCHEL1 =IPCHE1 MCHEL2 =IPCHE2 SEGACT MCHEL1,MCHEL2 IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) GOTO 166 TIT1 = MCHEL1.TITCHE TIT2 = MCHEL2.TITCHE IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN CALL ERREUR (21) IRET=0 GOTO 666 ENDIF NSOUS1=MCHEL1.ICHAML(/1) NSOUS2=MCHEL2.ICHAML(/1) IF(NSOUS1.NE.NSOUS2) GOTO 166 * * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2 * LX=NSOUS1 SEGINI MTRAA * DO 110 ISOUS1=1,NSOUS1 IPMAI1=MCHEL1.IMACHE(ISOUS1) CONCH1=MCHEL1.CONCHE(ISOUS1) DO 120 ISOUS2=1,NSOUS2 IPMAI2=MCHEL2.IMACHE(ISOUS2) CONCH2=MCHEL2.CONCHE(ISOUS2) IF(IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120 CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 120 * IMINT1=0 IMINT2=0 IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) IF (IMINT1.EQ.IMINT2) GOTO 121 * IMINT1=1 IMINT2=1 IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) IF (IMINT1.EQ.0) IMINT1=1 IF (IMINT2.EQ.0) IMINT2=1 IF (IMINT1.EQ.IMINT2) GOTO 121 * SEGSUP MTRAA * * ERREUR PAS DE CORRESPONDANCE 2 A 2 * GOTO 166 * 120 CONTINUE * 121 CONTINUE ITRAA(ISOUS1)=ISOUS2 GOTO 110 110 CONTINUE * * COMPARAISON PROPREMENT DITE * KSOM=0 NSOUS=NSOUS1 N1=NSOUS N3=MCHEL1.INFCHE(/2) L1=MCHEL1.TITCHE(/1) SEGINI MCHELM IPCHMA=MCHELM IFOCHE=MCHEL1.IFOCHE TITCHE=TIT1 * * BOUCLE SUR LES SOUS PAQUETS DE MCHELM * DO 200 ISOUS=1,NSOUS DO 201 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 201 CONTINUE IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) * ISOUS2=ITRAA(ISOUS) * MCHAM1=MCHEL1.ICHAML(ISOUS ) MCHAM2=MCHEL2.ICHAML(ISOUS2) SEGACT MCHAM1,MCHAM2 * NCOMP=MCHAM1.IELVAL(/1) N2=NCOMP SEGINI MCHAML ICHAML(ISOUS)=MCHAML DO 300 ICOMP=1,NCOMP CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC, & MCHAM1.NOMCHE(ICOMP) ) * IF (IPLAC.EQ.0) THEN MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) MOTERR(5:8)=TIT1(1:4) CALL ERREUR(77) SEGSUP MCHAML,MCHELM,MTRAA SEGDES MCHAM1,MCHAM2 IRET=0 GOTO 666 ELSE NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP) TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP) * MELVA1=MCHAM1.IELVAL(ICOMP) MELVA2=MCHAM2.IELVAL(IPLAC) SEGACT MELVA1,MELVA2 IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN NBPTE1=MELVA1.VELCHE(/1) NEL1 =MELVA1.VELCHE(/2) NBPTE2=MELVA2.VELCHE(/1) NEL2 =MELVA2.VELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE2) NBELEM=MAX(NEL1,NEL2) * N2PTEL=0 N2EL =0 N1PTEL=NBPGAU N1EL =NBELEM * IML=0 ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN NBPTE1=MELVA1.IELCHE(/1) NEL1 =MELVA1.IELCHE(/2) NBPTE2=MELVA2.IELCHE(/1) NEL2 =MELVA2.IELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE2) NBELEM=MAX(NEL1,NEL2) * N1PTEL=0 N1EL =0 N2PTEL=NBPGAU N2EL =NBELEM * IML=1 ELSE * * COMPOSANTE NON RECONNUE * MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP) CALL ERREUR (197) SEGSUP MCHAML,MCHELM,MTRAA SEGDES MCHAM1,MCHAM2 IRET=0 GOTO 666 ENDIF SEGINI MELVAL IELVAL(ICOMP)=MELVAL * IF(ICLE.EQ.1) THEN DO 331 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 331 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GT.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) SEGACT MLREE1,MLREE2 IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 302 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GT.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 302 CONTINUE IELCHE(IGAU,IB)=MLREEL SEGDES MLREEL SEGDES MLREE1,MLREE2 ENDIF 331 CONTINUE ELSE IF (ICLE.EQ.2) THEN DO 332 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 332 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GE.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) SEGACT MLREE1,MLREE2 IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 303 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GE.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 303 CONTINUE IELCHE(IGAU,IB)=MLREEL SEGDES MLREEL SEGDES MLREE1,MLREE2 ENDIF 332 CONTINUE ELSE IF (ICLE.EQ.3) THEN DO 333 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 333 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.EQ.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) SEGACT MLREE1,MLREE2 IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 304 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.EQ.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 304 CONTINUE IELCHE(IGAU,IB)=MLREEL SEGDES MLREEL SEGDES MLREE1,MLREE2 ENDIF 333 CONTINUE ELSE IF (ICLE.EQ.6) THEN DO 336 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 336 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.NE.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) SEGACT MLREE1,MLREE2 IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 305 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.NE.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 305 CONTINUE IELCHE(IGAU,IB)=MLREEL SEGDES MLREEL SEGDES MLREE1,MLREE2 ENDIF 336 CONTINUE ENDIF ENDIF SEGDES MELVA1,MELVA2 SEGDES MELVAL 300 CONTINUE SEGDES MCHAM1,MCHAM2 SEGDES MCHAML 200 CONTINUE SEGDES MCHELM * * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1 * DESACTIVATON DES SEGMENTS * SEGSUP MTRAA IF(ISOM.EQ.1) THEN CALL DTCHAM(IPCHMA) IPCHMA=KSOM ENDIF 666 CONTINUE SEGDES MCHEL1,MCHEL2 RETURN 166 CONTINUE CALL ERREUR(103) IRET=0 GOTO 666 END