Télécharger examel.eso

Retour à la liste

Numérotation des lignes :

  1. C EXAMEL SOURCE PV 17/10/03 21:15:24 9581
  2. SUBROUTINE EXAMEL (ICOLAC,ITLACC,M1,M2,IIICHA)
  3. C----------------------------------------------------------------------
  4. C
  5. C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE
  6. C SI IIICHA =1 ON CHANGE LES POINTEURS----
  7. C
  8. C ENTREE ITLACC POINTEUR DE LA PILE EXAMINEE
  9. C ICOLAC POINTEUR SUR LE CHAPEAU DES PILES
  10. C M1 @REMIER INDICE D EXAMEN DANS LA PILE
  11. C M2 DERNIER INDICE
  12. C IIICHA =1 ON CHANGE LES POINTEURS
  13. C----------------------------------------------------------------
  14. C APPELE PAR EXPIL
  15. C APPELLE AJOUN
  16. C
  17. C=======================================================================
  18. C TABLEAU KCOLA :
  19. C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6
  20. C 7 8 MSOLUT 9 MSTRUC 10 11 MAFFEC 12 MSOSTU
  21. C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
  22. C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL 23 MSUPER
  23. C=======================================================================
  24. C
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. logical ooovp1
  28. -INC SMELEME
  29. -INC CCOPTIO
  30. -INC TMCOLAC
  31. -INC SMCOORD
  32. -INC CCGEOME
  33. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  34. ICO1=KCOLA(1)
  35. ICO2=KCOLA(32)
  36. ILISSE=ILISSG
  37. SEGACT ILISSE*MOD
  38. ITLAC1=ICO2
  39. SEGINI ICPR
  40. IFAIT = ITLAC1.ITLAC(/1)
  41. DO 710 IHU=1,IFAIT
  42. IAM=ITLAC1.ITLAC(IHU)
  43. ICPR(IAM)=IHU
  44. 710 CONTINUE
  45. * mise a jour de ilgni a ne faire qu'une fois
  46. if (m1.eq.1.and.iiicha.eq.1) then
  47. if (ilgni.ne.0) then
  48. if (icpr(ilgni).eq.0) then
  49. IFAIT = IFAIT + 1
  50. ICPR(ilgni)=IFAIT
  51. ENDIF
  52. ilgni = icpr(ilgni)
  53. endif
  54. endif
  55. DO 601 IEL=M1,M2
  56. MELEME=ITLAC(IEL)
  57. C WRITE (IOIMP,8876) MELEME
  58. IF (MELEME.EQ.0) GO TO 601
  59. if (.NOT.ooovp1(meleme)) goto 610
  60. C8876 FORMAT(' MELEME',I6)
  61. if(IIICHA.EQ.1) then
  62. Cgf activation en mod pour pouvoir renumeroter les maillages
  63. SEGACT MELEME*MOD
  64. else
  65. Cgf On ne fait que lire le maillage, pas besoin de l'ouvrir en
  66. C ecriture
  67. SEGACT MELEME
  68. endif
  69. IF(LISOUS(/1).EQ.0) GO TO 602
  70. IF (LISOUS(/1).LT.0) GOTO 610
  71. DO 603 I=1,LISOUS(/1)
  72. IVA=LISOUS(I)
  73. if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
  74. CALL AJOUN(ICO1,IVA,ILISSE,1)
  75. IF(IIICHA.EQ.1)LISOUS(I)=IVA
  76. 603 CONTINUE
  77. 602 CONTINUE
  78. IF(LISREF(/1).EQ.0) GO TO 645
  79. IF (LISREF(/1).GT.1000) GOTO 610
  80. IF (LISREF(/1).LT.0) GOTO 610
  81. DO 646 I=1,LISREF(/1)
  82. IVA=LISREF(I)
  83. if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
  84. CALL AJOUN(ICO1,IVA,ILISSE,1)
  85. IF(IIICHA.EQ.1)LISREF(I)=IVA
  86. 646 CONTINUE
  87. 645 CONTINUE
  88. IF(NUM(/2).EQ.0) GO TO 660
  89. DO 661 K2=1,NUM(/2)
  90. DO 661 K1=1,NUM(/1)
  91. IVA=NUM(K1,K2)
  92. if (iva.gt.icpr(/1).or.iva.le.0) goto 610
  93. IF(ICPR(IVA).EQ.0) THEN
  94. IFAIT = IFAIT + 1
  95. ICPR(IVA)=IFAIT
  96. * ITLAC1.ITLAC(**)= IVA
  97. * CALL AJOUN(ICO2,IVA,)
  98. ENDIF
  99. IF(IIICHA.EQ.1) NUM(K1,K2)=ICPR(IVA)
  100. 661 CONTINUE
  101. 660 CONTINUE
  102. SEGDES MELEME
  103. GOTO 601
  104. 610 continue
  105. * meleme invalide. On le supprime de la pile
  106. moterr(1:8)='MAILLAGE'
  107. interr(1)=itlac(iel)
  108. call erreur(861)
  109. itlac(iel)=0
  110. 601 CONTINUE
  111. C# MC IF(IICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT)
  112. IF(IIICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT,ILISSE)
  113. SEGSUP ICPR
  114. * SEGDES ILISSE
  115. RETURN
  116. C ************
  117. END
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  

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