Télécharger quepo1.eso

Retour à la liste

Numérotation des lignes :

  1. C QUEPO1 SOURCE PV 09/09/11 12:12:10 6503
  2. SUBROUTINE QUEPO1(ICHP1,IPSG,LMOT)
  3. C-----------------------------------------------------------------------
  4. C On teste le champoint ICHP1 afin de vérifier :
  5. C 1) qu'il est non partitionné
  6. C 2) qu'il a le bon nombre de composantes et/ou les bonnes composantes
  7. C 3) que son support géométrique est IPSG
  8. C-----------------------------------------------------------------------
  9. C
  10. C---------------------------
  11. C Parametres Entree/Sortie :
  12. C---------------------------
  13. C
  14. C E/ ICHP1 : Champoint à tester
  15. C E/ IPSG : Maillage de référence, en général de type POI1
  16. C Si IPSG = 0: pas de test sur le maiilage
  17. C E/S LMOT : En entrée (si LMOT > 0),
  18. C noms des composantes à tester
  19. C En sortie (si LMOT <= 0),
  20. C noms des composantes du CHPO
  21. C-----------------------------------------------------------------------
  22. C
  23. C Langage : ESOPE + FORTRAN77
  24. C
  25. C Auteurs : A. BECCANTINI
  26. C
  27. C-----------------------------------------------------------------------
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8 (A-H,O-Z)
  30. C
  31. -INC CCOPTIO
  32. -INC SMELEME
  33. -INC SMCHPOI
  34. -INC SMLMOTS
  35. -INC SMLENTI
  36. C
  37. C**** Variables de COOPTIO
  38. C
  39. C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  40. C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ
  41. C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES
  42. C & ,IECHO, IIMPI, IOSPI
  43. C & ,IDIM
  44. C & ,MCOORD
  45. C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  46. C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  47. C & ,NORINC,NORVAL,NORIND,NORVAD
  48. C & ,NUCROU, IPSAUV
  49. CC
  50. POINTEUR MLEORD.MLENTI, MLEPOI.MLENTI
  51. C
  52. INTEGER ICHP1, IPSG, LMOT, NSOUPO, NBCOMP, JGN, JGM
  53. & , IC, JG, NBCOM1, IC2, NBSOUS, N, NC, ICOLD, NGP
  54. & , NLP, NLPOLD
  55. CHARACTER*4 MOT1
  56. LOGICAL LOGORD
  57. C
  58. C- Test si le CHPO est partitionné
  59. C
  60. MCHPOI = ICHP1
  61. SEGACT MCHPOI
  62. NSOUPO = MCHPOI.IPCHP(/1)
  63. IF (NSOUPO.NE.1) THEN
  64. MOTERR(1:8) = 'CHAMPOIN'
  65. C
  66. C******** Message d'erreur standard
  67. C 132 2
  68. C On veut un objet %m1:8 élémentaire
  69. C
  70. CALL ERREUR(132)
  71. GOTO 9999
  72. ENDIF
  73. C
  74. C- Test/Récupération/Imposition du nom des composantes
  75. C
  76. MSOUPO = MCHPOI.IPCHP(1)
  77. SEGDES MCHPOI
  78. SEGACT MSOUPO*MOD
  79. NBCOMP = MSOUPO.NOCOMP(/2)
  80. IF(LMOT .LE. 0)THEN
  81. LOGORD = .TRUE.
  82. JG = NBCOMP
  83. SEGINI MLEORD
  84. C
  85. C******** Recuperation
  86. C
  87. JGN = 4
  88. JGM = NBCOMP
  89. SEGINI MLMOTS
  90. LMOT = MLMOTS
  91. DO IC = 1, NBCOMP, 1
  92. MLMOTS.MOTS(IC) = MSOUPO.NOCOMP(IC)
  93. MLEORD.LECT(IC) = IC
  94. ENDDO
  95. ELSE
  96. C
  97. C******** Test/imposition
  98. C
  99. MLMOTS = LMOT
  100. SEGACT MLMOTS
  101. NBCOM1 = MLMOTS.MOTS(/2)
  102. IF (NBCOM1.NE.NBCOMP) THEN
  103. MOTERR(1:8) = ' QUEPOI '
  104. MOTERR(9:16) = 'CHAMPOIN'
  105. INTERR(1) = NBCOM1
  106. INTERR(2) = NBCOMP
  107. C
  108. C********** Message d'erreur standard
  109. C 699 2
  110. C routine %m1:8 : On voulait un %m9:16 à %i1 composantes au lieu de %i2 .
  111. C
  112. CALL ERREUR(699)
  113. GOTO 9999
  114. ENDIF
  115. JG = NBCOMP
  116. LOGORD = .TRUE.
  117. SEGINI MLEORD
  118. DO IC = 1, NBCOMP, 1
  119. C
  120. C********** On cherche la position de chaque composante en MLMOTS
  121. C
  122. MOT1 = MSOUPO.NOCOMP(IC)
  123. DO IC2 = 1, NBCOMP, 1
  124. IF(MLMOTS.MOTS(IC2) .EQ. MOT1) THEN
  125. IF(IC2 .NE. IC) LOGORD= .FALSE.
  126. MLEORD.LECT(IC2) = IC
  127. GOTO 1
  128. ENDIF
  129. ENDDO
  130. C
  131. C********** On est la car on n'as pas de MOT1
  132. C Message d'erreur standard
  133. C 197 2
  134. C Le mot %m1:4 n'est pas un nom de composante reconnu
  135. C
  136. MOTERR(1:4)=MOT1
  137. CALL ERREUR(197)
  138. GOTO 9999
  139. C
  140. 1 CONTINUE
  141. ENDDO
  142. ENDIF
  143. C
  144. C- Transforme le maillage en POI1 si maillage quelconque
  145. C- Le maillage POI1 de pointeur IPT1 est actif au retour de CHANGE
  146. C
  147. IPT1 = MSOUPO.IGEOC
  148. IF(IPSG .EQ. 0)THEN
  149. MELEME = IPT1
  150. ELSE
  151. MELEME = IPSG
  152. ENDIF
  153. SEGACT MELEME
  154. NBSOUS = MELEME.LISOUS(/1)
  155. IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
  156. CALL CHANGE(MELEME,1)
  157. IF (IERR.NE.0) GOTO 9999
  158. ENDIF
  159. C
  160. C- Si égalité des pointeurs et LOGORD -> OK, sinon
  161. C
  162. IF (LOGORD .AND. (MELEME .EQ. IPT1)) THEN
  163. SEGDES MELEME
  164. SEGDES MLMOTS
  165. SEGSUP MLEORD
  166. SEGDES MSOUPO
  167. IF(MLEORD .GT. 0) SEGSUP MLEORD
  168. RETURN
  169. ELSE
  170. C
  171. C- Dans le cas d'un MELEME de POI1 création d'un CHPO de support
  172. C- géométrique le POI1 en question.
  173. C
  174. N = MELEME.NUM(/2)
  175. NC = NBCOMP
  176. SEGINI MPOVA1
  177. MPOVAL = MSOUPO.IPOVAL
  178. SEGACT MPOVAL
  179. C
  180. C- Recherche si les points du MELEME de type POI1 sont dans le CHPO
  181. C- et ordonnencement
  182. C
  183. CALL KRIPAD(IPT1,MLEPOI)
  184. C SEGACT MLEPOI
  185. DO IC = 1, NC, 1
  186. ICOLD = MLEORD.LECT(IC)
  187. MSOUPO.NOCOMP(IC) = MLMOTS.MOTS(IC)
  188. DO NLP = 1, N, 1
  189. NGP = MELEME.NUM(1,NLP)
  190. NLPOLD = MLEPOI.LECT(NGP)
  191. IF(NLPOLD .EQ. 0)THEN
  192. MOTERR(1:8) = 'CHAMPOIN'
  193. MOTERR(9:16) = 'MAILLAGE'
  194. INTERR(1) = 1
  195. CALL ERREUR(698)
  196. GOTO 9999
  197. C
  198. C**************** Message d'erreur standard
  199. C 698 2
  200. C Incohérence entre les pointeurs géométriques des objets %m1:8 et %m9:16
  201. C 698 2
  202. C pour la zone élémentaire numéro %i1.
  203. C
  204. ELSE
  205. MPOVA1.VPOCHA(NLP,IC)=MPOVAL.VPOCHA(NLPOLD,ICOLD)
  206. ENDIF
  207. ENDDO
  208. ENDDO
  209. SEGDES MPOVA1
  210. MSOUPO.IGEOC=MELEME
  211. MSOUPO.IPOVAL=MPOVA1
  212. SEGDES MSOUPO
  213. SEGSUP MLEORD
  214. SEGSUP MLEPOI
  215. ENDIF
  216. 9999 CONTINUE
  217. RETURN
  218. END
  219.  
  220.  
  221.  
  222.  
  223.  

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