1 : C J3COTO SOURCE CHAT 05/01/13 00:46:10 5004 2 : SUBROUTINE J3COTO(WORK1,WORK2,TOL,IRET) 3 : C---------------------------------------------------- 4 : C RAPPORT ENTRE LE CONTOUR DE WORK1 AVEC CELUI DE WORK2 5 : C 6 : C CODE IST(1,I): 0 point non traite 7 : C 1 est sur le segment IST(2,I) 8 : C 2 est sur les segments IST(2,I) et IST(3,I) 9 : C -1 est a l'interieur 10 : C -2 est a l'exterieur 11 : C 12 : C PP 6/97 13 : C Pierre Pegon/JRC Ispra 14 : C---------------------------------------------------- 15 : C 16 : IMPLICIT INTEGER(I-N) 17 : IMPLICIT REAL*8(A-H,O-Z) 18 : -INC CCOPTIO 19 : SEGMENT WORK 20 : REAL*8 XYC(2,NPTO) 21 : INTEGER IST(3,NPTO) 22 : REAL*8 DENS(NPTO) 23 : INTEGER JUN 24 : ENDSEGMENT 25 : POINTEUR WORK1.WORK, WORK2.WORK 26 : C 27 : DIMENSION XY1(2),XY2(2),XY3(2),XY4(2),XY(2) 28 : C 29 : IRET=0 30 : C 31 : NPTO1=WORK1.XYC(/2) 31 : CALL J3ZERI(WORK1.IST,3,NPTO1) 32 : NPTO2=WORK2.XYC(/2) 32 : CALL J3ZERI(WORK2.IST,3,NPTO2) 33 : C 34 : C ON CHERCHE A SAVOIR SI LES POINTS DE XYC1 SONT CONFONDU 35 : C AVEC DES POINTS DE XYC2, OU SUR LES COTES DE XYC2, OU BIEN 36 : C DEDANS OU DEHORS DE XYC2 37 : C 38 : DO IE1=1,NPTO1 39 : DO IE2=1,2 40 : XY1(IE2)=WORK1.XYC(IE2,IE1) 41 : ENDDO 42 : C 43 : ICOD=0 44 : C 44 : CALL J3NOCO(XY1,WORK2.XYC,NPTO2,TOL,IE2) 45 : IF(IE2.NE.0)THEN 46 : ICOD=2 46 : CALL J3BOCO(WORK1,IE1,IE2,IRET) 47 : IE2=IE2-1+(1/IE2)*NPTO2 47 : CALL J3BOCO(WORK1,IE1,IE2,IRET) 48 : ENDIF 49 : C 50 : IF(ICOD.EQ.0)THEN 50 : CALL J3DESS(XY1,WORK2.XYC,NPTO2,TOL,IE2) 51 : IF(IE2.NE.0)THEN 52 : ICOD=1 52 : CALL J3BOCO(WORK1,IE1,IE2,IRET) 53 : ENDIF 54 : ENDIF 55 : C 56 : IF(ICOD.EQ.0)THEN 56 : CALL J3INEX(XY1,WORK2.XYC,NPTO2,TOL,ICOD,ISIGM,IRET) 57 : WORK1.IST(1,IE1)=ICOD 58 : ENDIF 59 : C 60 : IF(IRET.GT.0)THEN 61 : RETURN 62 : ENDIF 63 : ENDDO 64 : C 65 : C ON REGARDE MAINTENANT S'IL Y A DES POINTS DE XYC2 QUI SONT 66 : C SUR XYC1. IL FAUT AJOUTER CES POINTS 67 : C 68 : DO IE1=1,NPTO2 69 : DO IE2=1,2 70 : XY2(IE2)=WORK2.XYC(IE2,IE1) 71 : ENDDO 71 : CALL J3NOCO(XY2,WORK1.XYC,NPTO1,TOL,IE2) 72 : IF(IE2.EQ.0)THEN 72 : CALL J3DESS(XY2,WORK1.XYC,NPTO1,TOL,IE2) 73 : IF(IE2.NE.0)THEN 74 : NPTO1=NPTO1+1 75 : IE2=IE2+1 76 : DENS1=WORK2.DENS(IE1) 76 : CALL J3POIN(WORK1,NPTO1,IE2,XY2,DENS1) 76 : CALL J3BOCO(WORK1,IE2,IE1,IRET) 77 : I1=IE1-1+(1/IE1)*NPTO2 77 : CALL J3BOCO(WORK1,IE2, I1,IRET) 78 : ENDIF 79 : ENDIF 80 : ENDDO 81 : C 82 : C ON REGARDE MAINTENANT LES INTERSECTIONS DE XYC1 AVEC XYC2 83 : C ET ON AJOUTE LES POINTS D'INTERSECTION 84 : C 85 : IE1=0 86 : 1 IE1=IE1+1 87 : IF(IE1.GT.NPTO1)GOTO 3 88 : C 89 : I1=IE1 90 : I2=IE1+1-(IE1/NPTO1)*IE1 91 : C 92 : IB1=WORK1.IST(2,I1) 93 : IB2=WORK1.IST(3,I1) 94 : IB3=WORK1.IST(2,I2) 95 : IB4=WORK1.IST(3,I2) 96 : C 97 : DO IE2=1,2 98 : XY1(IE2)=WORK1.XYC(IE2,I1) 99 : XY2(IE2)=WORK1.XYC(IE2,I2) 100 : ENDDO 101 : C 102 : DO 2 IE2=1,NPTO2 103 : C 104 : C (ON ELIMINE LES COTES DE XYC2 DEJA COUPES PAR XYC1) 105 : C 106 : IB=MIN(ABS(IB1-IE2),ABS(IB2-IE2),ABS(IB3-IE2),ABS(IB4-IE2)) 107 : IF(IB.EQ.0)GOTO 2 108 : C 109 : I3=IE2 110 : I4=IE2+1-(IE2/NPTO2)*IE2 111 : DO IE3=1,2 112 : XY3(IE3)=WORK2.XYC(IE3,I3) 113 : XY4(IE3)=WORK2.XYC(IE3,I4) 114 : ENDDO 115 : C 115 : CALL J3SINT(XY1,XY2,XY3,XY4,TOL,XLAM,XGAM,XY) 116 : C 117 : IF((XLAM.GT.0.D0).AND.(XLAM.LT.1.D0).AND. 118 : > (XGAM.GT.0.D0).AND.(XGAM.LT.1.D0))THEN 119 : NPTO1=NPTO1+1 120 : DENS1=XLAM*WORK1.DENS(I2)+(1-XLAM)*WORK1.DENS(I1) 120 : CALL J3POIN(WORK1,NPTO1,IE1+1,XY,DENS1) 120 : CALL J3BOCO(WORK1,IE1+1,IE2,IRET) 121 : IE1=IE1-1 122 : GOTO 1 123 : ENDIF 124 : 2 CONTINUE 125 : C 126 : GOTO 1 127 : 3 CONTINUE 128 : IF(IRET.GT.0)RETURN 129 : C 130 : C ON CHERCHE A SAVOIR SI LES POINTS DE XYC2 SONT CONFONDU 131 : C AVEC DES POINTS DE XYC1, OU SUR LES COTES DE XYC1, OU BIEN 132 : C DEDANS OU DEHORS DE XYC1 133 : C 134 : DO IE1=1,NPTO2 135 : DO IE2=1,2 136 : XY2(IE2)=WORK2.XYC(IE2,IE1) 137 : ENDDO 138 : C 139 : ICOD=0 140 : C 140 : CALL J3NOCO(XY2,WORK1.XYC,NPTO1,TOL,IE2) 141 : IF(IE2.NE.0)THEN 142 : ICOD=2 142 : CALL J3BOCO(WORK2,IE1,IE2,IRET) 143 : IE2=IE2-1+(1/IE2)*NPTO1 143 : CALL J3BOCO(WORK2,IE1,IE2,IRET) 144 : ENDIF 145 : C 146 : IF(ICOD.EQ.0)THEN 146 : CALL J3DESS(XY2,WORK1.XYC,NPTO1,TOL,IE2) 147 : IF(IE2.NE.0)THEN 148 : ICOD=1 148 : CALL J3BOCO(WORK2,IE1,IE2,IRET) 149 : ENDIF 150 : ENDIF 151 : C 152 : IF(ICOD.EQ.0)THEN 152 : CALL J3INEX(XY2,WORK1.XYC,NPTO1,TOL,ICOD,ISIGM,IRET) 153 : WORK2.IST(1,IE1)=ICOD 154 : ENDIF 155 : C 156 : IF(IRET.GT.0)THEN 157 : RETURN 158 : ENDIF 159 : ENDDO 160 : C 161 : IF (IIMPI.EQ.1789)THEN 162 : WRITE(IOIMP,*)'J3COTO' 163 : NPTO1=WORK1.XYC(/2) 164 : WRITE(IOIMP,*)'WORK1: NUM,X,Y,IST1,IST2,IST3,DENS ',WORK1 165 : DO IE1=1,NPTO1 166 : WRITE(IOIMP,*)IE1,WORK1.XYC(1,IE1),WORK1.XYC(2,IE1), 167 : > WORK1.IST(1,IE1),WORK1.IST(2,IE1),WORK1.IST(3,IE1), 168 : > WORK1.DENS(IE1) 169 : ENDDO 170 : NPTO2=WORK2.XYC(/2) 171 : WRITE(IOIMP,*)'WORK2: NUM,X,Y,IST1,IST2,IST3,DENS ',WORK2 172 : DO IE1=1,NPTO2 173 : WRITE(IOIMP,*)IE1,WORK2.XYC(1,IE1),WORK2.XYC(2,IE1), 174 : > WORK2.IST(1,IE1),WORK2.IST(2,IE1),WORK2.IST(3,IE1), 175 : > WORK2.DENS(IE1) 176 : ENDDO 177 : ENDIF 178 : C 179 : RETURN 180 : END 181 : 182 :
© Cast3M 2003 - All rights reserved.
Disclaimer