Télécharger exelch.eso

Retour à la liste

Numérotation des lignes :

  1. C EXELCH SOURCE CB215821 19/08/20 21:17:25 10287
  2. *
  3. * EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS
  4. * COMPOSANTES D'UN CHAMP/ELEMENT
  5. *
  6. ************************************************************************
  7. * ENTREES :
  8. *
  9. * IPCHEL =POINTEUR SUR UN MCHAML
  10. * IMM = 1 MAXI , 2 MINI , 3 A 9 LES AUTRES
  11. * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES
  12. * IAV = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES,
  13. * 2 ILS SONT EXCLUS
  14. * ILAST = 1 STRICTEMENT (Tous les PTS de Gauss doivent respecter la condition)
  15. * = 2 LARGEMENT (Un seul PT de Gauss doit respecter la condition)
  16. * IPLIS = POINTEUR SUR UN LISTMOTS
  17. * VALREF = VALEUR POUR FAIRE LES COMPARAISONS
  18. * VALRE2 = IDEM POUR OPTION 'COMPRIS'
  19. *
  20. * SORTIES :
  21. *
  22. * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS
  23. * SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS
  24. * PAR RAPPORT A VALREF
  25. *
  26. * P DOWLATYARI OCT 91
  27. ************************************************************************
  28. SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,
  29. & IPMAIL)
  30.  
  31. IMPLICIT INTEGER(I-N)
  32. IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC CCOPTIO
  35. -INC CCREEL
  36.  
  37. -INC SMCHAML
  38. -INC SMELEME
  39. -INC SMLMOTS
  40.  
  41. SEGMENT QUELCO
  42. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS),IMEL(NSOUS)
  43. ENDSEGMENT
  44.  
  45. SEGMENT MMEL
  46. INTEGER NELC,LELC(NBELC)
  47. ENDSEGMENT
  48.  
  49. SEGMENT MESH
  50. INTEGER LMAIL(NMAIL,3+NSOUS)
  51. ENDSEGMENT
  52.  
  53. LOGICAL BOOL1
  54. CHARACTER*8 MOCOMP
  55.  
  56. * INITIALISATIONS
  57. IPMAIL = 0
  58. *
  59. IMAIL = 0
  60. QUELCO = 0
  61. MESH = 0
  62.  
  63. * VERIFICATIONS D'USAGE (normalement inutiles) :
  64. IF (IMM.LT.1 .OR. IMM.GT.9) THEN
  65. write(ioimp,*) 'EXELCH IMM =',IMM
  66. CALL ERREUR(5)
  67. RETURN
  68. ENDIF
  69. IF (IAB.LT.0 .OR. IAB.GT.1) THEN
  70. write(ioimp,*) 'EXELCH IAB =',IAB
  71. CALL ERREUR(5)
  72. RETURN
  73. ENDIF
  74. IF (IAV.LT.1 .OR. IAV.GT.2) THEN
  75. write(ioimp,*) 'EXELCH IAV =',IAV
  76. CALL ERREUR(5)
  77. RETURN
  78. ENDIF
  79. IF (ILAST.LT.1 .OR. ILAST.GT.2) THEN
  80. write(ioimp,*) 'EXELCH ILAST =',ILAST
  81. CALL ERREUR(5)
  82. RETURN
  83. ENDIF
  84.  
  85. * ON RECUPERE LE CHAMP PAR ELEMENT
  86. *
  87. MCHELM = IPCHEL
  88. SEGACT,MCHELM
  89. NSOUS = mchelm.IMACHE(/1)
  90. * MCHAML vide -> Maillage vide en sortie
  91. IF (NSOUS.EQ.0) GOTO 90
  92.  
  93. * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES
  94. *
  95. NCOMX = 0
  96. DO 10 ISOUS = 1, NSOUS
  97. mchaml = mchelm.ICHAML(ISOUS)
  98. SEGACT,mchaml
  99. NCOMX = MAX(NCOMX,mchaml.NOMCHE(/2))
  100. 10 CONTINUE
  101. * MCHAML sans composante -> Maillage vide en sortie
  102. IF (NCOMX.EQ.0) GOTO 90
  103. SEGINI,QUELCO
  104.  
  105. * Remplissage de QUELCO qui indique les composantes a prendre en compte
  106. * sur chaque sous-zone
  107. * Par defaut, on prend toutes les composantes, sauf si la listmots est
  108. * fournie, et dans ce cas, on conserve ou on exclut les composantes.
  109. *
  110. IF (IPLIS.NE.0) THEN
  111. mlmots = IPLIS
  112. SEGACT,mlmots
  113. NCLIS = mlmots.MOTS(/2)
  114. ENDIF
  115.  
  116. NZERO = NSOUS
  117. DO 20 ISOUS = 1, NSOUS
  118. MELEME = mchelm.IMACHE(ISOUS)
  119. MCHAML = mchelm.ICHAML(ISOUS)
  120. NCOMP = mchaml.NOMCHE(/2)
  121. IF (IPLIS.EQ.0) THEN
  122. DO ICOMP = 1, NCOMP
  123. quelco.ICO(ISOUS,ICOMP) = 1
  124. ENDDO
  125. NCO = NCOMP
  126. ELSE
  127. NCO = 0
  128. DO ICOMP = 1, NCOMP
  129. MOCOMP = mchaml.NOMCHE(ICOMP)
  130. CALL PLACE(mlmots.MOTS,NCLIS,IX,MOCOMP)
  131. igco = 0
  132. IF (IAV.EQ.1) THEN
  133. IF (IX.NE.0) igco = 1
  134. ELSE
  135. IF (IX.EQ.0) igco = 1
  136. ENDIF
  137. quelco.ICO(ISOUS,ICOMP) = igco
  138. NCO = NCO + igco
  139. ENDDO
  140. ENDIF
  141. quelco.NNCO(ISOUS) = NCO
  142. IF (NCO.NE.0) THEN
  143. c* On verifie si MELEME n'a pas deja ete rencontre dans les sous-zones
  144. c* precedentes...
  145. mmel = 0
  146. DO ISZ = ISOUS-1, 1, -1
  147. IF (meleme.EQ.mchelm.IMACHE(ISZ)) THEN
  148. mmel = -ABS(quelco.IMEL(ISZ))
  149. ENDIF
  150. ENDDO
  151. IF (mmel.EQ.0) THEN
  152. SEGACT,meleme
  153. NBELC = meleme.NUM(/2)
  154. SEGINI,mmel
  155. ENDIF
  156. ELSE
  157. mmel = 0
  158. NZERO = NZERO - 1
  159. ENDIF
  160. quelco.IMEL(ISOUS) = mmel
  161. 20 CONTINUE
  162.  
  163. * Cas particulier ou aucune composante n'est a traiter -> Maillage Vide
  164. IF (NZERO.EQ.0) GOTO 90
  165.  
  166. * RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 )
  167. *
  168. IF (IMM.LE.2) THEN
  169. IF (IMM.EQ.1) THEN
  170. IF (IAB.EQ.0) THEN
  171. XEXT = -XGRAND
  172. ELSE
  173. XEXT = XZERO
  174. ENDIF
  175. ELSE
  176. XEXT = XGRAND
  177. ENDIF
  178.  
  179. DO 30 ISOUS = 1, NSOUS
  180. IF (quelco.NNCO(ISOUS).EQ.0) GOTO 30
  181. MCHAML = mchelm.ICHAML(ISOUS)
  182. NCOMP = mchaml.NOMCHE(/2)
  183. DO 310 ICOMP = 1, NCOMP
  184. IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 310
  185. melval = mchaml.IELVAL(ICOMP)
  186. SEGACT,melval
  187. NBPTEL = melval.VELCHE(/1)
  188. NEL = melval.VELCHE(/2)
  189. DO 320 IB = 1, NEL
  190. DO 320 IGAU = 1,NBPTEL
  191. XX = melval.VELCHE(IGAU,IB)
  192. IF (IAB.EQ.1) XX = ABS(XX)
  193. IF (IMM.EQ.1) THEN
  194. XEXT = MAX(XX,XEXT)
  195. ELSE
  196. XEXT = MIN(XX,XEXT)
  197. ENDIF
  198. 320 CONTINUE
  199. 310 CONTINUE
  200. 30 CONTINUE
  201. ENDIF
  202.  
  203. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  204. *
  205. DO 40 ISOUS = 1, NSOUS
  206. IF (quelco.NNCO(ISOUS).EQ.0) GOTO 40
  207. mmel = ABS(quelco.IMEL(ISOUS))
  208. * segact,mmel
  209. NBELC = mmel.LELC(/1)
  210. c* Si NELC = NBELC c'est que tous les elements du maillage sont deja
  211. c* pris auparavant (meleme commun a plusieurs sous-zones) donc on
  212. c* ne poursuit plus le traitement pour cette sous-zone...
  213. IF (mmel.NELC.EQ.NBELC) GOTO 40
  214. MCHAML = mchelm.ICHAML(ISOUS)
  215. NCOMP = mchaml.NOMCHE(/2)
  216. DO 410 ICOMP = 1, NCOMP
  217. IF (quelco.ICO(ISOUS,ICOMP).EQ.0) GOTO 410
  218. c* Si NELC = NBELC c'est que tous les elements sont deja pris pour
  219. c* les precedentes composantes de cette sous-zone...
  220. IF (mmel.NELC.EQ.NBELC) GOTO 40
  221. melval = mchaml.IELVAL(ICOMP)
  222. SEGACT,melval
  223. NBPTEL = melval.VELCHE(/1)
  224. NEL = melval.VELCHE(/2)
  225. c* Normalement : NEL = 1 ou NEL = NBELC (a verifier ?)
  226. DO 420 IB = 1, NBELC
  227. C* Si l'element a deja ete retenu, ce n'est pas la peine de continuer...
  228. IF (mmel.LELC(IB).EQ.1) GOTO 420
  229. IBMN = MIN(IB,NEL)
  230. igco = 0
  231. DO 430 IGAU = 1, NBPTEL
  232. XX = melval.VELCHE(IGAU,IBMN)
  233. IF (IAB.EQ.1) XX = ABS(XX)
  234.  
  235. * TRI SELON LA VALEUR DE IMM
  236. GOTO (21,21,23,24,25,26,27,28,29),IMM
  237. c* Erreur ne devant pas arriver normalement (voir test au debut)
  238. CALL ERREUR(5)
  239. GOTO 9000
  240.  
  241. * MAXI OU MINI
  242. 21 BOOL1 = (XX.EQ.XEXT)
  243. GOTO 425
  244. * SUPE
  245. 23 BOOL1 = (XX.GT.VALREF)
  246. GOTO 425
  247. * EGSUPE
  248. 24 BOOL1 = (XX.GE.VALREF)
  249. GOTO 425
  250. * EGAL
  251. 25 BOOL1 = (XX.EQ.VALREF)
  252. GOTO 425
  253. * EGINFE
  254. 26 BOOL1 = (XX.LE.VALREF)
  255. GOTO 425
  256. * INFE
  257. 27 BOOL1 = (XX.LT.VALREF)
  258. GOTO 425
  259. * DIFF
  260. 28 BOOL1 = (XX.NE.VALREF)
  261. GOTO 425
  262. * COMP
  263. 29 BOOL1 = (XX.GE.VALREF) .AND. (XX.LE.VALRE2)
  264. GOTO 425
  265. *
  266. 425 CONTINUE
  267. IF (BOOL1) THEN
  268. igco = igco + 1
  269. C On prend l'element au premier rencontre car LARG
  270. IF (ILAST.EQ.2) GOTO 435
  271. ELSE
  272. C On change d''element si 'STRI'
  273. IF (ILAST.EQ.1) GOTO 420
  274. ENDIF
  275. 430 CONTINUE
  276. 435 IF (igco.GT.0) THEN
  277. mmel.LELC(IB) = 1
  278. mmel.NELC = mmel.NELC + 1
  279. ENDIF
  280. 420 CONTINUE
  281. 410 CONTINUE
  282. 40 CONTINUE
  283.  
  284. C* Il faut maintenant construire le maillage correspondant :
  285. NMAIL = NSOUS
  286. SEGINI,MESH
  287. IMAIL = 0
  288. DO 500 ISOUS = 1, NSOUS
  289. mmel = quelco.IMEL(ISOUS)
  290. IF (mmel.LE.0) GOTO 500
  291. * segact,mmel
  292. IF (mmel.NELC.EQ.0) GOTO 500
  293. ipt1 = mchelm.IMACHE(ISOUS)
  294. * segact,ipt1
  295. ity1 = ipt1.ITYPEL
  296. nbn1 = ipt1.NUM(/1)
  297. DO im = 1, IMAIL
  298. IF (ity1.EQ.mesh.LMAIL(im,1) .AND.
  299. & nbn1.EQ.mesh.LMAIL(im,2)) THEN
  300. C* Le 2e test sert dans le cas particulier des elements SURE pour
  301. C* lesquels itypel=48 mais le nombre de noeuds variables !
  302. IMSH = im
  303. GOTO 510
  304. ENDIF
  305. ENDDO
  306. IMAIL = IMAIL + 1
  307. IMSH = IMAIL
  308. mesh.LMAIL(IMSH,1) = ity1
  309. mesh.LMAIL(IMSH,2) = nbn1
  310. mesh.LMAIL(IMSH,3) = 0
  311. 510 CONTINUE
  312. mesh.LMAIL(IMSH,3+ISOUS) = mesh.LMAIL(IMSH,3) + 1
  313. mesh.LMAIL(IMSH,3) = mesh.LMAIL(IMSH,3) + mmel.NELC
  314. 500 CONTINUE
  315. *
  316. * Cas particulier : le maillage resultat est vide
  317. 90 CONTINUE
  318. IF (IMAIL.EQ.0) THEN
  319. NBNN = 0
  320. NBELEM = 0
  321. NBSOUS = 0
  322. NBREF = 0
  323. SEGINI,meleme
  324. meleme.ITYPEL = 0
  325. ELSE
  326. IF (IMAIL.GT.1)THEN
  327. NBNN = 0
  328. NBELEM = 0
  329. NBSOUS = IMAIL
  330. NBREF = 0
  331. SEGINI,meleme
  332. ENDIF
  333. DO 600 IMSH = 1, IMAIL
  334. NBNN = mesh.LMAIL(IMSH,2)
  335. NBELEM = mesh.LMAIL(IMSH,3)
  336. NBSOUS = 0
  337. NBREF = 0
  338. SEGINI,ipt3
  339. ipt3.ITYPEL = mesh.LMAIL(IMSH,1)
  340. js = 0
  341. jm = 0
  342. DO 610 ISOUS = 1, NSOUS
  343. im = mesh.LMAIL(IMSH,3+ISOUS)
  344. IF (im.EQ.0) GOTO 610
  345. im = im - 1
  346. ipt2 = mchelm.IMACHE(ISOUS)
  347. NBEL2 = ipt2.NUM(/2)
  348. mmel = quelco.IMEL(ISOUS)
  349. c* Quelques tests de verification/debogage au cas ou :
  350. if (mmel.LE.0) then
  351. write(ioimp,*) 'exelch : err 610 mmel',mmel,isous,imsh
  352. call erreur(5)
  353. endif
  354. nbnn2 = ipt2.NUM(/1)
  355. if (nbnn2.NE.nbnn) then
  356. write(ioimp,*) 'exelch : err 610 nbnn',nbnn2,nbnn,isous,imsh
  357. call erreur(5)
  358. endif
  359. nbelc = mmel.LELC(/1)
  360. if (NBEL2.NE.nbelc) then
  361. write(ioimp,*) 'exelch : err 610 nbel',nbelc,nbel2,isous,imsh
  362. call erreur(5)
  363. endif
  364. js = js + 1
  365. DO 620 IB = 1, NBEL2
  366. IF (mmel.LELC(IB).EQ.0) GOTO 620
  367. im = im + 1
  368. jm = jm + 1
  369. DO igau = 1, NBNN
  370. ipt3.NUM(igau,im) = ipt2.NUM(igau,IB)
  371. ENDDO
  372. ipt3.ICOLOR(im) = ipt2.ICOLOR(IB)
  373. 620 CONTINUE
  374. 610 CONTINUE
  375. if (jm.ne.NBELEM) then
  376. write(ioimp,*) 'exelch : incoherence jm',jm,nbelem,imsh
  377. call erreur(5)
  378. endif
  379. IF (js.GT.1) THEN
  380. CALL UNIQM1(ipt3,ipt1,nbdif)
  381. IF (IPT1.NE.IPT3) SEGSUP,ipt3
  382. c* if (ipt1.eq.0) then
  383. c* write(ioimp,*) 'exelch : maillage vide',imsh
  384. c* endif
  385. ELSE
  386. ipt1 = ipt3
  387. ENDIF
  388. IF (IMAIL.GT.1) THEN
  389. meleme.LISOUS(IMSH) = ipt1
  390. ENDIF
  391. 600 CONTINUE
  392. IF (IMAIL.EQ.1) meleme = ipt1
  393. ENDIF
  394. IPMAIL = meleme
  395. IF (mesh.NE.0) SEGSUP,mesh
  396.  
  397. 9000 CONTINUE
  398. DO ISOUS = 1, NSOUS
  399. meleme = mchelm.IMACHE(ISOUS)
  400. mchaml = mchelm.ICHAML(ISOUS)
  401. mmel = quelco.IMEL(ISOUS)
  402. IF (mmel.GT.0) SEGSUP,mmel
  403. ENDDO
  404. IF (quelco.NE.0) SEGSUP,quelco
  405.  
  406. END
  407.  
  408.  
  409.  

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