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.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. POINTEUR MELEM2.MELEME
  26. -INC SMCOORD
  27. SEGMENT ICPR(nbpts)
  28. SEGMENT IAPOB1(nbpts)
  29. SEGMENT IAPOB2(nbpts)
  30. REAL*8 XXX,CRIT
  31. -INC CCGEOME
  32. -INC TMLCHA8
  33. -INC TMCOLAC
  34. -INC CCASSIS
  35. CHARACTER*8 TYPI,NOMI
  36.  
  37. C RECUPERE LES ARGUMENTS
  38.  
  39. IF (ICLE.EQ.0) THEN
  40.  
  41. CALL QUETYP(TYPI,0,IRET)
  42. IF (IRET.EQ.0) THEN
  43. * ERREUR => "Cet opérateur a encore besoin d'un opérande."
  44. CALL ERREUR(533)
  45. RETURN
  46. ENDIF
  47.  
  48. IF (TYPI.NE.'MAILLAGE' .AND.
  49. & TYPI.NE.'ENTIER' .AND.
  50. & TYPI.NE.'FLOTTANT') THEN
  51. * ERREUR => "On ne veut pas d'objet de type %m1:8"
  52. MOTERR(1:8)=TYPI
  53. CALL ERREUR(39)
  54. RETURN
  55. ENDIF
  56.  
  57. ENDIF
  58. ***********************************************************************
  59.  
  60.  
  61. MELEME=0
  62. MELEM2=0
  63. CALL LIRREE(XXX,0,IRETOU)
  64. IF (IRETOU.NE.0)THEN
  65. CRIT=XXX
  66. ELSE
  67. CRIT=DBLE(DENSIT)/10.D0
  68. ENDIF
  69. CRIT=ABS(CRIT)
  70. C Erreur 21 : Données incompatibles
  71. IF (CRIT.EQ.0.D0) CALL ERREUR(21)
  72. IF (IERR.NE.0) RETURN
  73. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  74. IF (IERR.NE.0) RETURN
  75. CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  76. IF(MELEM2.EQ.0) MELEM2=MELEME
  77. * ON REMET DANS LA PILE LE DERNIER MAILLAGE LU (POUR DALLER QUEL)
  78. IF(ICLE.EQ.0) CALL REFUS
  79. if( nbesc.ne.0) then
  80. mestra=imestr
  81. SEGACT MESTRA*MOD
  82. call ooofrc(1)
  83. call setass(1)
  84. endif
  85. SEGINI ICPR
  86. SEGINI IAPOB1
  87. SEGINI IAPOB2
  88. C
  89. C BOUCLE SUR LE PREMIER MAILLAGE REMPLI ICPR ET IAPOB1
  90. C
  91. ITE=0
  92. SEGACT MELEME
  93. DO 2 I=1,MAX(1,LISOUS(/1))
  94. IF (LISOUS(/1).NE.0) THEN
  95. IPT1=LISOUS(I)
  96. SEGACT IPT1
  97. ELSE
  98. IPT1=MELEME
  99. ENDIF
  100. DO 5 K=1,IPT1.NUM(/1)
  101. DO 51 L=1,IPT1.NUM(/2)
  102. M=IPT1.NUM(K,L)
  103. IF (ICPR(M).EQ.0) THEN
  104. ITE=ITE+1
  105. ICPR(M)=ITE
  106. ENDIF
  107. IAPOB1(ICPR(M))=1
  108. 51 CONTINUE
  109. 5 CONTINUE
  110. 2 CONTINUE
  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. 52 CONTINUE
  133. C
  134. C ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE
  135. C
  136. TYPI=' '
  137. K=-1
  138. CALL TYPFIL(TYPI,K)
  139. CALL CREPIL(ICOLAC,-K)
  140. M=1
  141. SEGINI MLCHA8
  142. MLCHAR(1)='MAILLAGE'
  143. CALL FILLPO(ICOLAC,MLCHA8)
  144. SEGSUP MLCHA8
  145. CALL FILLPI(ICOLAC)
  146. SEGACT ICOLAC
  147. C
  148. C BOUCLE SUR LES MAILLAGES ON CHERCHE LES ELEMENTS DE TYPE 22
  149. C ("MULT")
  150. C ON INDIQUE LEUR EXISTENCE DANS IAPOB1 AVEC LA VALEUR 2
  151. C
  152. ITLACC=KCOLA(1)
  153. SEGACT ITLACC
  154. DO 70 L=1,ITLAC(/1)
  155. MELEME=ITLAC(L)
  156. IF (MELEME.NE.0) THEN
  157. SEGACT MELEME
  158. DO 60 LL=1,MAX(1,LISOUS(/1))
  159. IF (LISOUS(/1).NE.0)THEN
  160. IPT1=LISOUS(LL)
  161. SEGACT IPT1
  162. ELSE
  163. IPT1=MELEME
  164. ENDIF
  165. IF (IPT1.ITYPEL .EQ. 22)THEN
  166. DO 55 LLL=1,IPT1.NUM(/2)
  167. C LE PREMIER NOEUD SUPPORTENT LES MULTIPLICATEURS
  168. IF (ICPR(IPT1.NUM(1,LLL)) .NE. 0)
  169. $ IAPOB1(ICPR(IPT1.NUM(1,LLL)))=2
  170. 55 CONTINUE
  171. ENDIF
  172. 60 CONTINUE
  173. ENDIF
  174. 70 CONTINUE
  175. C Supprime icolac et tous ses sous-objets (ITLACC...)
  176. CALL SUPPIL(ICOLAC,-1)
  177. C
  178. CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE)
  179. SEGSUP IAPOB2,IAPOB1,ICPR
  180. if(nbesc.ne.0) then
  181. mestra=imestr
  182. call ooofrc(0)
  183. call setass(0)
  184. SEGDES MESTRA
  185. endif
  186. END
  187.  
  188.  
  189.  
  190.  

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