Télécharger expche.eso

Retour à la liste

Numérotation des lignes :

  1. C EXPCHE SOURCE PV 09/03/12 21:22:01 6325
  2. SUBROUTINE EXPCHE(IPCHEL,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL)
  3. *
  4. * EXTRAIRE LE OU LES POINTS SUPPORTS DU MAXI OU DU MINI DES VALEURS DE
  5. * COMPOSANTES D'UN CHAMP/ELEMENT
  6. *
  7. ************************************************************************
  8. * ENTREES :
  9. *
  10. * IPCHEL =POINTEUR SUR UN MCHAML
  11. * IMM = 1 MAXI , 2 MINI , 3 A 8 AUTRES
  12. * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES
  13. * IAV = 1 LES NOMS DE LA LISEMOTS SONT CONSIDERES ,2 ILS SONT EXC
  14. * IPLIS = POINTEUR SUR UN LISTMOTS
  15. * VALREF = VALEUR DE REFERENCE
  16. * VALRE2 = IDEM POUR OPTION COMPRIS
  17. *
  18. * SORTIES :
  19. *
  20. * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES POINTS
  21. * SUPPORTS DU MAXI OU DU MINI
  22. *
  23. * P DOWLATYARI OCT 91
  24. ************************************************************************
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. *
  28. -INC CCOPTIO
  29. -INC SMCHAML
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC SMLMOTS
  33. -INC SMINTE
  34. *
  35. SEGMENT QUELCO
  36. INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS)
  37. ENDSEGMENT
  38. *
  39. SEGMENT MTRA
  40. REAL*8 XE(3,NBNN1)
  41. ENDSEGMENT
  42. *
  43. CHARACTER*4 MOCOMP
  44. *
  45. * INITIALISATIONS
  46. *
  47. IF(IAB.EQ.0)THEN
  48. IF(IMM.EQ.1)THEN
  49. XEXT=-1.D35
  50. ELSE
  51. XEXT=1.D35
  52. ENDIF
  53. ELSE
  54. IF(IMM.EQ.1)THEN
  55. XEXT=0.D0
  56. ELSE
  57. XEXT=1.D35
  58. ENDIF
  59. ENDIF
  60. *
  61. IF(IPLIS.NE.0)THEN
  62. MLMOTS=IPLIS
  63. SEGACT MLMOTS
  64. NC=MOTS(/2)
  65. ENDIF
  66. C
  67. C ON RECUPERE LE CHAMELEM
  68. C
  69. MCHELM=IPCHEL
  70. SEGACT MCHELM
  71. NSOUS=IMACHE(/1)
  72.  
  73. *
  74. * ON CHERCHE LE NOMBRE MAXIMALE DE COMPOSANTES
  75. *
  76. NCOMX = 0
  77. DO 10 ISOUS=1,NSOUS
  78. MCHAML=ICHAML(ISOUS)
  79. SEGACT MCHAML
  80. NCOMX=MAX(NCOMX,NOMCHE(/2))
  81. 10 CONTINUE
  82. *
  83. IF(IPLIS.NE.0)SEGINI QUELCO
  84. *
  85. * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI
  86. *
  87. DO 500 ISOUS=1,NSOUS
  88. *
  89. MCHAML=ICHAML(ISOUS)
  90. NCOMP=NOMCHE(/2)
  91. IF(IPLIS.NE.0)THEN
  92. NCO=0
  93. DO 20 ICOMP=1,NCOMP
  94. MOCOMP=NOMCHE(ICOMP)
  95. CALL PLACE(MOTS,NC,IX,MOCOMP)
  96. IF(IAV.EQ.1)THEN
  97. IF(IX.NE.0)THEN
  98. ICO(ISOUS,ICOMP)=1
  99. NCO=NCO+1
  100. ELSE
  101. ICO(ISOUS,ICOMP)=0
  102. ENDIF
  103. ELSE
  104. IF(IX.EQ.0)THEN
  105. ICO(ISOUS,ICOMP)=1
  106. NCO=NCO+1
  107. ELSE
  108. ICO(ISOUS,ICOMP)=0
  109. ENDIF
  110. ENDIF
  111. 20 CONTINUE
  112. NNCO(ISOUS)=NCO
  113. ENDIF
  114. *
  115. IF(IMM.LE.2) THEN
  116. IF(IPLIS.EQ.0)THEN
  117. DO 100 ICOMP=1,NCOMP
  118. MELVAL=IELVAL(ICOMP)
  119. SEGACT MELVAL
  120. NEL=VELCHE(/2)
  121. NBPTEL=VELCHE(/1)
  122. DO 200 IB=1,NEL
  123. DO 200 IGAU=1,NBPTEL
  124. XX=VELCHE(IGAU,IB)
  125. IF(IAB.EQ.1) XX = ABS(XX)
  126. IF(IMM.EQ.1)THEN
  127. XEXT=MAX(XX,XEXT)
  128. ELSE
  129. XEXT=MIN(XX,XEXT)
  130. ENDIF
  131. 200 CONTINUE
  132. SEGDES MELVAL
  133. 100 CONTINUE
  134. ELSEIF(NCO.NE.0)THEN
  135. DO 110 ICOMP=1,NCOMP
  136. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  137. MELVAL=IELVAL(ICOMP)
  138. SEGACT MELVAL
  139. NEL=VELCHE(/2)
  140. NBPTEL=VELCHE(/1)
  141. DO 210 IB=1,NEL
  142. DO 210 IGAU=1,NBPTEL
  143. XX=VELCHE(IGAU,IB)
  144. IF(IAB.EQ.1) XX = ABS(XX)
  145. IF(IMM.EQ.1)THEN
  146. XEXT=MAX(XX,XEXT)
  147. ELSE
  148. XEXT=MIN(XX,XEXT)
  149. ENDIF
  150. 210 CONTINUE
  151. SEGDES MELVAL
  152. ENDIF
  153. 110 CONTINUE
  154. ENDIF
  155. ENDIF
  156. SEGDES MCHAML
  157. 500 CONTINUE
  158. *
  159. IF(IPLIS.NE.0)THEN
  160. SEGDES MLMOTS
  161. NZERO=0
  162. DO 510 ISOUS=1,NSOUS
  163. IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1
  164. 510 CONTINUE
  165. IF(NZERO.EQ.NSOUS)THEN
  166. CALL ERREUR(280)
  167. SEGDES MCHELM
  168. SEGSUP QUELCO
  169. IPMAIL=0
  170. RETURN
  171. ENDIF
  172. ENDIF
  173. *
  174. * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS
  175. *
  176. NBNN=1
  177. NBELEM=XCOOR(/1)/(IDIM+1)
  178. NBTEST=NBELEM
  179. NBSOUS=0
  180. NBREF=0
  181. SEGINI MELEME
  182. IPMAIL=MELEME
  183. ITYPEL=1
  184. NBELEM=0
  185. *
  186. * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS
  187. *
  188. DO 600 ISOUS=1,NSOUS
  189. *
  190. MCHAML=ICHAML(ISOUS)
  191. SEGACT MCHAML
  192. NCOMP=NOMCHE(/2)
  193. MINTE=INFCHE(ISOUS,4)
  194. IF(MINTE.NE.0)THEN
  195. SEGACT MINTE
  196. NBNO=SHPTOT(/2)
  197. ENDIF
  198. IPT1=IMACHE(ISOUS)
  199. SEGACT IPT1
  200. NBNN1=IPT1.NUM(/1)
  201. IF(MINTE.NE.0)SEGINI MTRA
  202. IF(IPLIS.EQ.0)THEN
  203. DO 300 ICOMP=1,NCOMP
  204. MELVAL=IELVAL(ICOMP)
  205. SEGACT MELVAL
  206. NBPTEL=VELCHE(/1)
  207. NEL=VELCHE(/2)
  208. DO 400 IB=1,NEL
  209. DO 400 IGAU=1,NBPTEL
  210. XX=VELCHE(IGAU,IB)
  211. IF(IAB.EQ.1)XX=ABS(XX)
  212. *
  213. * TRI SELON LA VALEUR DE IMM
  214. *
  215. GO TO (21,21,23,24,25,26,27,28,29),IMM
  216. *
  217. CALL ERREUR(280)
  218. SEGDES MCHELM
  219. SEGSUP QUELCO
  220. IPMAIL=0
  221. RETURN
  222. *
  223. * MAXI OU MINI
  224. 21 IF(XX.EQ.XEXT) GO TO 403
  225. GO TO 400
  226. *
  227. * SUPE
  228. 23 IF(XX.GT.VALREF) GO TO 403
  229. GO TO 400
  230. *
  231. * EGSUPE
  232. 24 IF(XX.GE.VALREF) GO TO 403
  233. GO TO 400
  234. *
  235. * EGAL
  236. 25 IF(XX.EQ.VALREF) GO TO 403
  237. GO TO 400
  238. *
  239. * EGINFE
  240. 26 IF(XX.LE.VALREF) GO TO 403
  241. GO TO 400
  242. *
  243. * INFE
  244. 27 IF(XX.LT.VALREF) GO TO 403
  245. GO TO 400
  246. *
  247. * DIFF
  248. 28 IF(XX.NE.VALREF) GO TO 403
  249. GO TO 400
  250. *
  251. * COMP
  252. 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2))GO TO 403
  253. GO TO 400
  254. *
  255. 403 CONTINUE
  256. NBELEM=NBELEM+1
  257. IF(NBELEM.GT.NBTEST) THEN
  258. NBTEST=NBELEM
  259. NBELEM = NBELEM*2
  260. SEGADJ MELEME
  261. NBELEM=NBTEST
  262. NBTEST= NUM(/2)
  263. ENDIF
  264. IF(MINTE.EQ.0)THEN
  265. NUM(1,NBELEM)=IPT1.NUM(IGAU,IB)
  266. ELSE
  267. CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE)
  268. XC=0.D0
  269. YC=0.D0
  270. ZC=0.D0
  271. DO 405 IE=1,NBNN1
  272. XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE)
  273. YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE)
  274. ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE)
  275. 405 CONTINUE
  276. NBPTS=XCOOR(/1)/(IDIM+1)
  277. NBPTS=NBPTS+1
  278. SEGADJ MCOORD
  279. XCOOR((NBPTS-1)*(IDIM+1)+1)=XC
  280. XCOOR((NBPTS-1)*(IDIM+1)+2)=YC
  281. IF(IDIM.EQ.3)
  282. 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC
  283. NUM(1,NBELEM)=NBPTS
  284. ENDIF
  285. *
  286. 400 CONTINUE
  287. SEGDES MELVAL
  288. 300 CONTINUE
  289. *
  290. ELSEIF(NNCO(ISOUS).NE.0)THEN
  291. DO 310 ICOMP=1,NCOMP
  292. IF(ICO(ISOUS,ICOMP).EQ.1)THEN
  293. MELVAL=IELVAL(ICOMP)
  294. SEGACT MELVAL
  295. NBPTEL=VELCHE(/1)
  296. NEL=VELCHE(/2)
  297. DO 410 IB=1,NEL
  298. DO 410 IGAU=1,NBPTEL
  299. XX=VELCHE(IGAU,IB)
  300. IF(IAB.EQ.1)XX=ABS(XX)
  301. *
  302. * TRI SELON LA VALEUR DE IMM
  303. *
  304. GO TO (31,31,33,34,35,36,37,38,39),IMM
  305. *
  306. CALL ERREUR(280)
  307. SEGDES MELVAL
  308. SEGDES MCHELM
  309. SEGSUP QUELCO
  310. IPMAIL=0
  311. RETURN
  312. *
  313. * MAXI OU MINI
  314. 31 IF(XX.EQ.XEXT) GO TO 413
  315. GO TO 410
  316. *
  317. * SUPE
  318. 33 IF(XX.GT.VALREF) GO TO 413
  319. GO TO 410
  320. *
  321. * EGSUPE
  322. 34 IF(XX.GE.VALREF) GO TO 413
  323. GO TO 410
  324. *
  325. * EGAL
  326. 35 IF(XX.EQ.VALREF) GO TO 413
  327. GO TO 410
  328. *
  329. * EGINFE
  330. 36 IF(XX.LE.VALREF) GO TO 413
  331. GO TO 410
  332. *
  333. * INFE
  334. 37 IF(XX.LT.VALREF) GO TO 413
  335. GO TO 410
  336. *
  337. * DIFF
  338. 38 IF(XX.NE.VALREF) GO TO 413
  339. GO TO 410
  340. *
  341. * COMP
  342. 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2))GO TO 413
  343. GO TO 410
  344. *
  345. 413 CONTINUE
  346. NBELEM=NBELEM+1
  347. IF(NBELEM.GT.NBTEST) THEN
  348. NBTEST=NBELEM
  349. NBELEM = NBELEM*2
  350. SEGADJ MELEME
  351. NBELEM=NBTEST
  352. NBTEST= NUM(/2)
  353. ENDIF
  354. IF(MINTE.EQ.0)THEN
  355. NUM(1,NBELEM)=IPT1.NUM(IGAU,IB)
  356. ELSE
  357. CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE)
  358. XC=0.D0
  359. YC=0.D0
  360. ZC=0.D0
  361. DO 406 IE=1,NBNN1
  362. XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE)
  363. YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE)
  364. ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE)
  365. 406 CONTINUE
  366. NBPTS=XCOOR(/1)/(IDIM+1)
  367. NBPTS=NBPTS+1
  368. SEGADJ MCOORD
  369. XCOOR((NBPTS-1)*(IDIM+1)+1)=XC
  370. XCOOR((NBPTS-1)*(IDIM+1)+2)=YC
  371. IF(IDIM.EQ.3)
  372. 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC
  373. NUM(1,NBELEM)=NBPTS
  374. ENDIF
  375. 410 CONTINUE
  376. SEGDES MELVAL
  377. ENDIF
  378. 310 CONTINUE
  379. *
  380. ENDIF
  381. SEGDES,MCHAML,IPT1
  382. IF(MINTE.NE.0)SEGDES MINTE
  383. IF(MINTE.NE.0)SEGSUP MTRA
  384. *
  385. 600 CONTINUE
  386. SEGADJ MELEME
  387. SEGDES MCHELM,MELEME
  388. IF(IPLIS.NE.0)SEGSUP QUELCO
  389. RETURN
  390. END
  391.  
  392.  
  393.  
  394.  
  395.  

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