Télécharger noisin.eso

Retour à la liste

Numérotation des lignes :

  1. C NOISIN SOURCE JC220346 16/11/29 21:15:25 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. FUNCTION NOISIN(IP,JP,IFC)
  5. C |
  6. C CETTE SUBROUTINE CHERCHE LA FACETTE JFC VOISINE DE IFC, |
  7. C AYANT POUR SEGMENT COMMUN ›IP,JP!. |
  8. C SI IL Y EN A PLUSIEURS ELLE PREND CELLE QUI FAIT LE PLUS PETIT |
  9. C ANGLE |
  10. C |
  11. C---------------------------------------------------------------------|
  12. C
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8(A-H,O-Z)
  15. dimension icrash(1)
  16. -INC CCOPTIO
  17. -INC TDEMAIT
  18. JFSAUV=0
  19. C
  20. C RECHERCHE DE JFC
  21. C ----------------
  22. DO 100 I=1,40
  23. JF=NPF(I,JP)
  24. IF (JF.EQ.0) GOTO 130
  25. IF (JF.EQ.IFC) GOTO 100
  26. IF (ISUCC(JF,JP).NE.IP) GOTO 100
  27. IF (JFSAUV.EQ.0) THEN
  28. JFSAUV=JF
  29. ELSE
  30. TETSAU=TETA(jfsauv,IFC,jP,iP)
  31. * TETSAU=TETA(IFC,JFSAUV,iP,jP)
  32. * write(6,*) ' noisin double facette voisine ',
  33. * # tetsau,TETA(jf,IFC,jP,iP),jfsauv,jf
  34. * write (6,*) ' facette courante ',ifc
  35. kp=nfc(1,ifc)
  36. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  37. kp=nfc(2,ifc)
  38. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  39. kp=nfc(3,ifc)
  40. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  41. kp=nfc(4,ifc)
  42. * if (kp.ne.0) write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  43. * write (6,*) ' facette jfsauv ',jfsauv
  44. kp=nfc(1,jfsauv)
  45. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  46. kp=nfc(2,jfsauv)
  47. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  48. kp=nfc(3,jfsauv)
  49. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  50. kp=nfc(4,jfsauv)
  51. * if (kp.ne.0) write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  52. * write (6,*) ' facette jf ',jf
  53. kp=nfc(1,jf)
  54. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  55. kp=nfc(2,jf)
  56. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  57. kp=nfc(3,jf)
  58. * write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  59. kp=nfc(4,jf)
  60. * if (kp.ne.0) write (6,*) kp,xyz(1,kp),xyz(2,kp),xyz(3,kp)
  61. IF (TETA(jf,IFC,jP,iP).gT.TETSAU) JFSAUV=JF
  62. * IF (TETA(IFC,JF,iP,jP).GT.TETSAU) JFSAUV=JF
  63. ENDIF
  64. 100 CONTINUE
  65. 130 CONTINUE
  66. IF (JFSAUV.NE.0) GOTO 110
  67. C
  68. 120 IF (IVERB.EQ.1) WRITE(6,1010)IFC,IP,JP
  69. 1010 FORMAT(' ERREUR |, LA FACETTE',I6,' N A PAS DE VOISINE',
  70. # ' PAR LE SEGMENT ',2I6,'!')
  71. * write (6,*) ' liste des facettes restantes '
  72. DO 444 I=1,NFCMAX
  73. * IF (IFAT(I).EQ.1) GOTO 444
  74. IF (IVERB.EQ.1) WRITE(6,*) I,IFAT(i),NFC(1,I),NFC(2,I),NFC(3,I),
  75. & NFC(4,I)
  76. 444 CONTINUE
  77. i=100000000
  78. nfc(1,i)=1
  79. * CALL ERRTRA
  80. C
  81. return
  82. 110 CONTINUE
  83. NOISIN=JFSAUV
  84. C WRITE(6,1000)JF,IFC
  85. C1000 FORMAT(' +++',I3,' EST VOISINE DE ',I3)
  86. C
  87. RETURN
  88. C
  89. C FIN DE LA SUBROUTINE VOISIN
  90. END
  91.  
  92.  
  93.  
  94.  

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