Télécharger fillp1.eso

Retour à la liste

Numérotation des lignes :

  1. C FILLP1 SOURCE PV 16/11/26 21:15:52 9205
  2. SUBROUTINE FILLP1 (ICOLAC,IMAX)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C
  7. C ON COMPLETE LA PILE DE MELEME
  8. C IMAX : NUMERO MAX DE POINT
  9. C
  10. C ECRIT PAR FARVACQUE -REPRIS PAR LENA
  11. C APPELE PAR SAUVV
  12. C APPELLE : AJOUN SNOM2 REPERT
  13. C=======================================================================
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC TMCOLAC
  17. SEGMENT ILISBB
  18. INTEGER ILISOB(MLON)
  19. ENDSEGMENT
  20. CHARACTER*8 CTYP
  21. DIMENSION ILENA(10)
  22. DATA CTYP/'MAILLAGE'/
  23. C
  24. C
  25. C **** ON PREND TOUS LES MELEME DONT TOUS LES NOEUDS SONT INFERIEURS
  26. C **** A IMAX . IL Y EN A IMAX2
  27. C
  28. SEGACT ICOLAC
  29. ILISSE=ILISSG
  30. SEGACT ILISSE*MOD
  31. CALL LISTOB(CTYP,MLON,ILENA,0)
  32. SEGINI ILISBB
  33. CALL LISTOB(CTYP,N,ILISOB,1)
  34. C CALL REPERT (CTYP ,N)
  35. IF (N.EQ.0) GO TO 100
  36. ICO=KCOLA(1)
  37. ITLACC =KCOLA (1)
  38. DO 200 M=1,N
  39. MELEME=ILISOB(M)
  40. C CALL LIROBJ(CTYP,MELEME,1,IRETOU)
  41. IF(IERR.NE.0) RETURN
  42. CALL SNOM2 (MELEME,ITLACC,IRET)
  43. IF (IRET.GT.0) GOTO 200
  44. C --- LE MELEME N EST PAS DANS LA PILE
  45. C --- ON REGARDE SI SES NUMEROS SONT .LE.IMAX
  46. SEGACT MELEME
  47. C
  48. IPT1=MELEME
  49. NTOTO=LISOUS(/1)
  50. KRET=0
  51. IF(NTOTO.NE.0) GOTO 53
  52. CALL TESTNU (MELEME,IMAX,IRET)
  53. KRET=IRET
  54. GO TO 54
  55. 53 CONTINUE
  56. DO 52 JJ=1,NTOTO
  57. MELEME=IPT1.LISOUS(JJ)
  58. CALL TESTNU (MELEME,IMAX,IRET)
  59. KRET=KRET+IRET
  60. 52 CONTINUE
  61. 54 MELEME=IPT1
  62. IF(KRET.NE.0) GOTO 51
  63. C --- CE MELEME A SES NUM INFERIEURS OU EGAL A IMAX
  64. C --- ON LE RAJOUTE DANS LA PILE 1
  65. C --- AINSI QUE SES LISOUS ET LISREF
  66. IVA=IPT1
  67. CALL AJOUN (ITLACC,IVA,ILISSE,1)
  68. C
  69. SEGACT MELEME
  70. IF(LISOUS(/1).EQ.0) GO TO 58
  71. DO 59 I=1,LISOUS(/1)
  72. IVA=LISOUS(I)
  73. CALL AJOUN(ITLACC,IVA,ILISSE,1)
  74. C LISOUS(I)=IVA
  75. 59 CONTINUE
  76. 58 IF(LISREF(/1).EQ.0) GOTO 64
  77. DO 61 I=1,LISREF(/1)
  78. IVA=LISREF(I)
  79. CALL AJOUN(ITLACC,IVA,ILISSE,1)
  80. C LISREF(I)=IVA
  81. 61 CONTINUE
  82. 64 SEGDES MELEME
  83. 51 CONTINUE
  84. C-----------------ATTENTION Y A T IL PLUSIEURS NIVEAUX DE LISTREF
  85. C-----------------SI OUI OBLIGATION DE REFAIRE UN PASSAGE DANS FILLPI
  86. 200 CONTINUE
  87. C
  88. 100 CONTINUE
  89. SEGSUP ILISBB
  90. * SEGDES ILISSE
  91. SEGDES ICOLAC
  92. RETURN
  93. END
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  

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