1 : C MSCHE1 SOURCE PV 09/03/12 21:29:06 6325 2 : SUBROUTINE MSCHE1(IPCHE2,IPCHE1,ICLE,IPCHMA,ISOM,IRET) 3 : ***************************************************************** 4 : * OPERATEUR MASQ 5 : * 6 : * ENTREES : 7 : * --------- 8 : * IPCHE1 :POINTEUR SUR LE PREMIER CHAMELEM 9 : * IPCHE2 :POINTEUR SUR UN SECOND CHAMELEM 10 : * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON 11 : * ISOM =1 SI ON VEUT LA SOMME 12 : * =0 SINON 13 : * 14 : * SORTIE : 15 : * -------- 16 : * IPCHMA :- POINTEUR SUR LE CHAMELEM RESULTAT SI ISOM=0 17 : * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1 18 : * IRET =1 OU 0 SUIVANT SUCCES OU PAS 19 : * 20 : * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 01/91 21 : * 22 : ***************************************************************** 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : -INC CCOPTIO 26 : -INC SMCHAML 27 : -INC SMLREEL 28 : -INC SMCOORD 29 : * 30 : CHARACTER*4 MOK 31 : CHARACTER*16 CONCH1,CONCH2 32 : CHARACTER*72 TIT1,TIT2,TITC 33 : PARAMETER (NINF=3) 34 : INTEGER INFOS(NINF) 35 : * 36 : SEGMENT MTRAA 37 : INTEGER ITRAA(LX) 38 : ENDSEGMENT 39 : * 40 : IRET=1 41 : * 42 : * POUR INFERIEUR ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2 43 : * 44 : IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN 45 : IKKK=IPCHE2 46 : IPCHE2=IPCHE1 47 : IPCHE1=IKKK 48 : IF (ICLE.EQ.4) ICLE=2 49 : IF (ICLE.EQ.5) ICLE=1 50 : ENDIF 51 : * 51 : CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET) 52 : * 53 : IF(IRET.EQ.0) RETURN 54 : * 55 : IF(K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN 55 : CALL ERREUR(488) 56 : IRET=0 57 : RETURN 58 : ENDIF 59 : MCHEL1 =IPCHE1 60 : MCHEL2 =IPCHE2 61 : SEGACT MCHEL1,MCHEL2 62 : IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) GOTO 166 63 : TIT1 = MCHEL1.TITCHE 64 : TIT2 = MCHEL2.TITCHE 65 : IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN 65 : CALL ERREUR (21) 66 : IRET=0 67 : GOTO 666 68 : ENDIF 69 : NSOUS1=MCHEL1.ICHAML(/1) 70 : NSOUS2=MCHEL2.ICHAML(/1) 71 : IF(NSOUS1.NE.NSOUS2) GOTO 166 72 : * 73 : * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2 74 : * 75 : LX=NSOUS1 76 : SEGINI MTRAA 77 : * 78 : DO 110 ISOUS1=1,NSOUS1 79 : IPMAI1=MCHEL1.IMACHE(ISOUS1) 80 : CONCH1=MCHEL1.CONCHE(ISOUS1) 81 : DO 120 ISOUS2=1,NSOUS2 82 : IPMAI2=MCHEL2.IMACHE(ISOUS2) 83 : CONCH2=MCHEL2.CONCHE(ISOUS2) 84 : IF(IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120 84 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 85 : IF (IRTD.EQ.0) GOTO 120 86 : * 87 : IMINT1=0 88 : IMINT2=0 89 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 90 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 91 : IF (IMINT1.EQ.IMINT2) GOTO 121 92 : * 93 : IMINT1=1 94 : IMINT2=1 95 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 96 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 97 : IF (IMINT1.EQ.0) IMINT1=1 98 : IF (IMINT2.EQ.0) IMINT2=1 99 : IF (IMINT1.EQ.IMINT2) GOTO 121 100 : * 101 : SEGSUP MTRAA 102 : * 103 : * ERREUR PAS DE CORRESPONDANCE 2 A 2 104 : * 105 : GOTO 166 106 : * 107 : 120 CONTINUE 108 : * 109 : 121 CONTINUE 110 : ITRAA(ISOUS1)=ISOUS2 111 : GOTO 110 112 : 110 CONTINUE 113 : * 114 : * COMPARAISON PROPREMENT DITE 115 : * 116 : KSOM=0 117 : NSOUS=NSOUS1 118 : N1=NSOUS 119 : N3=MCHEL1.INFCHE(/2) 120 : L1=MCHEL1.TITCHE(/1) 121 : SEGINI MCHELM 122 : IPCHMA=MCHELM 123 : IFOCHE=MCHEL1.IFOCHE 124 : TITCHE=TIT1 125 : * 126 : * BOUCLE SUR LES SOUS PAQUETS DE MCHELM 127 : * 128 : DO 200 ISOUS=1,NSOUS 129 : DO 201 N33=1,N3 130 : INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 131 : 201 CONTINUE 132 : IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) 133 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 134 : * 135 : ISOUS2=ITRAA(ISOUS) 136 : * 137 : MCHAM1=MCHEL1.ICHAML(ISOUS ) 138 : MCHAM2=MCHEL2.ICHAML(ISOUS2) 139 : SEGACT MCHAM1,MCHAM2 140 : * 141 : NCOMP=MCHAM1.IELVAL(/1) 142 : N2=NCOMP 143 : SEGINI MCHAML 144 : ICHAML(ISOUS)=MCHAML 145 : DO 300 ICOMP=1,NCOMP 145 : CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC, 146 : & MCHAM1.NOMCHE(ICOMP) ) 147 : * 148 : IF (IPLAC.EQ.0) THEN 149 : MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) 150 : MOTERR(5:8)=TIT1(1:4) 150 : CALL ERREUR(77) 151 : SEGSUP MCHAML,MCHELM,MTRAA 152 : SEGDES MCHAM1,MCHAM2 153 : IRET=0 154 : GOTO 666 155 : ELSE 156 : NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP) 157 : TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP) 158 : * 159 : MELVA1=MCHAM1.IELVAL(ICOMP) 160 : MELVA2=MCHAM2.IELVAL(IPLAC) 161 : SEGACT MELVA1,MELVA2 162 : IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN 163 : NBPTE1=MELVA1.VELCHE(/1) 164 : NEL1 =MELVA1.VELCHE(/2) 165 : NBPTE2=MELVA2.VELCHE(/1) 166 : NEL2 =MELVA2.VELCHE(/2) 167 : NBPGAU=MAX(NBPTE1,NBPTE2) 168 : NBELEM=MAX(NEL1,NEL2) 169 : * 170 : N2PTEL=0 171 : N2EL =0 172 : N1PTEL=NBPGAU 173 : N1EL =NBELEM 174 : * 175 : IML=0 176 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 177 : NBPTE1=MELVA1.IELCHE(/1) 178 : NEL1 =MELVA1.IELCHE(/2) 179 : NBPTE2=MELVA2.IELCHE(/1) 180 : NEL2 =MELVA2.IELCHE(/2) 181 : NBPGAU=MAX(NBPTE1,NBPTE2) 182 : NBELEM=MAX(NEL1,NEL2) 183 : * 184 : N1PTEL=0 185 : N1EL =0 186 : N2PTEL=NBPGAU 187 : N2EL =NBELEM 188 : * 189 : IML=1 190 : ELSE 191 : * 192 : * COMPOSANTE NON RECONNUE 193 : * 194 : MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP) 194 : CALL ERREUR (197) 195 : SEGSUP MCHAML,MCHELM,MTRAA 196 : SEGDES MCHAM1,MCHAM2 197 : IRET=0 198 : GOTO 666 199 : ENDIF 200 : SEGINI MELVAL 201 : IELVAL(ICOMP)=MELVAL 202 : * 203 : IF(ICLE.EQ.1) THEN 204 : DO 331 IGAU=1,NBPGAU 205 : IGMN1=MIN(IGAU,NBPTE1) 206 : IGMN2=MIN(IGAU,NBPTE2) 207 : DO 331 IB=1,NBELEM 208 : IBMN1=MIN(IB,NEL1) 209 : IBMN2=MIN(IB,NEL2) 210 : IF (IML.EQ.0) THEN 211 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 212 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 213 : IF (XTT1.GT.XTT2) THEN 214 : VELCHE(IGAU,IB)=1.D0 215 : KSOM=KSOM+1 216 : ENDIF 217 : ELSE 218 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 219 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 220 : SEGACT MLREE1,MLREE2 221 : IPRO1=MLREE1.PROG(/1) 222 : IPRO2=MLREE2.PROG(/1) 223 : JG=MAX(IPRO1,IPRO2) 224 : * 225 : SEGINI MLREEL 226 : * 227 : DO 302 IPROG=1,JG 228 : IPMN1=MIN(IPRO1,IPROG) 229 : IPMN2=MIN(IPRO2,IPROG) 230 : XTT1=MLREE1.PROG(IPMN1) 231 : XTT2=MLREE2.PROG(IPMN2) 232 : IF (XTT1.GT.XTT2) THEN 233 : PROG(IPROG)=1.D0 234 : KSOM=KSOM+1 235 : ENDIF 236 : 302 CONTINUE 237 : IELCHE(IGAU,IB)=MLREEL 238 : SEGDES MLREEL 239 : SEGDES MLREE1,MLREE2 240 : ENDIF 241 : 331 CONTINUE 242 : ELSE IF (ICLE.EQ.2) THEN 243 : DO 332 IGAU=1,NBPGAU 244 : IGMN1=MIN(IGAU,NBPTE1) 245 : IGMN2=MIN(IGAU,NBPTE2) 246 : DO 332 IB=1,NBELEM 247 : IBMN1=MIN(IB,NEL1) 248 : IBMN2=MIN(IB,NEL2) 249 : IF (IML.EQ.0) THEN 250 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 251 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 252 : IF (XTT1.GE.XTT2) THEN 253 : VELCHE(IGAU,IB)=1.D0 254 : KSOM=KSOM+1 255 : ENDIF 256 : ELSE 257 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 258 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 259 : SEGACT MLREE1,MLREE2 260 : IPRO1=MLREE1.PROG(/1) 261 : IPRO2=MLREE2.PROG(/1) 262 : JG=MAX(IPRO1,IPRO2) 263 : * 264 : SEGINI MLREEL 265 : * 266 : DO 303 IPROG=1,JG 267 : IPMN1=MIN(IPRO1,IPROG) 268 : IPMN2=MIN(IPRO2,IPROG) 269 : XTT1=MLREE1.PROG(IPMN1) 270 : XTT2=MLREE2.PROG(IPMN2) 271 : IF (XTT1.GE.XTT2) THEN 272 : PROG(IPROG)=1.D0 273 : KSOM=KSOM+1 274 : ENDIF 275 : 303 CONTINUE 276 : IELCHE(IGAU,IB)=MLREEL 277 : SEGDES MLREEL 278 : SEGDES MLREE1,MLREE2 279 : ENDIF 280 : 332 CONTINUE 281 : ELSE IF (ICLE.EQ.3) THEN 282 : DO 333 IGAU=1,NBPGAU 283 : IGMN1=MIN(IGAU,NBPTE1) 284 : IGMN2=MIN(IGAU,NBPTE2) 285 : DO 333 IB=1,NBELEM 286 : IBMN1=MIN(IB,NEL1) 287 : IBMN2=MIN(IB,NEL2) 288 : IF (IML.EQ.0) THEN 289 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 290 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 291 : IF (XTT1.EQ.XTT2) THEN 292 : VELCHE(IGAU,IB)=1.D0 293 : KSOM=KSOM+1 294 : ENDIF 295 : ELSE 296 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 297 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 298 : SEGACT MLREE1,MLREE2 299 : IPRO1=MLREE1.PROG(/1) 300 : IPRO2=MLREE2.PROG(/1) 301 : JG=MAX(IPRO1,IPRO2) 302 : * 303 : SEGINI MLREEL 304 : * 305 : DO 304 IPROG=1,JG 306 : IPMN1=MIN(IPRO1,IPROG) 307 : IPMN2=MIN(IPRO2,IPROG) 308 : XTT1=MLREE1.PROG(IPMN1) 309 : XTT2=MLREE2.PROG(IPMN2) 310 : IF (XTT1.EQ.XTT2) THEN 311 : PROG(IPROG)=1.D0 312 : KSOM=KSOM+1 313 : ENDIF 314 : 304 CONTINUE 315 : IELCHE(IGAU,IB)=MLREEL 316 : SEGDES MLREEL 317 : SEGDES MLREE1,MLREE2 318 : ENDIF 319 : 333 CONTINUE 320 : ELSE IF (ICLE.EQ.6) THEN 321 : DO 336 IGAU=1,NBPGAU 322 : IGMN1=MIN(IGAU,NBPTE1) 323 : IGMN2=MIN(IGAU,NBPTE2) 324 : DO 336 IB=1,NBELEM 325 : IBMN1=MIN(IB,NEL1) 326 : IBMN2=MIN(IB,NEL2) 327 : IF (IML.EQ.0) THEN 328 : XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) 329 : XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) 330 : IF (XTT1.NE.XTT2) THEN 331 : VELCHE(IGAU,IB)=1.D0 332 : KSOM=KSOM+1 333 : ENDIF 334 : ELSE 335 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 336 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 337 : SEGACT MLREE1,MLREE2 338 : IPRO1=MLREE1.PROG(/1) 339 : IPRO2=MLREE2.PROG(/1) 340 : JG=MAX(IPRO1,IPRO2) 341 : * 342 : SEGINI MLREEL 343 : * 344 : DO 305 IPROG=1,JG 345 : IPMN1=MIN(IPRO1,IPROG) 346 : IPMN2=MIN(IPRO2,IPROG) 347 : XTT1=MLREE1.PROG(IPMN1) 348 : XTT2=MLREE2.PROG(IPMN2) 349 : IF (XTT1.NE.XTT2) THEN 350 : PROG(IPROG)=1.D0 351 : KSOM=KSOM+1 352 : ENDIF 353 : 305 CONTINUE 354 : IELCHE(IGAU,IB)=MLREEL 355 : SEGDES MLREEL 356 : SEGDES MLREE1,MLREE2 357 : ENDIF 358 : 336 CONTINUE 359 : ENDIF 360 : ENDIF 361 : SEGDES MELVA1,MELVA2 362 : SEGDES MELVAL 363 : 300 CONTINUE 364 : SEGDES MCHAM1,MCHAM2 365 : SEGDES MCHAML 366 : 200 CONTINUE 367 : SEGDES MCHELM 368 : * 369 : * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1 370 : * DESACTIVATON DES SEGMENTS 371 : * 372 : SEGSUP MTRAA 373 : IF(ISOM.EQ.1) THEN 373 : CALL DTCHAM(IPCHMA) 374 : IPCHMA=KSOM 375 : ENDIF 376 : 666 CONTINUE 377 : SEGDES MCHEL1,MCHEL2 378 : RETURN 379 : 166 CONTINUE 379 : CALL ERREUR(103) 380 : IRET=0 381 : GOTO 666 382 : END 383 : 384 : 385 : 386 : 387 :
© Cast3M 2003 - All rights reserved.
Disclaimer