C COMBL2 SOURCE PV 20/03/24 21:16:00 10554 SUBROUTINE COMBL2 C-------------------------------------------------------------------- C C TABL1 = COMB TABL2 FLOT1; C C FLOT1 : TOLERANCE C C Pierre Pegon/JRC Ispra (??96 et 12/98) C-------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C -INC PPARAM -INC CCOPTIO -INC SMTABLE -INC SMELEME -INC SMCOORD -INC CCNOYAU -INC CCASSIS C C2002 SEGMENT,BLOCOM C2002 INTEGER POINT(NPOINT) C2002 REAL*8 XX(NPOINT),YY(NPOINT),DD(NPOINT) C2002 INTEGER MAILL(MM1) C2002 ENDSEGMENT C SEGMENT BLOCOM INTEGER POINT(NPOINT) REAL*8 YCOOR(IDIM+1,NPOINT) INTEGER MAILL(MM1) ENDSEGMENT C CALL LIROBJ('TABLE',MTABLE,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRREE(XTOL,1,IRETOU) IF(IERR.NE.0) RETURN XTOL2=XTOL**2 C C VERIFICATION DE LA DIMENSION C IF (IDIM.NE.2)THEN WRITE(IOIMP,*)'GENJOI: on n"est pas en 2D' RETURN ENDIF C C VERIFICATIONS DIVERSES C - SOUS TYPE DE LA TABLE C - NATURE DES MAILLAGE DE LA TABLE (SIMPLE, POI1 OU SEG2) C ET CALCUL DU NOMBRE DE POINT C NPOINT=0 SEGACT, MTABLE MM=MLOTAB if(nbesc.ne.0) segact ipiloc DO IE1=1,MM IF (MTABTI(IE1).EQ.'MOT ')THEN C C ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU C JF=IPCHAR(MTABII(IE1)+1) ID=IPCHAR(MTABII(IE1)) IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN WRITE(IOIMP,*)'COMB: un indice de type mot est errone' GOTO 9999 ENDIF IF (MTABTV(IE1).NE.'MOT ')THEN WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre un MOT' GOTO 9999 ENDIF JF=IPCHAR(MTABIV(IE1)+1) ID=IPCHAR(MTABIV(IE1)) IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre LISTE_DE_BLOCS' GOTO 9999 ENDIF ELSEIF (MTABTI(IE1).EQ.'ENTIER ')THEN C C ON VERIFIE LE CONTENU DES INDICES ENTIERS C IF (MTABTV(IE1).NE.'MAILLAGE')THEN ENDIF MELEME=MTABIV(IE1) SEGACT,MELEME IF(LISOUS(/1).NE.0.OR.(ITYPEL.NE.1.AND.ITYPEL.NE.2))THEN WRITE(IOIMP,*)'COMB: un maillage est errone' SEGDES,MELEME GOTO 9999 ENDIF NPOINT=NPOINT+ICOLOR(/1) SEGDES,MELEME ELSE WRITE(IOIMP,*)'COMB: un type d"indice est errone' GOTO 9999 ENDIF ENDDO if(nbesc.ne.0) SEGDES,IPILOC C C ON CHARGE LE NUMERO DES POINTS ... C IPOINT=0 IMAILL=0 MM1=MM-1 SEGINI,BLOCOM DO IE1=1,MM IF (MTABTI(IE1).EQ.'ENTIER ')THEN IMAILL=IMAILL+1 MELEME=MTABIV(IE1) MAILL(IMAILL)=MELEME SEGACT,MELEME DO IE2=1,ICOLOR(/1) IPOINT=IPOINT+1 POINT(IPOINT)=NUM(1,IE2) ENDDO SEGDES,MELEME ENDIF ENDDO C C ... ON LES ORDONNE ... C CALL ORDO02(POINT,NPOINT,.TRUE.) C C ... ET ON VERIFIE QU'ILS SONT TOUS 2 A 2 DIFFERENT C IPOINT=POINT(1) DO IE1=2,NPOINT IPOIN1=POINT(IE1) IF(IPOIN1.EQ.IPOINT)THEN WRITE(IOIMP,*)'COMB: deux points sont identiques' GOTO 9998 ENDIF IPOINT=IPOIN1 ENDDO C C ON CHARGES LES COORDONNES ET LA DENSITE DE TOUS LES POINTS C DO IE1=1,NPOINT IREF=(POINT(IE1)-1)*(IDIM+1) C2002 XX(IE1)=XCOOR(IREF+1) C2002 YY(IE1)=XCOOR(IREF+2) C2002 DD(IE1)=XCOOR(IREF+3) DO IE2=1,IDIM+1 YCOOR(IE2,IE1)=XCOOR(IREF+IE2) ENDDO ENDDO C+2002 C C ON VERIFIE QUE LES POINTS EN VIS A VIS ONT LA MEME DENSITE C ET ON REND LES COORDONNES IDENTIQUES C IRETOU=0 CALL J3DISK(BLOCOM,XTOL,IRETOU) IF(IRETOU.NE.0)THEN WRITE(IOIMP,*)'COMBL2: Pbs de pt en vis-a-vis' GOTO 9998 ENDIF C SEGACT MCOORD*MOD DO IE1=1,NPOINT IREF=(POINT(IE1)-1)*(IDIM+1) DO IE2=1,IDIM+1 XCOOR(IREF+IE2)=YCOOR(IE2,IE1) ENDDO ENDDO C+2002 C C ON BOUCLE MAINTENANT SUR TOUS LES BLOCS ... C NBSOUS=0 DO IE1=1,MM1 MELEME=MAILL(IE1) SEGACT,MELEME NBNN=ITYPEL NBELEM=ICOLOR(/1) NBREF=LISREF(/1) C C ... ET SUR TOUS LEURS COTES C (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CH C IE2=0 1 IE2=IE2+1 IF(IE2.GT.NBELEM)GOTO 3 C DO 3 IE2=1,NBELEM IREF=(NUM(1,IE2)-1)*(IDIM+1) XX1=XCOOR(IREF+1) YY1=XCOOR(IREF+2) IF(IE2.EQ.NBELEM)THEN IREF=(NUM(1,1)-1)*(IDIM+1) ELSE IREF=(NUM(1,IE2+1)-1)*(IDIM+1) ENDIF XX2=XCOOR(IREF+1) YY2=XCOOR(IREF+2) D12=(XX1-XX2)**2+(YY1-YY2)**2 C C ON BOUCLE SUR TOUS LES POINTS ... C DO 2 IE3=1,NPOINT C2002 XXI=XX(IE3) C2002 YYI=YY(IE3) XXI=YCOOR(1,IE3) YYI=YCOOR(2,IE3) DI1=(XXI-XX1)**2+(YYI-YY1)**2 DI2=(XXI-XX2)**2+(YYI-YY2)**2 C C ... ON ELIMINE CEUX QUI SONT TROP LOIN ... C IF((DI1.GT.D12+XTOL2).OR.(DI2.GT.D12+XTOL2))GOTO 2 C C ... ON ELIMINE CEUX QUI SONT TROP PRES ... C IF((DI1.LT.XTOL2).OR.(DI2.LT.XTOL2))GOTO 2 C C ... CEUX QUI NE SONT PAS ENTRE ... C AAA=((XXI-XX1)*(XX2-XX1)+(YYI-YY1)*(YY2-YY1))/D12 IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2 C C ... ET CEUX QUI SONT TROP LOIN DU SEGMENT C BBB=((XXI-XX1)-AAA*(XX2-XX1))**2 > +((YYI-YY1)-AAA*(YY2-YY1))**2 IF(BBB.GT.XTOL2)GOTO 2 C C ON INCERE LES POINT RESTANT DANS LE MAILLAGE APRES DUPLICATION C EVENTUELLE ... C C PP 2001: On change un peu la filosophie: on incere le point du segm C le plus proche du point conside. Cela ne change rien si le C sont sans epaisseurs... C C segact mcoord*mod NBPTS=nbpts+1 SEGADJ MCOORD IREF=(NBPTS-1)*(IDIM+1) C PP20001 XCOOR(IREF+1)=XXI C PP20001 XCOOR(IREF+2)=YYI XCOOR(IREF+1)=XX1+AAA*(XX2-XX1) XCOOR(IREF+2)=YY1+AAA*(YY2-YY1) C PP20001 C 2002 XCOOR(IREF+3)=DD(IE3) XCOOR(IREF+3)=YCOOR(IDIM+1,IE3) IF(MELEME.EQ.MAILL(IE1))THEN IPT1=MELEME SEGINI,MELEME=IPT1 SEGDES,IPT1 ENDIF NBELEM=NBELEM+1 SEGADJ, MELEME ICOLOR(NBELEM)=ICOLOR(NBELEM-1) IF(ITYPEL.EQ.1)THEN IF(IE2.LT.NBELEM-1)THEN DO IE4=NBELEM,IE2+2,-1 NUM(1,IE4)=NUM(1,IE4-1) ENDDO ENDIF NUM(1,IE2+1)=NBPTS ELSE DO IE4=NBELEM,IE2+1,-1 NUM(1,IE4)=NUM(1,IE4-1) NUM(2,IE4)=NUM(2,IE4-1) ENDDO NUM(1,IE2+1)=NBPTS NUM(2,IE2)=NBPTS ENDIF C C ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE PO C IE2=IE2-1 GOTO 1 C C FIN BOUCLE POINT C 2 CONTINUE C C FIN BOUCLE COTE C GOTO 1 3 CONTINUE IF(MELEME.EQ.MAILL(IE1))THEN SEGDES,MELEME ELSE MAILL(IE1)=MELEME SEGDES,MELEME ENDIF C C FIN BOUCLE BLOC C ENDDO C C ON CREE ET ON REMPLIT LA TABLE DE SORTIE C IMAILL=0 MTAB1=MTABLE SEGINI,MTABLE=MTAB1 SEGDES,MTAB1 DO IE1=1,MM IF (MTABTI(IE1).EQ.'ENTIER ')THEN IMAILL=IMAILL+1 MTABIV(IE1)=MAILL(IMAILL) ENDIF ENDDO C C ON REND LA MAIN A GIBIANE C SEGSUP,BLOCOM SEGDES,MTABLE CALL ECROBJ('TABLE',MTABLE) C RETURN C C ERREURS C 9998 SEGSUP,BLOCOM 9999 SEGDES,MTABLE RETURN END