1 : C IMPOS6 SOURCE CHAT 05/01/13 00:34:02 5004 2 : SUBROUTINE IMPOS6(IMCTC1,IMCTC2,ICODE) 3 : c 4 : c pour cavi 5 : c assemble deux mctc de cavi1 6 : c le resultat est mis dans imctc2 7 : c 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8 (A-H,O-Z) 10 : -INC SMCOORD 11 : -INC CCOPTIO 12 : SEGMENT MCTC 13 : INTEGER IPOT1(NNO1) 14 : INTEGER IPOT2(NNO2) 15 : ENDSEGMENT 16 : POINTEUR MCTC1.MCTC,MCTC2.MCTC,MCTC3.MCTC 17 : LOGICAL FLAG 18 : c 19 : c executable 20 : c 21 : MCTC1 = IMCTC1 22 : MCTC2 = IMCTC2 23 : IF ( ICODE .EQ. -1 ) THEN 24 : c les segments sont inversés entre les deux lignes de points on renverse mctc2 25 : NNO2 = MCTC2.IPOT1(/1) 26 : NNO1 = MCTC2.IPOT2(/1) 27 : SEGINI MCTC 28 : DO 100 I=1,NNO1 29 : IPOT1(I)=MCTC2.IPOT2(I) 30 : 100 CONTINUE 31 : DO 200 I=1,NNO2 32 : IPOT2(I)=MCTC2.IPOT1(I) 33 : 200 CONTINUE 34 : SEGSUP MCTC2 35 : MCTC2 = MCTC 36 : ENDIF 37 : c 38 : c nombre de points dans la premiere ligne du nouveau mctc 39 : c 40 : NNO1 = MCTC1.IPOT1(/1) + MCTC2.IPOT1(/1) 41 : DO 300 I=1,MCTC2.IPOT1(/1) 42 : DO 250 J=1,MCTC1.IPOT1(/1) 43 : IF ( MCTC2.IPOT1(I) .EQ. MCTC1.IPOT1(J)) THEN 44 : MCTC2.IPOT1(I) = -J 45 : NNO1 = NNO1 - 1 46 : GOTO 300 47 : ENDIF 48 : 250 CONTINUE 49 : 300 CONTINUE 50 : c 51 : c nombre de points de la deuxieme ligne du nouveau mctc 52 : c 53 : NNO2 = MCTC1.IPOT2(/1) + MCTC2.IPOT2(/1) 54 : DO 400 I=1,MCTC2.IPOT2(/1) 55 : DO 350 J=1,MCTC1.IPOT2(/1) 56 : IF ( MCTC2.IPOT2(I) .EQ. MCTC1.IPOT2(J)) THEN 57 : MCTC2.IPOT2(I) = -J 58 : NNO2 = NNO2 - 1 59 : GOTO 400 60 : ENDIF 61 : 350 CONTINUE 62 : 400 CONTINUE 63 : c initialisation du nouveau mctc3 avec nno1 et nno2 64 : SEGINI MCTC3 65 : c 66 : c introduction des points de mctc1 dans mctc3 67 : c 68 : DO 500 I=1,MCTC1.IPOT1(/1) 69 : MCTC3.IPOT1(I)=MCTC1.IPOT1(I) 70 : 500 CONTINUE 71 : DO 600 I=1,MCTC1.IPOT2(/1) 72 : MCTC3.IPOT2(I)=MCTC1.IPOT2(I) 73 : 600 CONTINUE 74 : c 75 : c introduction des points de mctc2 dans mctc3 76 : c on doit trier pour les mettre a la bonne place 77 : c 78 : c 1ere couche 79 : c 80 : INDI1 = MCTC1.IPOT1(/1) 81 : INDI2 = 1 82 : c indi1 est le niveau de remplissage de mctc3.ipot1 83 : c indi2 indique le point le plus en avant que l'on ait place 84 : DO 700 I=1,MCTC2.IPOT1(/1) 85 : IF (MCTC2.IPOT1(I) .GT. 0) THEN 86 : IM = MCTC2.IPOT1(I) 87 : DO 650 J=INDI2,INDI1-1 88 : c boucle sur les points deja mis dans mctc3 89 : c on cherche a placer le nouveau point au bon endroit 90 : IA = MCTC3.IPOT1(J) 91 : IB = MCTC3.IPOT1(J+1) 92 : XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1) 93 : YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2) 94 : XAM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1) 95 : YAM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2) 96 : PL1 = XAB*XAB + YAB*YAB 97 : PL2 = XAB*XAM + YAB*YAM 98 : PL3 = XAM*XAM + YAM*YAM 99 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 100 : IF ((PL2 .LE. 0.D0) .AND. ((PL3/PL1).LT. 4.)) THEN 101 : c le point ce trouve a gauche de A a une distance raisonnable 102 : DO 640 K=INDI1,J,-1 103 : MCTC3.IPOT1(K+1)=MCTC3.IPOT1(K) 104 : 640 CONTINUE 105 : INDI1 = INDI1 + 1 106 : * print *,'a gauche' 107 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 108 : MCTC3.IPOT1(J)=IM 109 : INDI2 = J 110 : GOTO 700 111 : ENDIF 112 : IF ((PL2 .GT.0.) .AND. ((PL3/PL1).LT. 1.)) THEN 113 : c le point ce trouve a gauche de B 114 : DO 645 K=INDI1,J+1,-1 115 : MCTC3.IPOT1(K+1)=MCTC3.IPOT1(K) 116 : 645 CONTINUE 117 : MCTC3.IPOT1(J+1)=IM 118 : * print *,'a droite' 119 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 120 : INDI2 = J+1 121 : INDI1 = INDI1 + 1 122 : GOTO 700 123 : ENDIF 124 : 650 CONTINUE 125 : c 126 : IF (INDI1 .EQ. 1) THEN 127 : c la ligne ne contient q'un seul point 128 : c on se base sur la deuxieme ligne 129 : IA = MCTC3.IPOT2(1) 130 : IB = MCTC3.IPOT2(2) 131 : IC = MCTC3.IPOT1(1) 132 : XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1) 133 : YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2) 134 : XCM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IC-1)*(IDIM+1)+1) 135 : YCM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IC-1)*(IDIM+1)+2) 136 : PL1 = XAB*XCM+YAB*YCM 137 : IF ( PL1 .GT. 0) THEN 138 : MCTC3.IPOT1(1)=IM 139 : * print *,'unique' 140 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 141 : MCTC3.IPOT1(2)=IC 142 : INDI1 = 2 143 : GOTO 700 144 : ENDIF 145 : ENDIF 146 : 147 : c le point se trouve a droite de tout 148 : INDI1 = INDI1 + 1 149 : MCTC3.IPOT1(INDI1)=IM 150 : * print *,'extreme' 151 : * print *,'im=',im 152 : INDI2 = INDI1 153 : ELSE 154 : INDI2 = -MCTC2.IPOT1(I) 155 : ENDIF 156 : 700 CONTINUE 157 : c 158 : c 2ieme couche 159 : c 160 : INDI1 = MCTC1.IPOT2(/1) 161 : INDI2 = 1 162 : c indi1 est le niveau de remplissage de mctc3.ipot2 163 : DO 800 I=1,MCTC2.IPOT2(/1) 164 : IF (MCTC2.IPOT2(I) .GT. 0) THEN 165 : IM = MCTC2.IPOT2(I) 166 : DO 750 J=INDI2,INDI1-1 167 : c boucle sur les points deja mis dans mctc3 168 : IA = MCTC3.IPOT2(J) 169 : IB = MCTC3.IPOT2(J+1) 170 : XAB = XCOOR((IB-1)*(IDIM+1)+1) - XCOOR((IA-1)*(IDIM+1)+1) 171 : YAB = XCOOR((IB-1)*(IDIM+1)+2) - XCOOR((IA-1)*(IDIM+1)+2) 172 : XAM = XCOOR((IM-1)*(IDIM+1)+1) - XCOOR((IA-1)*(IDIM+1)+1) 173 : YAM = XCOOR((IM-1)*(IDIM+1)+2) - XCOOR((IA-1)*(IDIM+1)+2) 174 : PL1 = XAB*XAB + YAB*YAB 175 : PL2 = XAB*XAM + YAB*YAM 176 : PL3 = XAM*XAM + YAM*YAM 177 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 178 : IF ((PL2 .LT. 0.D0) .AND. ((PL3/PL1) .LT. 4.)) THEN 179 : c le point ce trouve a gauche de A 180 : DO 740 K=INDI1,J,-1 181 : MCTC3.IPOT2(K+1)=MCTC3.IPOT2(K) 182 : 740 CONTINUE 183 : INDI1 = INDI1 + 1 184 : INDI2 = J 185 : MCTC3.IPOT2(J)=IM 186 : * print *,'a gauche' 187 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 188 : GOTO 800 189 : ENDIF 190 : IF ((PL2 .GE. 0.D0) .AND. ((PL3/PL1).LT. 1.)) THEN 191 : c le point ce trouve a gauche de B 192 : DO 745 K=INDI1,J+1,-1 193 : MCTC3.IPOT2(K+1)=MCTC3.IPOT2(K) 194 : 745 CONTINUE 195 : MCTC3.IPOT2(J+1)=IM 196 : * print *,'a droite' 197 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 198 : INDI2 = J+1 199 : INDI1 = INDI1 + 1 200 : GOTO 800 201 : ENDIF 202 : 750 CONTINUE 203 : IF (INDI1 .EQ. 1) THEN 204 : IA = MCTC3.IPOT1(1) 205 : IB = MCTC3.IPOT1(2) 206 : IC = MCTC3.IPOT2(1) 207 : XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1) 208 : YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2) 209 : XCM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IC-1)*(IDIM+1)+1) 210 : YCM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IC-1)*(IDIM+1)+2) 211 : PL1 = XAB*XCM+YAB*YCM 212 : IF ( PL1 .GT. 0) THEN 213 : MCTC3.IPOT2(1)=IM 214 : MCTC3.IPOT2(2)=IC 215 : * print *,'unique' 216 : * print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3 217 : INDI1 = 2 218 : GOTO 800 219 : ENDIF 220 : ENDIF 221 : c le point se trouve a droite de tout 222 : INDI1 = INDI1 + 1 223 : MCTC3.IPOT2(INDI1)=IM 224 : INDI2 = INDI1 225 : * print *,'extreme' 226 : * print *,'im=',im 227 : ELSE 228 : INDI2 = -MCTC2.IPOT2(I) 229 : ENDIF 230 : 800 CONTINUE 231 : c 232 : c 233 : c 234 : SEGSUP MCTC2 235 : IMCTC2 = MCTC3 236 : RETURN 237 : END 238 : 239 :
© Cast3M 2003 - All rights reserved.
Disclaimer