C FUSCHL SOURCE PV090527 25/01/07 14:42:39 12115 SUBROUTINE FUSCHL(MCHEL1,MCHEL2,IRECHE) IMPLICIT REAL*8 (A-H,O-Z) ************************************************************************ * * F U S C H L * ----------- * * FONCTION: * --------- * REUNION DE DEUX OBJETS DE TYPE "CHAMELEM". * * MODULES UTILISES: * ----------------- * IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMCHAML -INC SMCOORD * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) * ----------- * * MCHEL1 (E) POINTEUR SUR LE PREMIER "CHAMELEM" * MCHEL2 (E) POINTEUR SUR LE DEUXIEME "CHAMELEM" * IRECHE (S) POINTEUR SUR LE "CHAMELEM" RESULTAT * ( =0 SI ECHEC ) * * VARIABLES: * ---------- * * SOUTYP = SOUS-TYPE DU "CHAMELEM" RESULTAT. * LSOUTY = LONGUEUR UTILE DE LA CHAINE "SOUTYP" segment traa integer ncompi(ncomp),n2r(n1) endsegment CHARACTER*8 NOP,CHA8 CHARACTER*(LOCOMP) CHACa,CHACb CHARACTER*16 CHA16a,CHA16b CHARACTER*(NCONCH) CONCHa,CONCHb INTEGER LSOUTY CHARACTER*72 SOUTYP,SOUTYPb * * REMARQUES: * ---------- * * * - DANS LE CAS DE LA REUNION DE 2 "CHAMELEM" DE SOUS-TYPES * DIFFERENTS, LE SOUS-TYPE DU RESULTAT EST: * . LE SOUS-TYPE DE L'UN SI LE SOUS-TYPE DE L'AUTRE EST ' ' * . ' ' DANS LES AUTRES CAS. * * - DANS LE CAS OU UNE COMPOSANTE EST COMMUNE SUR UNE ZONE * ELEMENTAIRE COMMUNE, ON verifie QUE SES VALEURS SONT LES MEMES * DANS LES DEUX "CHAMELEM" INITIAUX (nature diffuse par defaut) * * AUTEUR, DATE DE CREATION: * ------------------------- * * DENIS ROBERT, LE 21 DECEMBRE 1987. - MODIF BRUN.J (MAI 90) * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * * SOUS-TYPES DE NOS "CHAMELEM" * ireche=0 SEGACT,MCHEL1 SEGACT,MCHEL2 * SOUTYP = MCHEL1.TITCHE LSOUTY = MCHEL1.TITCHE(/1) * CHA8 = SOUTYP(1:8) IF (CHA8 .EQ. ' ') THEN CHA8 = MCHEL2.TITCHE(1:8) IF ( CHA8 .NE. ' ') THEN SOUTYP = MCHEL2.TITCHE LSOUTY = MCHEL2.TITCHE(/1) ENDIF ELSE SOUTYPb=MCHEL2.TITCHE IF (SOUTYPb .NE. SOUTYP) THEN CHA8=MCHEL2.TITCHE(1:8) IF (CHA8 .NE. ' ') THEN SOUTYP=' ' LSOUTY=1 ENDIF ENDIF ENDIF * LSOUTY = MAX(LSOUTY,1) * * NOMBRE DE ZONES DE CHAQUE "CHAMELEM" * NSOU1=MCHEL1.IMACHE(/1) NSOU2=MCHEL2.IMACHE(/1) N31 =MCHEL1.INFCHE(/2) N32 =MCHEL2.INFCHE(/2) *+* N33=MIN(N31,N32) N3=MAX(N31,N32) * on active tout ncomp=0 DO 5 ISOUS=1,NSOU1 MCHAML=MCHEL1.ICHAML(ISOUS) SEGACT,MCHAML ncomp=max(ncomp,ielval(/1)) 5 CONTINUE DO 6 ISOUS=1,NSOU2 MCHAML=MCHEL2.ICHAML(ISOUS) SEGACT,MCHAML ncomp=max(ncomp,ielval(/1)) 6 continue * on cree le résultat n1=nsou1+nsou2 segini traa itrf=1 l1=lsouty segini mchelm titche=soutyp ifoche=ifour * JCARDO 13/03/2012 : gestion du cas où au moins un des MCHAML est vide if (n1.eq.0) goto 66 if (nsou1.eq.0) then mchel3=mchel2 n33=n32 else mchel3=mchel1 n33=n31 endif * on commence par recopier le premier sous champ conche(1)=mchel3.conche(1) imache(1)=mchel3.imache(1) mcham2=mchel3.ichaml(1) segini,mchaml=mcham2 ichaml(1)=mchaml n2r(1)=ielval(/1) do k=1,n33 infche(1,k)=mchel3.infche(1,k) enddo n1=1 * on reprend tous les autres sous champs et on se pose la question de * savoir si meme imache,meme nophas, meme conche, * si oui on additionnera directement dans le mchaml apres * avoir testé si meme nom de composante , meme support (infche(6) * meme typche , meme valeur ipas=0 7 continue if(ipas.eq.0) then mchel3=mchel1 nsous=nsou1 n33=n31 else mchel3=mchel2 nsous=nsou2 n33=n32 endif do 8 i=1,nsous if( i.eq.1.and.ipas.eq.0) go to 8 ima =mchel3.imache(i) inf3 =mchel3.infche(i,3) inf6 =mchel3.infche(i,6) nop =mchel3.conche(i)(17:24) CONCHa=mchel3.conche(i) mcham3=mchel3.ichaml(i) ncomp =mcham3.ielval(/1) if (itrf.eq.0) then do k=1,ncomp ncompi(k)=0 enddo endif itrf=0 do 9 j=1,n1 if( ima.ne.imache(j)) go to 9 CONCHb=conche(j) if( CONCHa .ne. CONCHb) go to 9 CHA8=conche(j)(17:24) if( nop .ne. CHA8) go to 9 * on en a trouvé une zone identique on continue par tester les noms * de composantes mchaml=ichaml(j) * write(6,*) ' prise de mchaml j ' , mchaml,j do 10 kold=1,mcham3.ielval(/1) CHACa =mcham3.nomche(kold) CHA16a=mcham3.typche(kold) do 11 knew=1,n2r(j) CHACb =nomche(knew) CHA16b=typche(knew) if(CHACa .eq. CHACb)then * on teste meme support if( inf6.ne.infche(j,6)) then call erreur(329) return endif * on teste meme typche if(CHA16a .ne. CHA16b) then moterr(1:4) = mcham3.nomche(kold) moterr(5:21) = CHA16a moterr(22:38) = CHA16b segdes mcham3, mchaml *le type %m5:21 et le type %m22:38 sont incompatibles pour la composante %m1:4 call erreur(917) return endif * on teste les valeurs * regarde les melval melva1 = mcham3.ielval(kold) melva2 = ielval(knew) segact melva1,melva2 if (CHA16a(1:8) .eq. 'REAL*8 ') then n1ptel = melva1.velche(/1) n1el = melva1.velche(/2) m1ptel = melva2.velche(/1) m1el = melva2.velche(/2) l11 = max(n1ptel,m1ptel) l2 = max(n1el,m1el) do jptel =1,l11 do jel =1,l2 x1 = melva1.velche(min(jptel,n1ptel),min(jel,n1el)) x2 = melva2.velche(min(jptel,m1ptel),min(jel,m1el)) if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then interr(1)=jptel interr(2)=jel moterr(1:4) = mcham3.nomche(kold) * composante %m1:4 : les valeurs ne sont pas identiques au point d integration * (%i1,%i2) segdes melva1, melva2 call erreur(918) return endif enddo enddo else * pointeurs n2ptel=melva1.ielche(/1) n2el=melva1.ielche(/2) m2ptel=melva2.ielche(/1) m2el=melva2.ielche(/2) l11 = max(n2ptel,m2ptel) l2 = max(n2el,m2el) do jptel =1,l11 do jel =1,l2 x1 = melva1.ielche(min(jptel,n2ptel),min(jel,n2el)) x2 = melva2.ielche(min(jptel,m2ptel),min(jel,m2el)) if(abs(x1-x2).gt.(abs(x1+x2))/2.*1.d-6) then interr(1)=jptel interr(2)=jel moterr(1:4) = mcham3.nomche(kold) segdes melva1, melva2 call erreur(918) return endif enddo enddo endif segdes melva1,melva2 ncompi(kold)=1 * tout est bon : meme support , meme typche, meme valeurs--> rien à faire go to 10 endif 11 continue * ici lon n'a pas trouvé de composantes identiques on regarde si * meme infche(6, si oui on agrandi mchaml pour ajouter la composante * sinon on continue pour tester les autres parties du nouveau champ if(inf6.eq.infche(j,6)) then * write(6,*) ' on passe ici mchaml ', mchaml n2r(j)=n2r(j)+1 if (n2r(j).gt.ielval(/1)) then n2=n2r(j)+10 segadj mchaml endif n2=n2r(j) * write(6,*) ' succés' nomche(n2)=mcham3.nomche(kold) ielval(n2)=mcham3.ielval(kold) typche(n2)=mcham3.typche(kold) ncompi(kold)=1 go to 10 endif 10 continue 9 continue * on a fini de regarder le nouveau champ et on a rangé là ou on pouvait * certaines composantes. on compte combien il y a encore de * composantes à ranger n2=0 do k=1,ncomp if( ncompi(k).eq.0) then n2=n2+1 endif enddo if(n2.ne.0) then n1=n1+1 imache(n1)=ima conche(n1)=CONCHa conche(n1)(17:24)=nop do m=1,n33 infche(n1,m)=mchel3.infche(i,m) enddo segini mchaml ichaml(n1)=mchaml n2r(n1)=n2 ik=0 do k=1,ncomp if(ncompi(k).eq.0) then ik=ik+1 nomche(ik)=mcham3.nomche(k) ielval(ik)=mcham3.ielval(k) typche(ik)=mcham3.typche(k) endif enddo endif 8 continue ipas=ipas+1 if(ipas.le.1) go to 7 * * on a fini * if(n1.ne.imache(/1)) segadj mchelm * call zpchel(mchelm,1) do i=1,ichaml(/1) mchaml=ichaml(i) n2=n2r(i) if (n2.ne.ielval(/1)) segadj mchaml do iup=1,n2 melva1=ielval(iup) segact,melva1*NOMOD enddo segact,mchaml*NOMOD enddo 66 segsup traa segact,mchelm*NOMOD ireche=mchelm * write(6,*) ' resultat de fuschl mchelm' , ireche end