Télécharger prelim.eso

Retour à la liste

Numérotation des lignes :

  1. C PRELIM SOURCE PV 20/03/30 21:22:37 10567
  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(nbpts)
  26. SEGMENT IAPOB1(nbpts)
  27. SEGMENT IAPOB2(nbpts)
  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. 2 CONTINUE
  109. C
  110. C BOUCLE SUR LE DEUXIEME MAILLAGE REMPLI IPCR ET IAPOB2
  111. C
  112. SEGACT MELEM2
  113. DO 52 I=1,MAX(1,MELEM2.LISOUS(/1))
  114. IF (MELEM2.LISOUS(/1).NE.0)THEN
  115. IPT2=MELEM2.LISOUS(I)
  116. SEGACT IPT2
  117. ELSE
  118. IPT2=MELEM2
  119. ENDIF
  120. DO 45 K=1,IPT2.NUM(/1)
  121. DO 451 L=1,IPT2.NUM(/2)
  122. M=IPT2.NUM(K,L)
  123. IF (ICPR(M).EQ.0) THEN
  124. ITE=ITE+1
  125. ICPR(M)=ITE
  126. ENDIF
  127. IAPOB2(ICPR(M))=1
  128. 451 CONTINUE
  129. 45 CONTINUE
  130. 52 CONTINUE
  131. C
  132. C ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE
  133. C
  134. TYPI=' '
  135. K=-1
  136. CALL TYPFIL(TYPI,K)
  137. CALL CREPIL(ICOLAC,-K)
  138. M=1
  139. SEGINI MLCHA8
  140. MLCHAR(1)='MAILLAGE'
  141. CALL FILLPO(ICOLAC,MLCHA8)
  142. SEGSUP MLCHA8
  143. CALL FILLPI(ICOLAC)
  144. SEGACT ICOLAC
  145. C
  146. C BOUCLE SUR LES MAILLAGES ON CHERCHE LES ELEMENTS DE TYPE 22
  147. C ("MULT")
  148. C ON INDIQUE LEUR EXISTENCE DANS IAPOB1 AVEC LA VALEUR 2
  149. C
  150. ITLACC=KCOLA(1)
  151. SEGACT ITLACC
  152. DO 70 L=1,ITLAC(/1)
  153. MELEME=ITLAC(L)
  154. IF (MELEME.NE.0) THEN
  155. SEGACT MELEME
  156. DO 60 LL=1,MAX(1,LISOUS(/1))
  157. IF (LISOUS(/1).NE.0)THEN
  158. IPT1=LISOUS(LL)
  159. SEGACT IPT1
  160. ELSE
  161. IPT1=MELEME
  162. ENDIF
  163. IF (IPT1.ITYPEL .EQ. 22)THEN
  164. DO 55 LLL=1,IPT1.NUM(/2)
  165. C LE PREMIER NOEUD SUPPORTENT LES MULTIPLICATEURS
  166. IF (ICPR(IPT1.NUM(1,LLL)) .NE. 0)
  167. $ IAPOB1(ICPR(IPT1.NUM(1,LLL)))=2
  168. 55 CONTINUE
  169. ENDIF
  170. 60 CONTINUE
  171. ENDIF
  172. 70 CONTINUE
  173. C Supprime icolac et tous ses sous-objets (ITLACC...)
  174. CALL SUPPIL(ICOLAC,-1)
  175. C
  176. CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
  177. SEGSUP IAPOB2,IAPOB1,ICPR
  178. if(nbesc.ne.0) then
  179. mestra=imestr
  180. call ooofrc(0)
  181. call setass(0)
  182. SEGDES MESTRA
  183. endif
  184. END
  185.  
  186.  
  187.  
  188.  

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