1 : C FUSCHL SOURCE JC220346 12/03/13 21:15:06 7306 2 : SUBROUTINE FUSCHL(MCHEL1,MCHEL2,IRECHE) 3 : IMPLICIT REAL*8 (A-H,O-Z) 4 : ************************************************************************ 5 : * 6 : * F U S C H L 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * REUNION DE DEUX OBJETS DE TYPE "CHAMELEM". 12 : * 13 : * MODULES UTILISES: 14 : * ----------------- 15 : * 16 : IMPLICIT INTEGER(I-N) 17 : -INC CCOPTIO 18 : -INC SMCHAML 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 21 : * ----------- 22 : * 23 : * MCHEL1 (E) POINTEUR SUR LE PREMIER "CHAMELEM" 24 : * MCHEL2 (E) POINTEUR SUR LE DEUXIEME "CHAMELEM" 25 : * IRECHE (S) POINTEUR SUR LE "CHAMELEM" RESULTAT 26 : * ( =0 SI ECHEC ) 27 : * 28 : * VARIABLES: 29 : * ---------- 30 : * 31 : * SOUTYP = SOUS-TYPE DU "CHAMELEM" RESULTAT. 32 : * LSOUTY = LONGUEUR UTILE DE LA CHAINE "SOUTYP" 33 : 34 : segment traa 35 : integer ncompi(ncomp),n2r(n1) 36 : endsegment 37 : CHARACTER*8 NOP 38 : CHARACTER*16 CON 39 : INTEGER LSOUTY 40 : CHARACTER*72 SOUTYP 41 : * 42 : * REMARQUES: 43 : * ---------- 44 : * 45 : * 46 : * - DANS LE CAS DE LA REUNION DE 2 "CHAMELEM" DE SOUS-TYPES 47 : * DIFFERENTS, LE SOUS-TYPE DU RESULTAT EST: 48 : * . LE SOUS-TYPE DE L'UN SI LE SOUS-TYPE DE L'AUTRE EST ' ' 49 : * . ' ' DANS LES AUTRES CAS. 50 : * 51 : * - DANS LE CAS OU UNE COMPOSANTE EST COMMUNE SUR UNE ZONE 52 : * ELEMENTAIRE COMMUNE, ON verifie QUE SES VALEURS SONT LES MEMES 53 : * DANS LES DEUX "CHAMELEM" INITIAUX (nature diffuse par defaut) 54 : * 55 : * AUTEUR, DATE DE CREATION: 56 : * ------------------------- 57 : * 58 : * DENIS ROBERT, LE 21 DECEMBRE 1987. - MODIF BRUN.J (MAI 90) 59 : * 60 : * LANGAGE: 61 : * -------- 62 : * 63 : * ESOPE + FORTRAN77 64 : * 65 : ************************************************************************ 66 : * 67 : * SOUS-TYPES DE NOS "CHAMELEM" 68 : * 69 : ireche=0 70 : SEGACT,MCHEL1 71 : SEGACT,MCHEL2 72 : * 73 : SOUTYP = MCHEL1.TITCHE 74 : LSOUTY = MCHEL1.TITCHE(/1) 75 : * 76 : IF (SOUTYP .EQ. ' ') THEN 77 : IF (MCHEL2.TITCHE .NE. ' ') THEN 78 : SOUTYP = MCHEL2.TITCHE 79 : LSOUTY = MCHEL2.TITCHE(/1) 80 : ENDIF 81 : ELSE 82 : IF (MCHEL2.TITCHE .NE. SOUTYP) THEN 83 : IF (MCHEL2.TITCHE .NE. ' ') THEN 84 : SOUTYP=' ' 85 : LSOUTY=1 86 : ENDIF 87 : ENDIF 88 : 89 : ENDIF 90 : * 91 : LSOUTY = MAX(LSOUTY,1) 92 : * 93 : * NOMBRE DE ZONES DE CHAQUE "CHAMELEM" 94 : * 95 : NSOU1=MCHEL1.IMACHE(/1) 96 : NSOU2=MCHEL2.IMACHE(/1) 97 : N31=MCHEL1.INFCHE(/2) 98 : N32=MCHEL2.INFCHE(/2) 99 : 100 : *+* 101 : N33=MIN(N31,N32) 102 : N3=MAX(N31,N32) 103 : * on active tout 104 : ncomp=0 105 : DO 5 ISOUS=1,NSOU1 106 : MCHAML=MCHEL1.ICHAML(ISOUS) 107 : SEGACT,MCHAML 108 : ncomp=max(ncomp,ielval(/1)) 109 : 5 CONTINUE 110 : DO 6 ISOUS=1,NSOU2 111 : MCHAML=MCHEL2.ICHAML(ISOUS) 112 : SEGACT,MCHAML 113 : ncomp=max(ncomp,ielval(/1)) 114 : 6 continue 115 : * on cree le résultat 116 : n1=nsou1+nsou2 117 : segini traa 118 : itrf=1 119 : l1=lsouty 120 : segini mchelm 121 : titche=soutyp 122 : ifoche=ifour 123 : 124 : * JCARDO 13/03/2012 : gestion du cas où au moins un des MCHAML est vide 125 : if (n1.eq.0) goto 66 126 : if (nsou1.eq.0) then 127 : mchel3=mchel2 128 : n33=n32 129 : else 130 : mchel3=mchel1 131 : n33=n31 132 : endif 133 : 134 : * on commence par recopier le premier sous champ 135 : conche(1)=mchel3.conche(1) 136 : imache(1)=mchel3.imache(1) 137 : mcham2=mchel3.ichaml(1) 138 : segini,mchaml=mcham2 139 : ichaml(1)=mchaml 140 : n2r(1)=ielval(/1) 141 : do k=1,n33 142 : infche(1,k)=mchel3.infche(1,k) 143 : enddo 144 : n1=1 145 : * on reprend tous les autres sous champs et on se pose la question de 146 : * savoir si meme imache,meme nophas, meme conche, 147 : * si oui on additionnera directement dans le mchaml apres 148 : * avoir testé si meme nom de composante , meme support (infche(6) 149 : * meme typche , meme valeur 150 : 151 : 152 : ipas=0 153 : 7 continue 154 : if(ipas.eq.0) then 155 : mchel3=mchel1 156 : nsous=nsou1 157 : n33=n31 158 : else 159 : mchel3=mchel2 160 : nsous=nsou2 161 : n33=n32 162 : endif 163 : do 8 i=1,nsous 164 : if( i.eq.1.and.ipas.eq.0) go to 8 165 : ima=mchel3.imache(i) 166 : inf3=mchel3.infche(i,3) 167 : inf6=mchel3.infche(i,6) 168 : nop=mchel3.conche(i)(17:24) 169 : con=mchel3.conche(i) 170 : mcham3=mchel3.ichaml(i) 171 : ncomp=mcham3.ielval(/1) 172 : if (itrf.eq.0) then 173 : do k=1,ncomp 174 : ncompi(k)=0 175 : enddo 176 : endif 177 : itrf=0 178 : do 9 j=1,n1 179 : if( ima.ne.imache(j)) go to 9 180 : if( con.ne.conche(j)) go to 9 181 : if( nop.ne.conche(j)(17:24)) go to 9 182 : 183 : * on en a trouvé une zone identique on continue par tester les noms 184 : * de composantes 185 : mchaml=ichaml(j) 186 : * write(6,*) ' prise de mchaml j ' , mchaml,j 187 : do 10 kold=1,mcham3.ielval(/1) 188 : do 11 knew=1,n2r(j) 189 : if(mcham3.nomche(kold).eq.nomche(knew))then 190 : * on teste meme support 191 : if( inf6.ne.infche(j,6)) then 192 : moterr(1:4)=nomche(knew) 192 : call erreur(1010) 193 : return 194 : endif 195 : * on teste meme typche 196 : if(mcham3.typche(kold).ne.typche(knew)) then 197 : moterr(1:4) = mcham3.nomche(kold) 198 : moterr(5:21) = mcham3.typche(kold) 199 : moterr(22:38) = typche(knew) 200 : segdes mcham3, mchaml 201 : *le type %m5:21 et le type %m22:38 sont incompatibles pour la composante %m1:4 201 : call erreur(917) 202 : return 203 : endif 204 : * on teste les valeurs 205 : * regarde les melval 206 : melva1 = mcham3.ielval(kold) 207 : melva2 = ielval(knew) 208 : segact melva1,melva2 209 : if (mcham3.typche(kold).eq.'REAL*8') then 210 : n1ptel = melva1.velche(/1) 211 : n1el = melva1.velche(/2) 212 : m1ptel = melva2.velche(/1) 213 : m1el = melva2.velche(/2) 214 : l11 = max(n1ptel,m1ptel) 215 : l2 = max(n1el,m1el) 216 : do jptel =1,l11 217 : do jel =1,l2 218 : x1 = melva1.velche(min(jptel,n1ptel),min(jel,n1el)) 219 : x2 = melva2.velche(min(jptel,m1ptel),min(jel,m1el)) 220 : if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then 221 : interr(1)=jptel 222 : interr(2)=jel 223 : moterr(1:4) = mcham3.nomche(kold) 224 : * composante %m1:4 : les valeurs ne sont pas identiques au point d integration 225 : * (%i1,%i2) 226 : segdes melva1, melva2 226 : call erreur(918) 227 : return 228 : endif 229 : enddo 230 : enddo 231 : else 232 : * pointeurs 233 : n2ptel=melva1.ielche(/1) 234 : n2el=melva1.ielche(/2) 235 : m2ptel=melva2.ielche(/1) 236 : m2el=melva2.ielche(/2) 237 : l11 = max(n2ptel,m2ptel) 238 : l2 = max(n2el,m2el) 239 : do jptel =1,l11 240 : do jel =1,l2 241 : x1 = melva1.ielche(min(jptel,n2ptel),min(jel,n2el)) 242 : x2 = melva2.ielche(min(jptel,m2ptel),min(jel,m2el)) 243 : if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then 244 : interr(1)=jptel 245 : interr(2)=jel 246 : moterr(1:4) = mcham3.nomche(kold) 247 : segdes melva1, melva2 247 : call erreur(918) 248 : return 249 : endif 250 : enddo 251 : enddo 252 : endif 253 : segdes melva1,melva2 254 : ncompi(kold)=1 255 : * tout est bon : meme support , meme typche, meme valeurs--> rien à faire 256 : go to 10 257 : endif 258 : 11 continue 259 : * ici lon n'a pas trouvé de composantes identiques on regarde si 260 : * meme infche(6, si oui on agrandi mchaml pour ajouterer la composante 261 : * sinon on continue pour tester les autres parties du nouveau champ 262 : if(inf6.eq.infche(j,6)) then 263 : * write(6,*) ' on passe ici mchaml ', mchaml 264 : n2r(j)=n2r(j)+1 265 : if (n2r(j).gt.ielval(/1)) then 266 : n2=n2r(j)+10 267 : segadj mchaml 268 : endif 269 : n2=n2r(j) 270 : * write(6,*) ' succés' 271 : nomche(n2)=mcham3.nomche(kold) 272 : ielval(n2)=mcham3.ielval(kold) 273 : typche(n2)=mcham3.typche(kold) 274 : ncompi(kold)=1 275 : go to 10 276 : endif 277 : 10 continue 278 : 9 continue 279 : * on a fini de regarder le nouveau champ et on a rangé là ou on pouvait 280 : * certaines composantes. on compte combien il y a encore de 281 : * composantes à ranger 282 : n2=0 283 : do k=1,ncomp 284 : if( ncompi(k).eq.0) then 285 : n2=n2+1 286 : endif 287 : enddo 288 : if(n2.ne.0) then 289 : n1=n1+1 290 : imache(n1)=ima 291 : conche(n1)=con 292 : conche(n1)(17:24)=nop 293 : do m=1,n33 294 : infche(n1,m)=mchel3.infche(i,m) 295 : enddo 296 : segini mchaml 297 : ichaml(n1)=mchaml 298 : n2r(n1)=n2 299 : ik=0 300 : do k=1,ncomp 301 : if(ncompi(k).eq.0) then 302 : ik=ik+1 303 : nomche(ik)=mcham3.nomche(k) 304 : ielval(ik)=mcham3.ielval(k) 305 : typche(ik)=mcham3.typche(k) 306 : endif 307 : enddo 308 : endif 309 : 8 continue 310 : ipas=ipas+1 311 : if(ipas.le.1) go to 7 312 : * 313 : * on a fini 314 : * 315 : DO ISOUS=1,NSOU1 316 : MCHAML=MCHEL1.ICHAML(ISOUS) 317 : * do iup=1,ielval(/1) 318 : * melva1=ielval(iup) 319 : * segdes melva1 320 : * enddo 321 : *pv SEGDES MCHAML 322 : ENDDO 323 : DO ISOUS=1,NSOU2 324 : MCHAML=MCHEL2.ICHAML(ISOUS) 325 : * do iup=1,ielval(/1) 326 : * melva1=ielval(iup) 327 : * segdes melva1 328 : * enddo 329 : *pv SEGDES,MCHAML 330 : ENDDO 331 : *pv segdes,mchel1,mchel2 332 : if(n1.ne.imache(/1)) segadj mchelm 332 : * call zpchel(mchelm,1) 333 : do i=1,ichaml(/1) 334 : mchaml=ichaml(i) 335 : n2=n2r(i) 336 : if (n2.ne.ielval(/1)) segadj mchaml 337 : * do iup=1,ielval(/1) 338 : * melva1=ielval(iup) 339 : * segdes melva1 340 : * enddo 341 : segdes mchaml 342 : enddo 343 : 66 segsup traa 344 : segdes mchelm 345 : 346 : ireche=mchelm 347 : * write(6,*) ' resultat de fuschl mchelm' , ireche 348 : return 349 : end 350 : 351 : 352 : 353 :
© Cast3M 2003 - All rights reserved.
Disclaimer