Télécharger impos6.eso

Retour à la liste

Numérotation des lignes :

  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.  
  240.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales