Télécharger prcoap.eso

Retour à la liste

Numérotation des lignes :

  1. C PRCOAP SOURCE BP208322 16/11/18 21:20:02 9177
  2. C CE SOUS PROGRAMME RETROUVE LE CONTOUR APPARENT (??) D'UN OBJET
  3. C IL EST DERIVE DE PRCONT
  4. C
  5. SUBROUTINE PRCOAP(IPT9,IPT2,ICPR,IVU,IRETNE)
  6. C
  7. IMPLICIT INTEGER(I-N)
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC SMELEME
  11. -INC SMCOORD
  12. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  13. SEGMENT IDCP(ITE)
  14. SEGMENT NTSEG(0)
  15. SEGMENT IVU(0)
  16. SEGMENT KON(NBCON,NMAX)
  17. C
  18. MELEME=IPT9
  19. IPT8=MELEME
  20. SEGACT MELEME
  21. ITE=IVU(/1)
  22. C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU
  23. C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  24. NBCON=7
  25. NBCONR=NBCON-1
  26. NMAX=(10*ITE)/NBCON
  27. SEGINI KON
  28. C MISE A ZERO DU TABLEAU KON
  29. DO 10 I=1,NMAX
  30. DO 10 J=1,NBCON
  31. KON(J,I)=0
  32. 10 CONTINUE
  33. C FABRICATION DU TABLEAU DES CONNECTIONS
  34. C POINT FINAL
  35. ICHAIN=ITE
  36. SEGACT MELEME
  37. IPT1=MELEME
  38. DO 100 IOB=1,MAX(1,LISOUS(/1))
  39. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
  40. SEGACT IPT1
  41. IF (KSURF(IPT1.ITYPEL).NE.0) THEN
  42. NBELEM=IPT1.NUM(/2)
  43. NBFAC=LTEL(1,IPT1.ITYPEL)
  44. IAD=LTEL(2,IPT1.ITYPEL)-1
  45. IF (NBFAC.NE.0) THEN
  46. DO 101 IFAC=1,NBFAC
  47. ITYP=LDEL(1,IAD+IFAC)
  48. NPFAC=KDFAC(1,ITYP)
  49. JAD=LDEL(2,IAD+IFAC)-1
  50. IDEP=KDFAC(2,ITYP)
  51. IFEP=IDEP+3*(KDFAC(3,ITYP)-1)
  52. * TRIANGLE ELEMENTAIRE
  53. * ON NE GARDE QUE CEUX QUI ONT LEURS TROIS NOEUDS VUS
  54. DO 101 ITRIAN=IDEP,IFEP,3
  55. IAFA=LFAC(JAD+KFAC(ITRIAN))
  56. IBFA=LFAC(JAD+KFAC(ITRIAN+1))
  57. ICFA=LFAC(JAD+KFAC(ITRIAN+2))
  58. DO 102 IEL=1,NBELEM
  59. IA=ICPR(IPT1.NUM(IAFA,IEL))
  60. IB=ICPR(IPT1.NUM(IBFA,IEL))
  61. IC=ICPR(IPT1.NUM(ICFA,IEL))
  62. IF (IVU(IA).GE.1.AND.IVU(IB).GE.1.AND.IVU(IC).GE.1)
  63. * THEN
  64. DO 103 ICOT=1,3
  65. IF (ICOT.EQ.1) THEN
  66. N1=IA
  67. N2=IB
  68. ELSEIF (ICOT.EQ.2) THEN
  69. N1=IB
  70. N2=IC
  71. ELSEIF (ICOT.EQ.3) THEN
  72. N1=IC
  73. N2=IA
  74. ENDIF
  75. NI=N1
  76. NJ=N2
  77. IF (N1*N2.EQ.0) THEN
  78. CALL ERREUR(26)
  79. SEGSUP KON
  80. SEGDES MELEME
  81. RETURN
  82. ENDIF
  83. IPO=0
  84. 23 CONTINUE
  85. 24 CONTINUE
  86. DO 25 K=1,NBCONR
  87. IF (KON(K,NI).EQ.0) GOTO 26
  88. IF (KON(K,NI).EQ.NJ) GOTO 27
  89. 25 CONTINUE
  90. IF (KON(NBCON,NI).EQ.0) GOTO 28
  91. NI=KON(NBCON,NI)
  92. GOTO 24
  93. 27 CONTINUE
  94. KON(K,NI)=-1
  95. GOTO 29
  96. 26 CONTINUE
  97. KON(K,NI)=NJ
  98. GOTO 29
  99. 28 CONTINUE
  100. ICHAIN=ICHAIN+1
  101. IF (ICHAIN.GE.NMAX) THEN
  102. C ON FAIT UN SEGADJ SUR LE TABLEAU DE CONNECTIONS
  103. NMAX=NMAX+1
  104. SEGADJ KON
  105. DO 70 J=1,NBCON
  106. KON(J,NMAX)=0
  107. 70 CONTINUE
  108. ENDIF
  109. KON(NBCON,NI)=ICHAIN
  110. K=1
  111. NI=ICHAIN
  112. GOTO 26
  113. 29 CONTINUE
  114. IF (IPO.NE.1) THEN
  115. NI=N2
  116. NJ=N1
  117. IPO=1
  118. GOTO 23
  119. ENDIF
  120. 103 CONTINUE
  121. ENDIF
  122. 102 CONTINUE
  123. 101 CONTINUE
  124. ENDIF
  125. ENDIF
  126. IF (LISOUS(/1).NE.0) SEGDES IPT1
  127. 100 CONTINUE
  128. SEGDES MELEME
  129. IF (IIMPI.EQ.2)WRITE (IOIMP,1122)((KON(I,J),I=1,NBCON),J=1,NMAX)
  130. 1122 FORMAT(1X,14I5)
  131. SEGDES MELEME
  132. SEGINI IDCP
  133. DO 40 I=1,ICPR(/1)
  134. IF (ICPR(I).EQ.0) GOTO 40
  135. IDCP(ICPR(I))=I
  136. 40 CONTINUE
  137. C CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME
  138. NBSOUS=0
  139. NBREF=0
  140. NBELEM=0
  141. DO 41 J=1,ITE
  142. JJ=J
  143. 43 DO 42 I=1,NBCONR
  144. IF (KON(I,JJ).LT.J) GOTO 42
  145. NBELEM=NBELEM+1
  146. 42 CONTINUE
  147. IF (KON(NBCON,JJ).EQ.0) GOTO 41
  148. JJ=KON(NBCON,JJ)
  149. GOTO 43
  150. 41 CONTINUE
  151. IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
  152. 1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6)
  153. IRETNE=NBELEM
  154. NBNN=2
  155. SEGINI MELEME
  156. ITYPEL=2
  157. IEL=0
  158. KAUX=1
  159. 50 CONTINUE
  160. K=KAUX
  161. KAUXR=KAUX
  162. if (k.gt.kon(/2)) then
  163. write (6,*) ' anomalie dans le trace '
  164. goto 63
  165. endif
  166. 51 DO 52 KL=1,NBCONR
  167. ITRA=KON(KL,K)
  168. IF (ITRA.EQ.-1) GOTO 52
  169. IF (ITRA.EQ.0) GOTO 53
  170. GOTO 54
  171. 52 CONTINUE
  172. K=KON(NBCON,K)
  173. IF (K.NE.0) GOTO 51
  174. 53 CONTINUE
  175. KAUX=KAUX+1
  176. IF (KAUX.EQ.ITE+1) GOTO 63
  177. GOTO 50
  178. 54 CONTINUE
  179. KPRESS=KAUXR
  180. GOTO 55
  181. 57 CONTINUE
  182. KL=1
  183. 55 DO 56 L=KL,NBCONR
  184. M=KON(L,K)
  185. IF (M.EQ.0) GOTO 53
  186. IF (M.EQ.-1) GOTO 56
  187. GOTO 58
  188. 56 CONTINUE
  189. K=KON(NBCON,K)
  190. IF (K.EQ.0) GOTO 53
  191. GOTO 57
  192. 58 CONTINUE
  193. IEL=IEL+1
  194. NUM(1,IEL)=IDCP(KPRESS)
  195. NUM(2,IEL)=IDCP(M)
  196. ICOLOR(IEL)=1
  197. KON(L,K)=-1
  198. M1=M
  199. 59 DO 60 L=1,NBCONR
  200. IF (KON(L,M1).EQ.0) GOTO 62
  201. IF (KON(L,M1).EQ.KPRESS) GOTO 61
  202. 60 CONTINUE
  203. M1=KON(NBCON,M1)
  204. IF (M1.EQ.0) GOTO 62
  205. GOTO 59
  206. 61 CONTINUE
  207. KON(L,M1)=-1
  208. 62 CONTINUE
  209. GOTO 57
  210. 63 CONTINUE
  211. * LE RESULTAT
  212. IPT2=MELEME
  213. IF (IIMPI.NE.0) THEN
  214. WRITE (IOIMP,*) ' CONTOUR APPARENT DANS PRCOAP '
  215. CALL ECROBJ('MAILLAGE',IPT2)
  216. CALL PRLIST
  217. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  218. ENDIF
  219. SEGSUP KON,IDCP
  220. C
  221. RETURN
  222. END
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  

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