Télécharger prelim.eso

Retour à la liste

Numérotation des lignes :

  1. C PRELIM SOURCE PV 17/12/05 21:17:06 9646
  2. SUBROUTINE PRELIM(ICLE)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C=====================================================================
  6. C CE SOUS PROGRAMME PREPARE LES DONNEES POUR ELIM
  7. C IL FORME LA TABLE DES POINTS A TESTER
  8. C
  9. C ICPR EST LA MOUVELLE NUMEROTATION
  10. C ICPR(ANCIEN N°)= NOUVEAU N°
  11. C ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S
  12. C ) ARGUMENT(S)
  13. C IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
  14. C =1 SI LE NOEUD EST DANS LE 1ER MAILLGE =0 SINON
  15. C IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION
  16. C =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE =0 SINON
  17. C ICLE=0 PRELIM APPELE PAR L'OPERATEUR ELIM
  18. C ICLE=1 PRELIM APPELE PAR L'OPERATEUR VISAVIS
  19. C======================================================================
  20.  
  21. -INC CCOPTIO
  22. -INC SMELEME
  23. POINTEUR MELEM2.MELEME
  24. -INC SMCOORD
  25. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  26. SEGMENT IAPOB1(XCOOR(/1)/(IDIM+1))
  27. SEGMENT IAPOB2(XCOOR(/1)/(IDIM+1))
  28. REAL*8 XXX,CRIT
  29. -INC CCGEOME
  30. -INC TMLCHA8
  31. -INC TMCOLAC
  32. -INC CCASSIS
  33. CHARACTER*8 TYPI,NOMI
  34.  
  35. C RECUPERE LES ARGUMENTS
  36.  
  37. IF (ICLE.EQ.0) THEN
  38.  
  39. CALL QUETYP(TYPI,0,IRET)
  40. IF (IRET.EQ.0) THEN
  41. * ERREUR => "Cet opérateur a encore besoin d'un opérande."
  42. CALL ERREUR(533)
  43. RETURN
  44. ENDIF
  45.  
  46. IF (TYPI.NE.'MAILLAGE' .AND.
  47. & TYPI.NE.'ENTIER' .AND.
  48. & TYPI.NE.'FLOTTANT') THEN
  49. * ERREUR => "On ne veut pas d'objet de type %m1:8"
  50. MOTERR(1:8)=TYPI
  51. CALL ERREUR(39)
  52. RETURN
  53. ENDIF
  54.  
  55. ENDIF
  56. ***********************************************************************
  57.  
  58.  
  59. MELEME=0
  60. MELEM2=0
  61. CALL LIRREE(XXX,0,IRETOU)
  62. IF (IRETOU.NE.0)THEN
  63. CRIT=XXX
  64. ELSE
  65. CRIT=DBLE(DENSIT)/10.D0
  66. ENDIF
  67. CRIT=ABS(CRIT)
  68. C Erreur 21 : Données incompatibles
  69. IF (CRIT.EQ.0.D0) CALL ERREUR(21)
  70. IF (IERR.NE.0) RETURN
  71. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  72. IF (IERR.NE.0) RETURN
  73. CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  74. IF(MELEM2.EQ.0) MELEM2=MELEME
  75. * ON REMET DANS LA PILE LE DERNIER MAILLAGE LU (POUR DALLER QUEL)
  76. IF(ICLE.EQ.0) CALL REFUS
  77. if( nbesc.ne.0) then
  78. mestra=imestr
  79. SEGACT MESTRA*MOD
  80. call ooofrc(1)
  81. call setass(1)
  82. endif
  83. SEGINI ICPR
  84. SEGINI IAPOB1
  85. SEGINI IAPOB2
  86. C
  87. C BOUCLE SUR LE PREMIER MAILLAGE REMPLI ICPR ET IAPOB1
  88. C
  89. ITE=0
  90. SEGACT MELEME
  91. DO 2 I=1,MAX(1,LISOUS(/1))
  92. IF (LISOUS(/1).NE.0) THEN
  93. IPT1=LISOUS(I)
  94. SEGACT IPT1
  95. ELSE
  96. IPT1=MELEME
  97. ENDIF
  98. DO 5 K=1,IPT1.NUM(/1)
  99. DO 51 L=1,IPT1.NUM(/2)
  100. M=IPT1.NUM(K,L)
  101. IF (ICPR(M).EQ.0) THEN
  102. ITE=ITE+1
  103. ICPR(M)=ITE
  104. ENDIF
  105. IAPOB1(ICPR(M))=1
  106. 51 CONTINUE
  107. 5 CONTINUE
  108. IF (LISOUS(/1).NE.0) SEGDES IPT1
  109. 2 CONTINUE
  110. SEGDES MELEME
  111. C
  112. C BOUCLE SUR LE DEUXIEME MAILLAGE REMPLI IPCR ET IAPOB2
  113. C
  114. SEGACT MELEM2
  115. DO 52 I=1,MAX(1,MELEM2.LISOUS(/1))
  116. IF (MELEM2.LISOUS(/1).NE.0)THEN
  117. IPT2=MELEM2.LISOUS(I)
  118. SEGACT IPT2
  119. ELSE
  120. IPT2=MELEM2
  121. ENDIF
  122. DO 45 K=1,IPT2.NUM(/1)
  123. DO 451 L=1,IPT2.NUM(/2)
  124. M=IPT2.NUM(K,L)
  125. IF (ICPR(M).EQ.0) THEN
  126. ITE=ITE+1
  127. ICPR(M)=ITE
  128. ENDIF
  129. IAPOB2(ICPR(M))=1
  130. 451 CONTINUE
  131. 45 CONTINUE
  132. IF (MELEM2.LISOUS(/1).NE.0) SEGDES IPT2
  133. 52 CONTINUE
  134. SEGDES MELEM2
  135. C
  136. C ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE
  137. C
  138. TYPI=' '
  139. K=-1
  140. CALL TYPFIL(TYPI,K)
  141. CALL CREPIL(ICOLAC,-K)
  142. M=1
  143. SEGINI MLCHA8
  144. MLCHAR(1)='MAILLAGE'
  145. CALL FILLPO(ICOLAC,MLCHA8)
  146. SEGSUP MLCHA8
  147. CALL FILLPI(ICOLAC)
  148. SEGACT ICOLAC
  149. C
  150. C BOUCLE SUR LES MAILLAGES ON CHERCHE LES ELEMENTS DE TYPE 22
  151. C ("MULT")
  152. C ON INDIQUE LEUR EXISTENCE DANS IAPOB1 AVEC LA VALEUR 2
  153. C
  154. ITLACC=KCOLA(1)
  155. SEGACT ITLACC
  156. DO 70 L=1,ITLAC(/1)
  157. MELEME=ITLAC(L)
  158. IF (MELEME.NE.0) THEN
  159. SEGACT MELEME
  160. DO 60 LL=1,MAX(1,LISOUS(/1))
  161. IF (LISOUS(/1).NE.0)THEN
  162. IPT1=LISOUS(LL)
  163. SEGACT IPT1
  164. ELSE
  165. IPT1=MELEME
  166. ENDIF
  167. IF (IPT1.ITYPEL .EQ. 22)THEN
  168. DO 55 LLL=1,IPT1.NUM(/2)
  169. C LE PREMIER NOEUD SUPPORTENT LES MULTIPLICATEURS
  170. IF (ICPR(IPT1.NUM(1,LLL)) .NE. 0)
  171. $ IAPOB1(ICPR(IPT1.NUM(1,LLL)))=2
  172. 55 CONTINUE
  173. ENDIF
  174. IF (LISOUS(/1).NE.0)SEGDES IPT1
  175. 60 CONTINUE
  176. SEGDES MELEME
  177. ENDIF
  178. 70 CONTINUE
  179. C Supprime icolac et tous ses sous-objets (ITLACC...)
  180. CALL SUPPIL(ICOLAC,-1)
  181. C
  182. CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
  183. SEGSUP IAPOB2
  184. SEGSUP IAPOB1
  185. SEGSUP ICPR
  186. if(nbesc.ne.0) then
  187. mestra=imestr
  188. call ooofrc(0)
  189. call setass(0)
  190. SEGDES MESTRA
  191. endif
  192. RETURN
  193. END
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  

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