Télécharger compri.eso

Retour à la liste

Numérotation des lignes :

  1. C COMPRI SOURCE PV 09/07/16 21:15:05 6446
  2. C CET OPERATEUR EXTRAIT D'UNE LIGNE LA PARTIE COMPRISE ENTRE 2 PTS
  3. C
  4. SUBROUTINE COMPRI
  5. IMPLICIT INTEGER(I-N)
  6. -INC CCOPTIO
  7. -INC SMELEME
  8. -INC SMCOORD
  9. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  10. SEGMENT IDCP(ITE)
  11. SEGMENT KON(NBCON,NMAX,3)
  12. CHARACTER*(8) ITPOIN,ITMAIL
  13. DATA ITPOIN,ITMAIL/'POINT ','MAILLAGE'/
  14. ipt1=0
  15. CALL LIROBJ(ITMAIL,MELEME,1,IRETOU)
  16. CALL LIROBJ(ITPOIN,IP1,1,IRETOU)
  17. CALL LIROBJ(ITPOIN,IP2,1,IRETOU)
  18. IPA1=IP1
  19. IPA2=IP2
  20. IF (IERR.NE.0) RETURN
  21. SEGACT MELEME
  22. NBNN=ITYPEL
  23. IF (NBNN.NE.2.AND.NBNN.NE.3) CALL ERREUR(16)
  24. IF (IERR.EQ.0) GOTO 1
  25. SEGDES MELEME
  26. RETURN
  27. 1 CONTINUE
  28. SEGINI ICPR
  29. DO 2 I=1,ICPR(/1)
  30. 2 ICPR(I)=0
  31. C REMPLISSAGE DE ICPR
  32. ITE=0
  33. NBELEM=NUM(/2)
  34. NBNN=NUM(/1)
  35. DO 3 J=1,NBNN
  36. DO 3 K=1,NBELEM
  37. IPOIT=NUM(J,K)
  38. IF (ICPR(IPOIT).NE.0) GOTO 3
  39. ITE=ITE+1
  40. ICPR(IPOIT)=ITE
  41. 3 CONTINUE
  42. C TABLEAU INVERSE
  43. SEGINI IDCP
  44. ILO=XCOOR(/1)/(IDIM+1)
  45. DO 4 I=1,ILO
  46. J=ICPR(I)
  47. IF (J.EQ.0) GOTO 4
  48. IDCP(J)=I
  49. 4 CONTINUE
  50. C ITE EST LE NOMBRE DE POINTS A TRACER ICPR LE TABLEAU
  51. C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  52. NBCON=3
  53. NBCONR=NBCON-1
  54. NMAX=(5*ITE)/NBCON
  55. SEGINI KON
  56. C MISE A ZERO DU TABLEAU KON
  57. DO 10 K=1,3
  58. DO 10 I=1,NMAX
  59. DO 10 J=1,NBCON
  60. 10 KON(J,I,K)=0
  61. C FABRICATION DU TABLEAU DES CONNECTIONS
  62. ICHAIN=ITE
  63. DO 20 I=1,NBELEM
  64. NMIL=1
  65. N1=ICPR(NUM(1,I))
  66. N2=ICPR(NUM(NBNN,I))
  67. IF (NBNN.EQ.3) NMIL=NUM(2,I)
  68. IF (N1.EQ.N2) GOTO 20
  69. NI=N1
  70. NJ=N2
  71. KSCOL=ICOLOR(I)
  72. 21 CONTINUE
  73. 22 DO 23 K=1,NBCONR
  74. IF (KON(K,NI,1).EQ.0) GOTO 25
  75. 23 CONTINUE
  76. IF (KON(NBCON,NI,1).EQ.0) GOTO 24
  77. NI=KON(NBCON,NI,1)
  78. GOTO 22
  79. 24 ICHAIN=ICHAIN+1
  80. IF (ICHAIN.EQ.NMAX) GOTO 30
  81. KON(NBCON,NI,1)=ICHAIN
  82. K=1
  83. NI=ICHAIN
  84. 25 KON(K,NI,1)=NJ
  85. KON(K,NI,2)=NMIL
  86. KON(K,NI,3)=KSCOL
  87. IF (NMIL.LE.0) GOTO 20
  88. NI=N2
  89. NJ=N1
  90. NMIL=-NMIL
  91. GOTO 21
  92. 30 CALL ERREUR(23)
  93. RETURN
  94. 20 CONTINUE
  95. SEGDES MELEME
  96. C EXTRACTION DE LA SOUS-PARTIE
  97. NBSOUS=0
  98. NBREF=0
  99. * write (6,*) ' ipt1 nbelem nbnn ',nbelem nbnn
  100. SEGINI IPT1
  101. IP1=ICPR(IP1)
  102. IP2=ICPR(IP2)
  103. IF (IP1*IP2.EQ.0) CALL ERREUR(18)
  104. IF (IERR.EQ.0) GOTO 31
  105. SEGSUP KON
  106. RETURN
  107. 31 CONTINUE
  108. if (ipt1.eq.0) call erreur(5)
  109. IEL=0
  110. KAUX=IP1
  111. K=KAUX
  112. KPRESS=KAUX
  113. 41 DO 40 KL=1,NBCONR
  114. M=KON(KL,K,1)
  115. IF (M.EQ.0) GOTO 100
  116. IF (KON(KL,K,2).LE.0) GOTO 40
  117. GOTO 45
  118. 40 CONTINUE
  119. K=KON(NBCON,K,1)
  120. IF (K.EQ.0) GOTO 100
  121. GOTO 41
  122. 46 KL=1
  123. 45 DO 47 L=KL,NBCONR
  124. M=KON(L,K,1)
  125. IF (M.EQ.-1) GOTO 47
  126. IF (M.EQ.0) GOTO 100
  127. GOTO 48
  128. 47 CONTINUE
  129. K=KON(NBCON,K,1)
  130. IF (K.EQ.0) GOTO 100
  131. GOTO 46
  132. 48 IEL=IEL+1
  133. IPT1.NUM(1,IEL)=IDCP(KPRESS)
  134. IPT1.NUM(NBNN,IEL)=IDCP(M)
  135. IPT1.ICOLOR(IEL)=KON(L,K,3)
  136. IF (NBNN.EQ.3) IPT1.NUM(2,IEL)=ABS(KON(L,K,2))
  137. IF (M.EQ.IP2) GOTO 52
  138. KON(L,K,1)=-1
  139. M1=M
  140. 49 DO 50 L=1,NBCONR
  141. IF (KON(L,M1,1).EQ.0) GOTO 53
  142. IF (KON(L,M1,1).EQ.-1) GOTO 50
  143. IF (KON(L,M1,1).EQ.KPRESS) GOTO 51
  144. 50 CONTINUE
  145. M1=KON(NBCON,M1,1)
  146. GOTO 49
  147. 51 KON(L,M1,1)=-1
  148. 53 KPRESS=M
  149. GOTO 46
  150. 100 CONTINUE
  151. * on essaye de voir si un seul chemin
  152. SEGSUP KON,IPT1,ICPR,IDCP
  153. CALL CHEMIN(MELEME,IPA1,IPA2,IPT1)
  154. IF(IERR.EQ.0)CALL ECROBJ(ITMAIL,IPT1)
  155. RETURN
  156. 52 CONTINUE
  157. SEGSUP KON,ICPR,IDCP
  158. C ON A FINI IL NE RESTE PLUS QU'A COMPACTER LE SEGMENT
  159. NBELEM=IEL
  160. SEGINI MELEME
  161. ITYPEL=NBNN
  162. DO 60 I=1,NBNN
  163. DO 60 J=1,NBELEM
  164. NUM(I,J)=IPT1.NUM(I,J)
  165. 60 CONTINUE
  166. DO 61 I=1,NBELEM
  167. 61 ICOLOR(I)=IPT1.ICOLOR(I)
  168. SEGSUP IPT1
  169. SEGDES MELEME
  170. CALL ECROBJ(ITMAIL,MELEME)
  171. RETURN
  172. END
  173.  
  174.  
  175.  
  176.  

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