Télécharger examel.eso

Retour à la liste

Numérotation des lignes :

examel
  1. C EXAMEL SOURCE PV 21/01/21 21:15:17 10862
  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.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC TMCOLAC
  33. -INC SMCOORD
  34. -INC CCGEOME
  35. SEGMENT ICPR(nbpts)
  36. integer ooolen
  37. iun=1
  38. ICO1=KCOLA(1)
  39. ICO2=KCOLA(32)
  40. ILISSE=ILISSG
  41. SEGACT ILISSE*MOD
  42. ITLAC1=ICO2
  43. icpchg=0
  44. SEGINI ICPR
  45. IFAIT = ITLAC1.ITLAC(/1)
  46. DO 710 IHU=1,IFAIT
  47. IAM=ITLAC1.ITLAC(IHU)
  48. ICPR(IAM)=IHU
  49. if(iam.ne.ihu) icpchg=1
  50. 710 CONTINUE
  51. * mise a jour de ilgni a ne faire qu'une fois
  52. if (m1.eq.1.and.iiicha.eq.1) then
  53. if (ilgni.ne.0) then
  54. if (icpr(ilgni).eq.0) then
  55. IFAIT = IFAIT + 1
  56. ICPR(ilgni)=IFAIT
  57. if(ilgni.ne.ifait) icpchg=1
  58. ENDIF
  59. ilgni = icpr(ilgni)
  60. endif
  61. endif
  62. DO 601 IEL=M1,M2
  63. MELEME=ITLAC(IEL)
  64. C WRITE (IOIMP,8876) MELEME
  65. IF (MELEME.EQ.0) GO TO 601
  66. if (.NOT.ooovp1(meleme)) goto 610
  67. C8876 FORMAT(' MELEME',I6)
  68. if(IIICHA.EQ.1) then
  69. Cgf activation en mod pour pouvoir renumeroter les maillages
  70. SEGACT MELEME*MOD
  71. else
  72. Cgf On ne fait que lire le maillage, pas besoin de l'ouvrir en
  73. C ecriture
  74. SEGACT MELEME
  75. endif
  76. IF(LISOUS(/1).EQ.0) GO TO 602
  77. IF (LISOUS(/1).LT.0) GOTO 610
  78. DO 603 I=1,LISOUS(/1)
  79. IVA=LISOUS(I)
  80. if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
  81. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  82. IF(IIICHA.EQ.1)LISOUS(I)=IVA
  83. 603 CONTINUE
  84. 602 CONTINUE
  85. IF(LISREF(/1).EQ.0) GO TO 645
  86. IF (LISREF(/1).GT.1000) GOTO 610
  87. IF (LISREF(/1).LT.0) GOTO 610
  88. DO 646 I=1,LISREF(/1)
  89. IVA=LISREF(I)
  90. if (IIICHA.EQ.1.AND..NOT.ooovp1(iva)) goto 610
  91. CALL AJOUN(ICO1,IVA,ILISSE,iun)
  92. IF(IIICHA.EQ.1)LISREF(I)=IVA
  93. 646 CONTINUE
  94. 645 CONTINUE
  95. IF(NUM(/2).EQ.0) GO TO 660
  96. if(ifait.eq.nbpts.and.icpchg.eq.0) goto 660
  97. DO K2=1,NUM(/2)
  98. DO K1=1,NUM(/1)
  99. IVA=NUM(K1,K2)
  100. if (iva.gt.icpr(/1).or.iva.le.0) goto 610
  101. IF(ICPR(IVA).EQ.0) THEN
  102. IFAIT = IFAIT + 1
  103. ICPR(IVA)=IFAIT
  104. if(iva.ne.ifait) icpchg=1
  105. * ITLAC1.ITLAC(**)= IVA
  106. * CALL AJOUN(ICO2,IVA,)
  107. ENDIF
  108. IF(IIICHA.EQ.1.and.icpr(iva).ne.iva) NUM(K1,K2)=ICPR(IVA)
  109. enddo
  110. enddo
  111. 660 CONTINUE
  112. * on ne desactive que si le segment n'est pas trop grand pour ne pas
  113. * provoquer d'appel systematique au menage automatique
  114. if (ooolen(meleme).lt.10000000) then
  115. SEGDES MELEME
  116. else
  117. segact meleme
  118. endif
  119. GOTO 601
  120. 610 continue
  121. * meleme invalide. On le supprime de la pile
  122. moterr(1:8)='MAILLAGE'
  123. interr(1)=itlac(iel)
  124. call erreur(861)
  125. itlac(iel)=0
  126. 601 CONTINUE
  127. C# MC IF(IICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT)
  128. IF(IIICHA.NE.1) CALL ITLACT (ICPR,ITLAC1,IFAIT,ILISSE)
  129. SEGSUP ICPR
  130. * SEGDES ILISSE
  131. RETURN
  132. C ************
  133. END
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  

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