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

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