Télécharger combl3.eso

Retour à la liste

Numérotation des lignes :

  1. C COMBL3 SOURCE JC220346 16/11/29 21:15:07 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE COMBL3(II,IF1,IF2,IF3,IGAGNE)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE REMPLIR LE COIN EN RAJOUTANT UN |
  7. C POINT AU MILIEU |
  8. C |
  9. C---------------------------------------------------------------------|
  10. C
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8(A-H,O-Z)
  13. -INC CCOPTIO
  14. -INC TDEMAIT
  15. DIMENSION IIF4(3),IIF3(3)
  16. * WRITE(6,5000)
  17. 5000 FORMAT(' COMBL3 ( supprime ) ')
  18. C VERIFICATION DES ANGLES ( 0› 130›)
  19. ANG=TETA(IF1,IF2,II,ISUCC(IF1,II))
  20. IF (ANG.LT.-5.) RETURN
  21. ANG=TETA(IF2,IF3,II,ISUCC(IF2,II))
  22. IF (ANG.LT.-5.) RETURN
  23. ANG=TETA(IF3,IF1,II,ISUCC(IF3,II))
  24. IF (ANG.LT.-5.) RETURN
  25. C verification que les facettes sont bien comme on croit
  26. if (noisin(ii,isucc(if1,ii),if1).ne.if2) then
  27. IF (IVERB.EQ.1) write (6,*) ' souci dans combl3 '
  28. return
  29. endif
  30. if (noisin(ii,isucc(if2,ii),if2).ne.if3) then
  31. IF (IVERB.EQ.1) write (6,*) ' souci dans combl3 '
  32. return
  33. endif
  34. if (noisin(ii,isucc(if3,ii),if3).ne.if1) then
  35. IF (IVERB.EQ.1) write (6,*) ' souci dans combl3 '
  36. return
  37. endif
  38. C
  39. C RECHERCHE DU TYPE DES FACETTES
  40. C ------------------------------
  41. DO 10 I=1,3
  42. IIF4(I)=0
  43. IIF3(I)=0
  44. 10 CONTINUE
  45. I4=0
  46. I3=0
  47. IF (NFC(4,IF1).NE.0) THEN
  48. I4=I4+1
  49. IIF4(I4)=IF1
  50. ELSE
  51. I3=I3+1
  52. IIF3(I3)=IF1
  53. ENDIF
  54. IF (NFC(4,IF2).NE.0) THEN
  55. I4=I4+1
  56. IIF4(I4)=IF2
  57. ELSE
  58. I3=I3+1
  59. IIF3(I3)=IF2
  60. ENDIF
  61. IF (NFC(4,IF3).NE.0) THEN
  62. I4=I4+1
  63. IIF4(I4)=IF3
  64. ELSE
  65. I3=I3+1
  66. IIF3(I3)=IF3
  67. ENDIF
  68. C LE PREMIER CAS EST TRAITE AILLEURS ==> TETRAEDRE
  69. * WRITE (6,*) ' COMBLE I4 ',I4
  70. IF (I4.LE.0) RETURN
  71. * IF (I4.EQ.1)
  72. * # WRITE (6,*) ' APPEL COM433 AVEC ',IIF4(1),IIF3(1),IIF3(2)
  73. IF (I4.EQ.1) CALL COM433(II,IIF4(1),IIF3(1),IIF3(2),IGAGNE)
  74. * IF (I4.EQ.2)
  75. * # WRITE (6,*) ' APPEL COM443 AVEC ',IIF4(1),IIF4(2),IIF3(1)
  76. IF (I4.EQ.2) CALL COM443(II,IIF4(1),IIF4(2),IIF3(1),IGAGNE)
  77. * IF (I4.EQ.3)
  78. * # WRITE (6,*) ' APPEL COM444 AVEC ',IIF4(1),IIF4(2),IIF4(3)
  79. IF (I4.EQ.3) CALL COM444(II,IIF4(1),IIF4(2),IIF4(3),IGAGNE)
  80. RETURN
  81. END
  82.  
  83.  
  84.  
  85.  

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