1 : C MUCHP1 SOURCE GOUNAND 11/06/29 21:15:13 7016 2 : SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IEPS,IRET) 3 : c======================================================================= 4 : c 5 : c entree 6 : c ipoi1=chpoint 7 : c ipoi2=chpoint 8 : c lmot1=liste de mots1 9 : c lmot2=liste de mots2 10 : c lmot3=liste de mots3 11 : c sorties 12 : c iret = pointeur sur chpoint resultant 13 : c = 0 sinon (un message d erreur est alors imprime ) 14 : c 15 : c 16 : c======================================================================= 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8(A-H,O-Z) 19 : -INC SMCHPOI 20 : -INC CCOPTIO 21 : -INC SMELEME 22 : -INC SMLMOTS 23 : -INC SMCOORD 24 : * le tableau icpr contient la mise en ordre des 3 chpoint 25 : SEGMENT ICPR 26 : * nbre harm. comp points chpoints 27 : REAL*8 VALCPR(XCOOR(/1)/(IDIM+1),NCOMP1,NHAR) 28 : ENDSEGMENT 29 : * nocmp1 et le nombre de composante dans chaque listmot 30 : * nhar est le nombre d'harmonique de Fourrier présent 31 : * ce segment contient les numéro des différents harmoniques trouvées 32 : * et l'inversion du tableau 33 : SEGMENT NUMHAR(NHAR) 34 : SEGMENT IHARNUM(NVHAR) 35 : * ce tableau sert de correspondance entre les composantes des liste mot 36 : * et celles des champ point pour chaque sous zone 37 : SEGMENT ICOR1(NCOMP1) 38 : SEGMENT ICOR2(NCOMP1) 39 : * 40 : * ces segment servent au moment de l'assemblage du nouveau chpoint 41 : * celui stocke le nombre de sous zone du nouveau chpoint 42 : SEGMENT JCHACO(4,NSOUP1) 43 : * indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante 44 : * kchaco donne l'adresse dans jchaco de la sous zone 45 : SEGMENT KCHACO(NSOUPO) 46 : SEGMENT MCORES 47 : * correspondence comp listmot comp sous zone 48 : INTEGER ICOR3(NCOMP1,NSOUPO) 49 : * indice 1 contient sum 2**i si i présent 50 : * indice 2 contient le nombre de i present 51 : INTEGER KCOMP(2,NSOUPO) 52 : INTEGER KHARM(NSOUPO) 53 : ENDSEGMENT 54 : * 55 : * ce tableau contient les pointeurs des deux champ point et des listemots 56 : DIMENSION ICHP(2),ILMO(2),NR(2) 57 : CHARACTER*4 MOTCLE(3),MONATU(1) 58 : DATA MOTCLE/'INDE','DIFF','DISC'/ 59 : DATA MONATU/'NATU'/ 60 : LOGICAL IVCHPO 61 : * 62 : * executable 63 : * verification de la dimension des listmots 64 : MLMOT1=LMOT1 65 : MLMOT2=LMOT2 66 : MLMOT3=LMOT3 67 : SEGACT MLMOT1,MLMOT2,MLMOT3 68 : NCOMP1 = MLMOT1.MOTS(/2) 69 : NCOMP2 = MLMOT2.MOTS(/2) 70 : NCOMP3 = MLMOT3.MOTS(/2) 71 : IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN 72 : * erreur dans la dimension des lismots 72 : CALL ERREUR(854) 73 : SEGDES MLMOT1,MLMOT2,MLMOT3 74 : RETURN 75 : ENDIF 76 : * determination du nombre d'harmonique de Fourrier 77 : * expédition rapide du cas sans harmonique 78 : NR(1) = 0 79 : NR(2) = 0 80 : ILMO(1)=LMOT1 81 : ILMO(2)=LMOT2 82 : ICHP(1)= IPOI1 83 : ICHP(2)= IPOI2 84 : * 85 : MCHPO1 = IPOI1 86 : MCHPO2 = IPOI2 87 : SEGACT MCHPO1,MCHPO2 88 : NHAR = 1 89 : NSUM = 0 90 : * boucle sur les 2 champoints 91 : DO 300 K=1,2 92 : MCHPO1 = ICHP(K) 93 : DO 200 I=1,MCHPO1.IPCHP(/1) 94 : MSOUPO = MCHPO1.IPCHP(I) 95 : SEGACT MSOUPO 96 : MELEME = IGEOC 97 : SEGACT MELEME 98 : NR(K) = NR(K) + NUM(/2) 99 : SEGDES MELEME 100 : DO 100 J=1,NOHARM(/1) 101 : NSUM = NSUM + NOHARM(J) 102 : 100 CONTINUE 103 : 200 CONTINUE 104 : 300 CONTINUE 105 : * 106 : * combien y a t'il d'harmoniques ? 107 : * 108 : IF (NSUM .NE. 0) THEN 109 : * il y en a plusieurs 110 : * write(6,*) 'Appel de noharm' 110 : CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNUM) 111 : NVHAR=IHARNUM(/1) 112 : ELSE 113 : * cas simple toutes les harmoniques sont nulles 114 : NHAR = 1 115 : NVHAR= 1 116 : SEGINI NUMHAR,IHARNUM 117 : NUMHAR(1)=0 118 : IHARNUM(1)=1 119 : NMIN=0 120 : ENDIF 121 : * 122 : * write(6,*) 'points',XCOOR(/1)/(IDIM+1),'Comp',ncomp1,'nhar',nhar 123 : * 124 : * initialisation du tableau 125 : SEGINI ICPR 126 : * ordre des opérations 127 : * cela va dépendre des remplissage respectifs NR1 et NR2 128 : * 129 : NRR1=MAX(NR(1),NR(2)) 130 : NRR2=MIN(NR(1),NR(2)) 131 : DNRR1 = REAL(NRR1) 132 : DNRR2 = REAL(NRR2) 133 : TAUX = DNRR2 / (DNRR1+0.1) 134 : * write(6,*) 'Taux de remplissage',taux 135 : * on classe les champ point dans l'ordre de taille 136 : IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR. 137 : & (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN 138 : * write(6,*) 'Inversion de l ordre des champoints' 139 : * write(6,*) 'Taux de remplissage' ,taux 140 : IDUM1 = ICHP(1) 141 : IDUM2 = ILMO(1) 142 : ICHP(1)=ICHP(2) 143 : ILMO(1)=ILMO(2) 144 : ICHP(2)=IDUM1 145 : ILMO(2)=IDUM2 146 : IVCHPO=.TRUE. 147 : ELSE 148 : IVCHPO=.FALSE. 149 : ENDIF 150 : * remplissage du tableau en bouclant sur les champ par points 151 : * on boucle sur les deux champ point 152 : * pour chaque sous zone on établi la correspondance de composantes du 153 : * liste mots vers les nom de composantes de la sous zone 154 : SEGINI ICOR1,ICOR2 155 : * pseudo boucle sur les champ points 156 : MCHPOI = ICHP(1) 157 : 158 : MLMOTS = ILMO(1) 159 : DO 900 J=1,IPCHP(/1) 160 : MSOUPO = IPCHP(J) 161 : * on établi la correspondance de composantes du 162 : * liste mots vers les nom de composantes de la sous zone 163 : NC = NOHARM(/1) 164 : NC1 = 0 165 : DO 600 K=1,NCOMP1 166 : ICOR1(K)=0 167 : DO 500 L=1,NC 168 : * write(6,*) MOTS(K),NOCOMP(L) 169 : IF(MOTS(K).EQ.NOCOMP(L)) THEN 170 : * write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k 171 : ICOR1(K)=L 172 : * nbre de composante présente sur la sous zone 173 : NC1 = NC1 + 1 174 : ICOR2(NC1)=K 175 : GOTO 600 176 : ENDIF 177 : 500 CONTINUE 178 : 600 CONTINUE 179 : 180 : * on remplit chaque point du meleme 181 : MELEME = IGEOC 182 : MPOVAL = IPOVAL 183 : SEGACT MELEME,MPOVAL 184 : * boucle sur les composantes 185 : DO 800 K=1,NC1 186 : KK = ICOR2(K) 187 : LC = ICOR1(KK) 188 : * numero local de l'harmonique 189 : IHA = IHARNUM(NOHARM(LC)-NMIN+1) 190 : * boucle sur les points 191 : DO 700 L=1,NUM(/2) 192 : NBP = NUM(1,L) 193 : * remplissage ici 194 : VALCPR(NBP,KK,IHA) 195 : & =VPOCHA(L,LC) 196 : 700 CONTINUE 197 : 800 CONTINUE 198 : SEGDES MELEME,MPOVAL,MSOUPO 199 : 900 CONTINUE 200 : * 201 : * on passe au second champ point 202 : MCHPOI = ICHP(2) 203 : MLMOTS = ILMO(2) 204 : DO 1400 J=1,IPCHP(/1) 205 : MSOUPO = IPCHP(J) 206 : SEGACT MSOUPO 207 : * on établi la correspondance de composantes du 208 : * liste mots vers les nom de composantes de la sous zone 209 : NC = NOHARM(/1) 210 : NC1 = 0 211 : * 212 : ncomp1 = mots(/2) 213 : * 214 : DO 1100 K=1,NCOMP1 215 : ICOR1(K)=0 216 : DO 1000 L=1,NC 217 : * write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L) 218 : IF(MOTS(K).EQ.NOCOMP(L)) THEN 219 : * write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k 220 : ICOR1(K)=L 221 : * nbre de composante présente sur la sous zone 222 : NC1 = NC1 + 1 223 : ICOR2(NC1)=K 224 : GOTO 1100 225 : ENDIF 226 : 1000 CONTINUE 227 : 1100 CONTINUE 228 : 229 : * on remplit chaque point du meleme 230 : MELEME = IGEOC 231 : MPOVAL = IPOVAL 232 : SEGACT MELEME,MPOVAL 233 : * boucle sur les composantes 234 : DO 1300 K=1,NC1 235 : KK = ICOR2(K) 236 : LC = ICOR1(KK) 237 : * numero local de l'harmonique 238 : IHA = IHARNUM(NOHARM(LC)-NMIN+1) 239 : * boucle sur les points 240 : DO 1200 L=1,NUM(/2) 241 : NBP = NUM(1,L) 242 : * multiplication ou division ici 243 : IF (IEPS.EQ.1) THEN 244 : VALCPR(NBP,KK,IHA) 245 : & =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC) 246 : ELSE 247 : IF (IVCHPO) THEN 248 : VALCPR(NBP,KK,IHA) 249 : & =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA) 250 : ELSE 251 : VALCPR(NBP,KK,IHA) 252 : & =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC) 253 : ENDIF 254 : ENDIF 255 : 1200 CONTINUE 256 : 1300 CONTINUE 257 : SEGDES MELEME,MPOVAL 258 : 1400 CONTINUE 259 : SEGSUP ICOR1,ICOR2 260 : * 261 : * 262 : * impression de icpr 263 : * WRITE(6,*) 'PTS',XCOOR(/1)/(IDIM+1),'COMP',ncomp1,'Nhar',nhar 264 : * do 6003 i=1,XCOOR(/1)/(IDIM+1) 265 : * write(6,5001) i 266 : * do 6002 j=1,ncomp1 267 : * do 6001 k=1,nhar 268 : * write(6,5002) j,k,valcpr(i,j,k) 269 : * 6001 continue 270 : * 6002 continue 271 : * 6003 continue 272 : 273 : * 5001 format('Point numero',I4) 274 : * 5002 format('Composante',I2,'Harmonique',I2,'Valeur',G12.5) 275 : 276 : 277 : * 278 : * il faut maintenant creer le champ point résultat 279 : * on commence par 280 : MCHPOI=ICHP(2) 281 : MLMOTS=ILMO(2) 282 : * 283 : * muchp2 determine le nombre de sous zone de notre chpoint 284 : * 285 : * write(6,*) 'Appel à muchp2' 285 : CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNUM,NMIN) 286 : * en sortie de mcuchp2 les segment sont actifs 287 : * 288 : * création du nouveau champ par point 289 : * 290 : * nini = jchaco(/2) 291 : * write(6,*)'tableau jchaco 1: kcomp 2:khar 3:nbre pts 4:nb comp' 292 : * do 6005 i=1,nini 293 : * write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i) 294 : * 6005 continue 295 : * 5003 format(' ',4(I5,2X)) 296 : * 297 : * nini = kchaco(/1) 298 : * write(6,*)'tableau kchaco correspondace 1 -> 3' 299 : * write(6,5004) (kchaco(i),i=1,nini) 300 : * 5004 format(' ',6(I2,2X)) 301 : * 302 : * write(6,*) 'Tableau mcores - icor3' 303 : * nono = icor3(/1) 304 : * write(6,*) 'icor3(/1)=' ,nono 305 : * do 6004 i=1,nini 306 : * write(6,*) 'sous zone' , i 307 : * write(6,5005) (icor3(j,i),j=1,nono) 308 : * 6004 continue 309 : * 5005 format(10(I2,2X)) 310 : * 311 : * attentioninversion volontaire 312 : MCHPO1 = ICHP(2) 313 : MCHPO2 = ICHP(1) 314 : NSOUPO = JCHACO(/2) 315 : NAT = 1 316 : SEGINI MCHPO3 317 : NSOUP1 = NSOUPO 318 : NSOUPO= MCHPO1.IPCHP(/1) 319 : MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *' 320 : MCHPO3.MTYPOI = ' ' 321 : * nature du champoint 321 : CALL LIRMOT(MONATU,1,IVAL,0) 322 : IF ( IVAL .EQ.1 ) THEN 322 : CALL LIRMOT(MOTCLE,3,IVAL,1) 323 : IF ( IERR .NE. 0) RETURN 324 : MCHPO3.JATTRI(1) = IVAL 325 : ELSE 326 : NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1) 327 : IF ( NATRI .EQ. 0) THEN 328 : MCHPO3.JATTRI(1) = 0 329 : ELSE IF ( NATRI .EQ. 1) THEN 330 : MCHPO3.JATTRI(1) = 1 331 : ELSE IF ( NATRI .EQ. 2) THEN 332 : * la nature discrete domine 333 : MCHPO3.JATTRI(1) = 2 334 : ELSE 335 : MCHPO3.JATTRI(1) = 2 336 : ENDIF 337 : ENDIF 338 : MCHPO3.IFOPOI = IFOUR 339 : * 340 : * boucle sur les sous zones DE MCHPO3 341 : * 342 : DO 2200 I=1,NSOUP1 343 : NC = JCHACO(4,I) 344 : NBELEM=JCHACO(3,I) 345 : * cas ou la sous zone n'existe pas encore 346 : SEGINI MSOUP3 347 : MCHPO3.IPCHP(I)=MSOUP3 348 : NBNN = 1 349 : * on cherche la première sous zone correspondante 350 : DO 1500 J=I,NSOUPO 351 : IF (KCHACO(J).EQ.I) GOTO 1600 352 : 1500 CONTINUE 353 : * ici j est le numéro de la premièer sous zone de mchpo1 correspondante 354 : 1600 CONTINUE 355 : MSOUP1 = MCHPO1.IPCHP(J) 356 : SEGACT MSOUP1 357 : IPT1 = MSOUP1.IGEOC 358 : SEGACT IPT1 359 : IF (NBELEM.EQ.IPT1.NUM(/2)) THEN 360 : IPT3 = IPT1 361 : ELSE 362 : NBSOUS = 0 363 : NBREF = 0 364 : NBNN = 1 365 : SEGINI IPT3 366 : DO 1650 K=1,IPT1.NUM(/2) 367 : IPT3.NUM(1,K)=IPT1.NUM(1,K) 368 : 1650 CONTINUE 369 : ENDIF 370 : MSOUP3.IGEOC = IPT3 371 : NR3 = IPT1.NUM(/2) 372 : N = NBELEM 373 : SEGINI MPOVA3 374 : MSOUP3.IPOVAL= MPOVA3 375 : * 376 : * nom des composantes et harmoniques 377 : * 378 : IC = 0 379 : DO 1800 K=1,NCOMP1 380 : IF (ICOR3(K,J).NE.0) THEN 381 : IC = IC + 1 382 : MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K) 383 : MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J)) 384 : MSOUP3.NOCONS(IC) = MSOUP1.NOCONS(ICOR3(K,J)) 385 : * 386 : * 1 ier remplissage 387 : * 388 : DO 1700 L=1,IPT1.NUM(/2) 389 : NBP = IPT1.NUM(1,L) 390 : MPOVA3.VPOCHA(L,IC)= 391 : & VALCPR(NBP,K,IHARNUM(MSOUP3.NOHARM(IC)-NMIN+1)) 392 : 1700 CONTINUE 393 : ENDIF 394 : 1800 CONTINUE 395 : SEGDES MSOUP1,IPT1 396 : * 397 : * remplissage suivant 398 : * 399 : * write(6,*) 'nr3=',nr3,'nbelem=',nbelem 400 : IF (NR3 .NE. NBELEM) THEN 401 : * write(6,*) 'Compactage de la sous zone' 402 : * on cherche la prochaine sous zone correspondante 403 : DO 2100 K=J+1,NSOUPO 404 : IF (KCHACO(K).EQ.I) THEN 405 : * k est le numéro de la sous zone de mchpo1 406 : MSOUP1 = MCHPO1.IPCHP(K) 407 : SEGACT MSOUP1 408 : IPT1 = MSOUP1.IGEOC 409 : SEGACT IPT1 410 : IC = 0 411 : DO 2000 L=1,NCOMP1 412 : IF (ICOR3(L,K).NE.0) THEN 413 : IC = IC + 1 414 : DO 1900 M=1,IPT1.NUM(/2) 415 : NBP = IPT1.NUM(1,M) 416 : IPT3.NUM(1,NR3+M) = NBP 417 : MPOVA3.VPOCHA(NR3+M,IC)= 418 : & VALCPR(NBP,L,IHARNUM(MSOUP3.NOHARM(IC)-NMIN+1)) 419 : 1900 CONTINUE 420 : 421 : ENDIF 422 : 2000 CONTINUE 423 : NR3 = NR3 + IPT1.NUM(/2) 424 : SEGDES MSOUP1,IPT1 425 : ENDIF 426 : 2100 CONTINUE 427 : IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN 428 : * write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic 429 : WRITE(6,*) 'erreur dans muchpo1.eso' 429 : CALL ERREUR(5) 430 : ENDIF 431 : * on ferme la sous zone du nouveau chpoint 432 : 433 : ENDIF 434 : SEGDES IPT3,MPOVA3,MSOUP3 435 : 2200 CONTINUE 436 : SEGDES MCHPO2,MCHPO1,MCHPO3 437 : * on détruit les temporaires 438 : SEGSUP ICPR,IHARNUM,NUMHAR,JCHACO,KCHACO,MCORES 439 : SEGDES ,MLMOT1,MLMOT2,MLMOT3 440 : IRET = MCHPO3 441 : RETURN 442 : END 443 : 444 : 445 : 446 : 447 :
© Cast3M 2003 - All rights reserved.
Disclaimer