Télécharger paqlig.eso

Retour à la liste

Numérotation des lignes :

  1. C PAQLIG SOURCE BP208322 16/11/18 21:19:43 9177
  2. SUBROUTINE PAQLIG(II,JJ)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *
  6. * ii est un meleme de seg2 ou de seg3. on chzerche a reconstituer chaque ligne
  7. * en sortie jj est un pointeur sur PAQUET qui contient la liste consecutive
  8. * des noeuds formant une ligne, chaque ligne est séparé par un zero
  9. C
  10. -INC SMELEME
  11. -INC CCGEOME
  12. -INC CCOPTIO
  13. -INC SMCOORD
  14. C
  15. INTEGER II,JJ,ITE,NELEM,IPOIT,N1,N2
  16. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  17. SEGMENT JCPR(XCOOR(/1)/(IDIM+1))
  18. SEGMENT KON(ITE,nkon)
  19. segment ivoi(ite)
  20. SEGMENT IDCP(ITE)
  21. SEGMENT PAQUET
  22. INTEGER LIGNE(NELEM)
  23. ENDSEGMENT
  24.  
  25.  
  26. MELEME=II
  27. SEGACT MELEME
  28. SEGINI ICPR,JCPR
  29. ITE=0
  30. nkon=2
  31. IF (LISOUS(/1).NE.0) THEN
  32. CALL ERREUR(16)
  33. RETURN
  34. ENDIF
  35. K=ITYPEL
  36. IF (K.NE.KDEGRE(K)) THEN
  37. CALL ERREUR(16)
  38. RETURN
  39. ENDIF
  40. DO 1 J=1,K,K-1
  41. DO 2 L=1,NUM(/2)
  42. IPOIT=NUM(J,L)
  43. JCPR(IPOIT)=JCPR(IPOIT)+1
  44. nkon=max(nkon,jcpr(ipoit))
  45. IF (JCPR(IPOIT).EQ.3) then
  46. interr(1)=ipoit
  47. CALL ERREUR(-336)
  48. ENDIF
  49. IF( icpr(ipoit).eq.0) then
  50. ITE=ITE+1
  51. ICPR(IPOIT)=ITE
  52. ENDIF
  53. 2 CONTINUE
  54. 1 CONTINUE
  55. * write(6,*) ' ite nkon',ite,nkon
  56. nelem=ite*nkon
  57. c Création du vecteur de connexions
  58. c initialisation
  59. SEGINI KON,ivoi,paquet
  60. C Remplissage
  61. DO 4 L=1,NUM(/2)
  62. N1=ICPR(NUM(1,L))
  63. N2=ICPR(NUM(K,L))
  64. ivoi(n1)=ivoi(n1)+1
  65. ivoi(n2)=ivoi(n2)+1
  66. KON(N1,ivoi(n1))=N2
  67. KON(N2,ivoi(n2))=n1
  68. 4 CONTINUE
  69. SEGDES MELEME
  70. SEGINI IDCP
  71. DO 5 I=1,ICPR(/1)
  72. IF (ICPR(I).EQ.0) GOTO 5
  73. IDCP(ICPR(I))=I
  74. 5 CONTINUE
  75. SEGSUP ICPR ,jcpr
  76. C
  77. C Création d'un vecteur contenant les paquets de lignes
  78. SEGINI PAQUET
  79. J=0
  80. * write(6,*) ' longueur du tableau' , ivoi(/1)
  81. * write(6,*) ( ivoi(iou),iou=1,ivoi(/1))
  82. 100 continue
  83. * on cherche un point de depart
  84. do 10 ip=1,ite
  85. if(mod(ivoi(ip),2).eq.1) go to 7
  86. 10 continue
  87. * il n'y en a pas ... fin
  88. go to 6
  89. 7 ipd=ip
  90. * write(6,*) ' point de depart ' , idcp(ip)
  91. j=j+1
  92. ligne(j)= idcp(ipd)
  93. 70 ipn=kon(ipd,ivoi(ipd))
  94. ivoi(ipd)=ivoi(ipd)-1
  95. * mise a jour de kon et ivoi pour le nouveau point ipn
  96. do 8 io=1,ivoi(ipn)
  97. if(kon(ipn,io).eq.ipd) go to 9
  98. 8 continue
  99. call erreur(5)
  100. segsup idcp,ivoi,kon
  101. return
  102. 9 continue
  103. if(io.eq.ivoi(ipn)) then
  104. ivoi(ipn)=ivoi(ipn)-1
  105. else
  106. do 11 iu=io+1,ivoi(ipn)
  107. 11 kon(ipn,iu-1)=kon(ipn,iu)
  108. ivoi(ipn)=ivoi(ipn)-1
  109. endif
  110. j=j+1
  111. ligne(j)=idcp(ipn)
  112. ipd=ipn
  113. if(ivoi(ipd).eq.0) then
  114. j=j+1
  115. ligne(j)=0
  116. go to 100
  117. endif
  118. go to 70
  119. 6 continue
  120. nelem =j
  121. segsup idcp, ivoi,kon
  122. segadj paquet
  123. jj=paquet
  124. return
  125. end
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  

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