C DICHO3 SOURCE PV 22/04/19 16:18:01 11344 C NOUVELLE VERSION DE DICHO C CE SOUS-PROGRAMME SERT A RESOUDRE LES SEGMENTS EN PARTIE CACHES C ADAPTE A GIBI C 1995 TRAC option FACB et FASB P.PEGON JRC-ISPRA C C PP FACE avec trait blanc SUBROUTINE DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX,IVU,NTSEG, # NELEM,IICOL,IDEFCO,lblanc,LTSEG) C PP # NELEM,IICOL,IDEFCO) C C TABLEAUX: NTELCL ELEMENTS CLASSES PAR ZONE C NTSEG SEGMENTS DOUTEUX C NAUX TABLEAU DE TRAVAIL C KON TABLEAU DES ELEMENTS TOUCHANT UN NOEUD C+PP trait blanc IMPLICIT INTEGER(I-N) logical lblanc C+PP * SG 20160420 dans le coloriage des segments * icoul : couleur courante (non definie = -3) * kcoul : couleur voulue * le but est de n'appeler chcoul que si qqch va etre trace integer icoul,kcoul DIMENSION XTR(2),YTR(2),ZTR(2) REAL*8 A,B,C REAL*8 XKK,XNN,XRAP,DNOM,DNUM,U,XPAR REAL XMIN,XMAX,YMIN,YMAX SEGMENT NTSEG(0) SEGMENT /XPROJ/(X(3,1)) SEGMENT IVU(NUMNP) SEGMENT ICPR(0) SEGMENT /TRAV1/(NTELEM(NELEM)) SEGMENT /TRAV2/(NTELCL(NREL),NAUX(NREL),IJK(4*NBZONE+2*NDEC+10)) SEGMENT /TRAV3/(IKON(IVU(/1))) SEGMENT /TRAV4/(KON(ISUP,IVU(/1))) SEGMENT /TRAV5/(DSTEL(NREL),NHZ(NELZON+2)) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCREEL -INC SMELEME ZTR(1)=0 ZTR(2)=0 IF (NTSEG(/1).NE.0) GOTO 1 SEGSUP NTSEG RETURN C RIEN A FAIRE 1 A=30. * CALL LIRREE(A,0,IRETOU) GENANT EN FULLSCREEN SEGACT ICPR C ON REMPLIT NTELEM TABLEAU DE REGROUPEMENT DES ELEMENTS SEGINI TRAV1 NREL=0 IPT1=MELEME SEGACT MELEME DO 3001 IOB=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) SEGACT IPT1 ENDIF IF (LTEL(1,IPT1.ITYPEL).EQ.0) GOTO 3003 IPB=IOB*NELEM DO 3002 I=1,IPT1.NUM(/2) DO 3005 J=1,IPT1.NUM(/1) IF (IVU(ICPR(IPT1.NUM(J,I))).GT.0) GOTO 3006 3005 CONTINUE GOTO 3002 3006 CONTINUE NREL=NREL+1 NTELEM(NREL)=IPB+I 3002 CONTINUE 3003 CONTINUE 3001 CONTINUE * write(6,*) ' nrel ',nrel C NB MOYEN DE PTS PAR ZONE RAP=(YMAX-YMIN)/(XMAX-XMIN) NBZONE=REAL(NREL)/A+1 NDEC=SQRT(REAL(NBZONE)/RAP) ** write(6,*) 'nrel a nbzone ndec,rap',nrel,a,nbzone,ndec,rap IF (NDEC.EQ.0) NDEC=1 MDEC=NBZONE/NDEC IF (MDEC.EQ.0) MDEC=1 NBZONE=NDEC*MDEC IF (IIMPI.EQ.1) WRITE (IOIMP,9912) NBZONE 9912 FORMAT (' NOMBRE DE ZONES ',I6) XDIST=XMAX-XMIN YDIST=YMAX-YMIN XDEC=XDIST/NDEC*1.00001 YDEC=YDIST/MDEC*1.00001 NUMNP=IVU(/1) SMO=1E-5*XDIST*YDIST/NUMNP C REMPLISSAGE DE KON TABLEAU ELEM (DE NTELEM) TOUCHANT NOEUD SEGINI TRAV3 DO 5011 I=1,NREL IOB=(NTELEM(I)-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=NTELEM(I)-IOB*NELEM DO 5012 J=1,IPT1.NUM(/1) K=ICPR(IPT1.NUM(J,IEL)) IKON(K)=IKON(K)+1 5012 CONTINUE 5011 CONTINUE ISUP=0 DO 5013 I=1,IKON(/1) ISUP=MAX(ISUP,IKON(I)) 5013 CONTINUE SEGINI TRAV4 DO 5015 I=1,NREL IOB=(NTELEM(I)-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=NTELEM(I)-IOB*NELEM DO 5016 J=1,IPT1.NUM(/1) K=ICPR(IPT1.NUM(J,IEL)) KON(IKON(K),K)=NTELEM(I) IKON(K)=IKON(K)-1 5016 CONTINUE 5015 CONTINUE SEGSUP TRAV3 C REMPLISSAGE DE NAUX(I)=ZONE DE L'ELEMENT NTELEM(I) * write(6,*) 'nrel nbzone ndec',nrel,nbzone,ndec SEGINI TRAV2 DO 10 I=1,IJK(/1) 10 IJK(I)=0 DO 26 I=1,NREL IOB=(NTELEM(I)-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=NTELEM(I)-IOB*NELEM IDEC=0 IDEC2=0 IDEC3=0 INOEUD=ICPR(IPT1.NUM(1,IEL)) NAUXI=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+INT(real((X(2,INOEUD) # -YMIN)/YDEC))*NDEC DO 21 J=2,IPT1.NUM(/1) INOEUD=ICPR(IPT1.NUM(J,IEL)) IZONE=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+ # INT(real((X(2,INOEUD)-YMIN)/YDEC))*NDEC IF (NAUXI.EQ.IZONE) GOTO 21 IF (IDEC.EQ.0) IDEC=IZONE IF (IDEC.EQ.IZONE) GOTO 21 IF (IDEC2.EQ.0) IDEC2=IZONE IF (IDEC2.EQ.IZONE) GOTO 21 IF (IDEC3.EQ.0) IDEC3=IZONE IF (IDEC3.EQ.IZONE) GOTO 21 NAUXI=0 GOTO 20 21 CONTINUE IF (IDEC.EQ.0) GOTO 20 IDECC=NAUXI IF (IDEC2.NE.0) GOTO 30 IVALID=ABS(IDECC-IDEC) IF (IVALID.NE.1) GOTO 22 NAUXI=MIN(IDECC,IDEC)+NBZONE+1 GOTO 20 22 IF (IVALID.NE.NDEC) GOTO 23 NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC GOTO 20 23 IF (IVALID.NE.NDEC+1) GOTO 24 NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 GOTO 20 24 IF (IVALID.NE.NDEC-1) GOTO 25 NAUXI=MIN(IDECC,IDEC)-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 GOTO 20 25 NAUXI=0 GOTO 20 30 IF (IDEC3.NE.0) GOTO 33 I1=MIN(IDECC,IDEC,IDEC2) I3=MAX(IDECC,IDEC,IDEC2) I2=IDECC+IDEC+IDEC2-I1-I3 IAUX=I2-I1 IF (IAUX.EQ.1) GOTO 31 IF (IAUX.NE.NDEC) GOTO 32 IF (I3-I2.NE.1) GOTO 25 NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 GOTO 20 32 IF (IAUX.NE.NDEC-1) GOTO 25 IF (I3-I2.NE.1) GOTO 25 NAUXI=I1-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 GOTO 20 31 IF (I3-I2.NE.NDEC.AND.I3-I2.NE.NDEC-1) GOTO 25 NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 GOTO 20 33 I1=MIN(IDECC,IDEC,IDEC2,IDEC3) I4=MAX(IDECC,IDEC,IDEC2,IDEC3) IF (I4-I1.NE.NDEC+1) GOTO 25 IF (IDECC+IDEC+IDEC2+IDEC3.NE.2*(I1+I4)) GOTO 25 IF (IDECC*IDEC*IDEC2*IDEC3.NE.I1*(I1+1)*(I4-1)*I4) GOTO 25 NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 20 CONTINUE NAUX(I)=NAUXI 26 CONTINUE C LE TABLEAU NAUX EST REMPLI C ON REMPLIT LE TABLEAU DE POINTEUR IJK (+1) DO 50 I=1,NREL IJK(NAUX(I)+1)=IJK(NAUX(I)+1)+1 50 CONTINUE NELZON=IJK(1) DO 51 I=2,IJK(/1) NELZON=MAX(NELZON,IJK(I)) 51 IJK(I)=IJK(I)+IJK(I-1) C CLASSEMENT DES ELEMENTS DANS NTELCL DO 60 I=1,NREL IAD=IJK(NAUX(I)+1) NTELCL(IAD)=NTELEM(I) IJK(NAUX(I)+1)=IAD-1 60 CONTINUE C CLASSEMENT DES ELEMENTS DANS CHAQUE ZONE PAR LA DISTANCE IF (IIMPI.NE.0) WRITE (IOIMP,9914) NELZON 9914 FORMAT(' NOMBRE MAX D''ELEMENT PAR ZONE ',I6) SEGSUP TRAV1 SEGINI TRAV5 DO 71 IW=2,IJK(/1) IDEB=IJK(IW-1)+1 IFIN=IJK(IW) IF (IDEB.GT.IFIN) GOTO 71 IDIFF=IFIN-IDEB+1 * write(6,*) ' dicho3 ideb ifin ',ideb,ifin DO 72 I=IDEB,IFIN IREL=NTELCL(I) IOB=(IREL-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=IREL-IOB*NELEM C# DSTEL(I)=XGRAND DSTEL(I)=XSGRAN C ON CONSIDERE SEULEMENT LES SEGMENTS DONT AU MOINS UN POINT EST VU IDEP=LPT(IPT1.ITYPEL) IFIN1=LPT(IPT1.ITYPEL)+(LPL(IPT1.ITYPEL)-1)*2 IFIN2=IFIN1 IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN C Polygone IFIN1=IDEP+2*IPT1.NUM(/1)-2 IFIN2=IFIN1 -2 ENDIF DO 73 ISEG=IDEP,IFIN1,2 IF (ISEG.LE.IFIN2) THEN IP1=ICPR(IPT1.NUM(KSEGM(ISEG),IEL)) IP2=ICPR(IPT1.NUM(KSEGM(ISEG+1),IEL)) ELSE C Polygone IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL)) IP2=ICPR(IPT1.NUM(KSEGM(1),IEL)) ENDIF IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 73 DSTEL(I)=MIN(DSTEL(I),X(3,IP1),X(3,IP2)) 73 CONTINUE 72 CONTINUE NHZ(1)=1 NHZ(2)=IFIN-IDEB+1 IZM=0 IZ=2 74 IZ=IZ-1 IF (IZ.LE.0) GOTO 75 IPB=NHZ(IZ*2-1) IPH=NHZ(IZ*2) IF (IPB.GE.IPH) GOTO 74 JPB=IPB-1 JPH=IPH+1 C CALCUL DU PIVOT RPV=(DSTEL(IPB+IDEB-1)+DSTEL(IPH+IDEB-1))/2. 77 JPB=JPB+1 IF (JPH.EQ.JPB) GOTO 80 IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 78 GOTO 77 78 JPH=JPH-1 IF (JPH.EQ.JPB) GOTO 80 IF (DSTEL(JPH+IDEB-1).LE.RPV) GOTO 79 GOTO 78 79 IAUX=NTELCL(JPH+IDEB-1) RAUX=DSTEL(JPH+IDEB-1) NTELCL(JPH+IDEB-1)=NTELCL(JPB+IDEB-1) DSTEL(JPH+IDEB-1)=DSTEL(JPB+IDEB-1) NTELCL(JPB+IDEB-1)=IAUX DSTEL(JPB+IDEB-1)=RAUX GOTO 77 C JPH=JPB MAIS ATTENTION PEUT ETRE A L'EXTERIEUR 80 IF (JPB.GE.IPB) GOTO 81 JPB=JPB+1 JPH=JPH+2 GOTO 84 81 IF (JPH.LE.IPH) GOTO 82 JPB=JPB-2 JPH=JPH-1 GOTO 84 82 IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 87 IF (JPH.EQ.IPH) GOTO 83 86 JPH=JPH+1 GOTO 84 87 IF (JPB.EQ.IPB) GOTO 86 83 JPB=JPB-1 84 IF (JPB.EQ.IPB) GOTO 85 NHZ(2*IZ)=JPB IZ=IZ+1 85 IF (JPH.EQ.IPH) GOTO 74 NHZ(2*IZ)=IPH NHZ(2*IZ-1)=JPH IZ=IZ+1 GOTO 74 75 CONTINUE 71 CONTINUE C C ON ABORDE MAINTENANT LA BOUCLE ON L'ON BALAYE LES SEGMENTS EN PARTIE C VUS. ICOLE=0 C EN FAIT IL Y A NBCOUL+1 COULEUR (+ EFFACEMENT) icoul=-3 DO 99 ICOLE=0,NBCOUL+1 C PP kcoul=ICOLE C+PP trait blanc IF (lblanc) THEN kcoul=0 ELSE kcoul=ICOLE ENDIF C+PP DO 100 L=1,LTSEG,3 IPVU=NTSEG(L) IPCA=NTSEG(L+1) IF (IDEFCO.EQ.1.AND.IICOL.NE.NTSEG(L+2)) GOTO 100 IF (ICOLE.NE.NTSEG(L+2)) GOTO 100 IREL=-IVU(IPCA) IOB=(IREL-1)/NELEM IF (LISOUS(/1).NE.0) THEN if (iob.eq.0) goto 100 IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=IREL-IOB*NELEM COXCA=X(1,IPCA) COYCA=X(2,IPCA) COZCA=X(3,IPCA) COXVU=X(1,IPVU) COYVU=X(2,IPVU) COZVU=X(3,IPVU) PARAM=0.9995 JAC=1 IOPT=0 * write (6,*) ' 1 iob,ipt1 ',iob,ipt1 150 CONTINUE LA=0 ISA=0 GOTO 2600 2602 CONTINUE IF (ISA.EQ.0) GOTO 151 C ON VA BOUCLER POUR ETUDIER LES ELEMENTS QUI TOUCHENT LE C SEGMENT ISA ISB C ON UTILISE LE TABLEAU KON DES ELEM QUI CONTIENNENT UN POINT IOPT=0 * DO 2500 LA=1,ISUP PROBLEME ON RENTRE DANS LA BOUCLE EN 2600 LA=1 25000 CONTINUE LAL=KON(LA,ISA) IF (LAL.EQ.0) GOTO 2501 IF (LAL.EQ.IREL) GOTO 2500 * DO 2502 LB=1,ISUP PROBLEME ON RENTRE DANS LA BOUCLE EN 2600 LB=1 25020 CONTINUE LBL=KON(LB,ISB) IF (LBL.EQ.0) GOTO 2503 IF (LAL.NE.LBL) GOTO 2502 IF (LBL.EQ.IREL) GOTO 2502 IREL=LAL IOB=(IREL-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF IEL=IREL-IOB*NELEM * write (6,*) ' 2 iob,ipt1 ',iob,ipt1 2600 CONTINUE * write (6,*) ' itypel ',ipt1.itypel IDEP=LPT(IPT1.ITYPEL) IFIN=IDEP+(LPL(IPT1.ITYPEL)-1)*2 IFIN2=IFIN IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN C Polygone IFIN=IDEP+2*IPT1.NUM(/1)-2 IFIN2=IFIN -2 ENDIF JIC=0 JOC=0 DO 101 I=IDEP,IFIN,2 IF (I.LE.IFIN2) THEN IP1=ICPR(IPT1.NUM(KSEGM(I),IEL)) IP2=ICPR(IPT1.NUM(KSEGM(I+1),IEL)) ELSE C Polygone IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL)) IP2=ICPR(IPT1.NUM(KSEGM(1),IEL)) ENDIF IF (IP1.EQ.IPVU) GOTO 2005 IF (IP2.EQ.IPVU) GOTO 2008 IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 101 XIP1=X(1,IP1) YIP1=X(2,IP1) XIP2=X(1,IP2) YIP2=X(2,IP2) C ON CALCULE LA COORDONNEE PARAMETRIQUE DU PT INTERSECTION DNOM=(COXCA-COXVU)*(YIP2-YIP1)-(COYCA-COYVU)*(XIP2-XIP1) IF (DNOM.EQ.0.) GOTO 101 DNUM=(COYVU-YIP1)*(XIP2-COXVU)-(COYVU-YIP2)*(XIP1-COXVU) U=DNUM/DNOM FOX=COXVU+U*(COXCA-COXVU) FOY=COYVU+U*(COYCA-COYVU) IF ((FOX-XIP1)*(FOX-XIP2)+(FOY-YIP1)*(FOY-YIP2).GT.SMO) #GOTO 101 IF (U.LT.-5E-4.OR.U.GT.PARAM) GOTO 101 JAC=1 JIC=1 ISA=IP1 ISB=IP2 PARAM=U-5E-4 IF (PARAM.GT.1E-4) GOTO 101 GOTO 100 2005 IF (IP2.EQ.IPCA) GOTO 101 JOC=1 GOTO 101 2008 IF (IP1.EQ.IPCA) GOTO 101 JOC=1 C ON NE DESSINE RIEN ? 101 CONTINUE IF (JAC.LE.0) PARAM=PARAM-5E-3 IF (PARAM.LT.0.) GOTO 100 COX=COXVU+PARAM*(COXCA-COXVU) COY=COYVU+PARAM*(COYCA-COYVU) CDIST=COZVU+PARAM*(COZCA-COZVU) IF (JOC.NE.0) GOTO 100 IF (JIC.EQ.0) GOTO 2603 IF (JAC.EQ.-5) GOTO 2601 JAC=JAC-1 * TEST DES ELEMENTS CONTENANT LE SEGMENT GOTO 2602 2603 CONTINUE IF (LA.EQ.0) GOTO 2602 2502 CONTINUE LB=LB+1 IF (LB.LE.ISUP) GOTO 25020 2503 CONTINUE 2500 CONTINUE LA=LA+1 IF (LA.LE.ISUP) GOTO 25000 2501 CONTINUE * PLUS D'ELEMENT TESTABLE RECHERCHE FINALE C REGARDONS SI UN ELEMENT CACHE CE POINT C D'ABORD TROUVONS SA ZONE C ON BOUCLE SUR TOUS LES ELEMENTS 151 CONTINUE IF (IOPT.EQ.1) GOTO 100 KNN=INT(real((COX-XMIN)/XDEC))+1+INT(real((COY-YMIN)/YDEC)) $ *NDEC IOPT=1 DO 140 IBAL=1,10 GOTO (130,131,132,133,134,135,136,137,138,139),IBAL 130 KN=KNN GOTO 110 131 KN=KNN-1+NBZONE+1 GOTO 110 132 KN=KNN+(NBZONE)+1 GOTO 110 133 KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC) GOTO 110 134 KN=KNN+(NBZONE+1)+(NBZONE+NDEC) GOTO 110 135 KN=KNN+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) GOTO 110 136 KN=KNN-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) GOTO 110 137 KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) GOTO 110 138 KN=KNN-NDEC-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) GOTO 110 139 KN=0 GOTO 110 110 KPU=IJK(KN+1+1) KPV=IJK(KN+1)+1 IF (KPU.LT.KPV) GOTO 140 IELD=1 DO 112 KK=KPV,KPU IF (IELD.EQ.0) GOTO 140 IELD=0 IF (DSTEL(KK).GE.CDIST) GOTO 140 IREL=NTELCL(KK) IOB=(IREL-1)/NELEM IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) ELSE IPT1=MELEME ENDIF K=IREL-IOB*NELEM NBFAC=LTEL(1,IPT1.ITYPEL) IAD=LTEL(2,IPT1.ITYPEL)-1 IDEDAF=0 DO 116 IFAC=1,NBFAC ITYP=LDEL(1,IAD+IFAC) JAD=LDEL(2,IAD+IFAC)-1 IDEP=KDFAC(2,ITYP) IFEP=IDEP+3*(KDFAC(3,ITYP)-1) IDEDAN=0 DO 115 ITRIAN=IDEP,IFEP,3 IA=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN)),K)) IB=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+1)),K)) IC=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+2)),K)) ZA=X(3,IA) ZB=X(3,IB) ZC=X(3,IC) IF (ZA.LT.CDIST) GOTO 201 IF (ZB.LT.CDIST) GOTO 201 IF (ZC.LT.CDIST) GOTO 201 GOTO 123 201 IELD=1 IF (IVU(IA).EQ.1) GOTO 200 IF (IVU(IB).EQ.1) GOTO 200 IF (IVU(IC).EQ.1) GOTO 200 GOTO 123 200 IF (IA.EQ.IPVU) GOTO 202 IF (IB.EQ.IPVU) GOTO 202 IF (IC.EQ.IPVU) GOTO 202 GOTO 203 202 IF (IA.EQ.IPCA) GOTO 123 IF (IB.EQ.IPCA) GOTO 123 IF (IC.EQ.IPCA) GOTO 123 203 CONTINUE VAX=COX-X(1,IA) VAY=COY-X(2,IA) VBX=COX-X(1,IB) VBY=COY-X(2,IB) VCX=COX-X(1,IC) VCY=COY-X(2,IC) DC=VAX*VBY-VAY*VBX DA=VBX*VCY-VBY*VCX IF (DA*DC.LT.0.) GOTO 123 DB=VCX*VAY-VCY*VAX IF (DA*DB.LT.0.) GOTO 123 IF (DC*DB.LT.0.) GOTO 123 IF (ABS(DA).GT.SMO) GOTO 121 IF (ABS(DB).GT.SMO) GOTO 121 IF (ABS(DC).GT.SMO) GOTO 121 IF (VAX*VBX.LT.-SMO) GOTO 123 IF (VAX*VCX.LT.-SMO) GOTO 123 IF (VAY*VCY.LT.-SMO) GOTO 123 IF (VAY*VBY.LT.-SMO) GOTO 123 IF (VBX*VCX.LT.-SMO) GOTO 123 IF (VBY*VCY.LT.-SMO) GOTO 123 121 CONTINUE S=DA+DB+DC IF (S.EQ.0.) GOTO 123 DA=DA/S DB=DB/S DC=DC/S S=DA*ZA+DB*ZB+DC*ZC IF (S.GT.CDIST) GOTO 123 IDEDAN=IDEDAN+1 123 CONTINUE 115 CONTINUE idedaf = idedaf + mod(idedan,2) 116 CONTINUE IF (IDEDAf.ne.0) THEN C ON EST CACHE PAR L'ELEMENT K IF (IIMPI.NE.0) WRITE (IOIMP,9923) K 9923 FORMAT(' LIGNE CACHE PAR ',I6) IEL=K GOTO 150 ENDIF 112 CONTINUE 140 CONTINUE C ON EST DESORMAIS VU. LE TRAIT S'ARRETE DONC LA 2601 CONTINUE *SG 20160420 if (kcoul.ne.icoul) then call chcoul(kcoul) icoul=kcoul endif XTR(1)=X(1,IPVU) YTR(1)=X(2,IPVU) XTR(2)=COX YTR(2)=COY CALL POLRL(2,XTR,YTR,ZTR) 100 CONTINUE 99 CONTINUE SEGSUP TRAV5,TRAV2,NTSEG,TRAV4 END