Télécharger hhoext.eso

Retour à la liste

Numérotation des lignes :

hhoext
  1. C HHOEXT SOURCE OF166741 24/06/19 21:15:06 11942
  2. C HHOEXT SOURCE FANDEUR
  3. C
  4. SUBROUTINE HHOEXT (IPMODL,chopt, IPOBJ,chobj, iret)
  5.  
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11.  
  12. -INC CCHHOPA
  13. -INC CCHHOPR
  14.  
  15. -INC SMCOORD
  16. -INC SMMODEL
  17. -INC SMELEME
  18. -INC SMLENTI
  19.  
  20. CHARACTER*(*) chopt,chobj
  21.  
  22. CHARACTER*(4) motopt
  23. c* CHARACTER*(16) motHHO
  24.  
  25. EXTERNAL LONG
  26.  
  27. iret = 0
  28. IPOBJ = 0
  29. chobj = '__VIDE__'
  30.  
  31. IF (IDIM.NE.2) THEN
  32. iret = 5
  33. RETURN
  34. END IF
  35.  
  36. n_z = LONG(chopt)
  37. CALL CHCASS(chopt(1:n_z),1,chopt(1:n_z))
  38. IF (chopt(1:4).NE.'HHO_') THEN
  39. write(ioimp,*) 'HHOEXT: incorrect keyword ',chopt(1:4)
  40. iret = 21
  41. RETURN
  42. END IF
  43. motopt(1:4) = chopt(5:8)
  44. IF ( (motopt.NE.'FACE') .AND. (motopt.NE.'PFAC') .AND.
  45. & (motopt.NE.'PCEL') ) THEN
  46. write(ioimp,*) 'HHOEXT: incorrect keyword ',motopt
  47. iret = 21
  48. RETURN
  49. END IF
  50.  
  51. mmodel = IPMODL
  52. c* segact,mmodel*nomod (segment actif en entree)
  53. NSOUM = mmodel.kmodel(/1)
  54.  
  55. NSOHHO = 0
  56. DO im = 1, NSOUM
  57. imodel = mmodel.kmodel(im)
  58. IF (imodel.nefmod .EQ. HHO_NUM_ELEMENT) NSOHHO = NSOHHO + 1
  59. END DO
  60.  
  61. C= Cas Particulier : pas de HHO dans le MMODEL -> Maillage VIDE
  62. IF (NSOHHO.EQ.0) THEN
  63. nbnn = 1
  64. nbelem = 0
  65. nbsous = 0
  66. nbref = 0
  67. SEGINI,ipt1
  68. ipt1.itypel = 1
  69. IPOBJ = ipt1
  70. chobj = 'MAILLAGE'
  71. RETURN
  72. END IF
  73.  
  74. C= EXTRACTION DES POINTS SUPPORTS DES DDLS DES FACES / CELLULES :
  75. IF ((motopt.EQ.'PFAC') .OR. (motopt.EQ.'PCEL')) THEN
  76. IF (motopt.EQ.'PFAC') THEN
  77. ipt2 = MPFHHO
  78. iel1 = NFAHHO
  79. indhho = 2
  80. END IF
  81. IF (motopt.EQ.'PCEL') THEN
  82. ipt2 = MPCHHO
  83. iel1 = NCEHHO
  84. indhho = 4
  85. END IF
  86. c* segact,ipt2
  87.  
  88. nbnn = 1
  89. nbelem = iel1
  90. nbsous = 0
  91. nbref = 0
  92. SEGINI,ipt1
  93. ipt1.itypel = 1
  94.  
  95. DO im = 1, NSOUM
  96. imodel = mmodel.kmodel(im)
  97. IF (imodel.nefmod .NE. HHO_NUM_ELEMENT) GOTO 100
  98. CALL HHONOB(imodel,nobHHO,iret)
  99. IF (nobHHO.LE.0) THEN
  100. write(ioimp,*) 'HHOEXT: nobHHO undefined'
  101. iret = 5
  102. RETURN
  103. END IF
  104. IF (imodel.TYMODE(nobHHO+indHHO) .NE. 'LISTENTI') THEN
  105. write(ioimp,*) 'HHOEXT: indHHO LISTENTI undefined'
  106. iret = 5
  107. RETURN
  108. END IF
  109. mlent3 = imodel.IVAMOD(nobHHO+indHHO)
  110. SEGACT,mlent3
  111. nbel3 = mlent3.lect(/1)
  112. DO i = 2, nbel3, 2
  113. je = mlent3.lect(i-1)
  114. ip = ABS(mlent3.lect(i))
  115. if (ip.eq.0) write(ioimp,*) 'HHOEXT P... Bizarre...',i/2,je,ip
  116. IF (motopt.EQ.'PFAC') THEN
  117. jp = ip + NBFHHO(je-1)
  118. ELSE IF (motopt.EQ.'PCEL') THEN
  119. jp = ip + NBCHHO(je-1)
  120. END IF
  121. ipt1.num(1,jp) = ipt2.num(1,jp)
  122. END DO
  123. SEGDES,mlent3
  124. 100 CONTINUE
  125. END DO
  126. C= On compacte le maillage de POI1
  127. iel1 = 0
  128. DO i1 = 1, nbelem
  129. IF (ipt1.num(1,i1).NE.0) THEN
  130. iel1 = iel1 + 1
  131. IF (iel1.NE.i1) THEN
  132. ipt1.num(1,iel1) = ipt1.num(1,i1)
  133. ipt1.num(1,i1) = 0
  134. END IF
  135. END IF
  136. END DO
  137. IF (iel1.LT.nbelem) THEN
  138. nbelem = iel1
  139. SEGADJ,ipt1
  140. END IF
  141. C= Fin
  142. c* SEGDES,ipt1
  143. IPOBJ = ipt1
  144. chobj = 'MAILLAGE'
  145. RETURN
  146. END IF
  147.  
  148. C= EXTRACTION DES FACES :
  149. IF (chopt(5:8).EQ.'FACE') THEN
  150. indHHO = 2
  151. JG = NFAMAX
  152. SEGINI,mlent1
  153. DO i = 1, JG
  154. mlent1.lect(i) = 0
  155. END DO
  156. C= Preparation des donnees (MAILLAGE) : Maillage a "ZERO"
  157. nbs = NUFHHO
  158. IF (IDIM.EQ.2) THEN
  159. ideb = 2
  160. ifin = 2
  161. if (nbs.ne.1) then
  162. write(ioimp,*) 'HHOEXT: incompatibility 2D NFUHHO'
  163. iret = 5
  164. return
  165. end if
  166. END IF
  167. IF (IDIM.EQ.3) THEN
  168. ideb = 3
  169. ifin = HHO_MAX_EDGE
  170. END IF
  171. isou = 0
  172. DO i = ideb, ifin
  173. nbelem = NBFHHO(i) - NBFHHO(i-1)
  174. IF (nbelem.EQ.0) GOTO 200
  175. isou = isou + 1
  176. nbnn = i
  177. nbsous = 0
  178. nbref = 0
  179. SEGINI,ipt1
  180. ipt2 = MAFHHO(i)
  181. segact,ipt2
  182. ipt1.itypel = ipt2.itypel
  183. c* segdes,ipt2
  184. mlent1.lect(i) = ipt1
  185. 200 CONTINUE
  186. END DO
  187. IF (isou.NE.nbs) THEN
  188. write(ioimp,*) 'HHOEXT(2): incompatibility NBSOUS'
  189. iret = 5
  190. return
  191. END IF
  192.  
  193. ISOHHO = 0
  194. DO im = 1, NSOUM
  195. imodel = mmodel.kmodel(im)
  196. IF (imodel.nefmod .NE. HHO_NUM_ELEMENT) GOTO 250
  197. CALL HHONOB(imodel, nobHHO, iret)
  198. IF (nobHHO.LE.0) THEN
  199. write(ioimp,*) 'HHOEXT : nobHHO undefined'
  200. iret = 5
  201. RETURN
  202. END IF
  203. IF (imodel.TYMODE(nobHHO+indHHO) .NE. 'LISTENTI') THEN
  204. write(ioimp,*) 'HHOEXT : nobHHO+indHHO LISTENTI undefined'
  205. iret = 5
  206. RETURN
  207. END IF
  208. ISOHHO = ISOHHO + 1
  209. mlent3 = imodel.IVAMOD(nobHHO+indHHO)
  210. SEGACT,mlent3
  211. nbel3 = mlent3.lect(/1)
  212. DO i = 2, nbel3, 2
  213. je = mlent3.lect(i-1)
  214. ip = ABS(mlent3.lect(i))
  215. if (ip.eq.0) write(ioimp,*) 'HHOEXT FACE Bizarre...',i/2,je,ip
  216. ipt2 = MAFHHO(je)
  217. ipt1 = mlent1.lect(je)
  218. DO j = 1, je
  219. ipt1.num(j,ip) = ipt2.num(j,ip)
  220. END DO
  221. END DO
  222. SEGDES,mlent3
  223. 250 CONTINUE
  224. END DO
  225. C= On compacte le maillage
  226. isou = 0
  227. DO i = 1, NFAMAX
  228. ipt1 = mlent1.lect(i)
  229. IF (ipt1.EQ.0) GOTO 270
  230. nbnn1 = ipt1.num(/1)
  231. nbel1 = ipt1.num(/2)
  232. iel1 = 0
  233. DO i1 = 1, nbel1
  234. IF (ipt1.num(1,i1).NE.0) THEN
  235. iel1 = iel1 + 1
  236. IF (iel1.NE.i1) THEN
  237. DO j = 1, nbnn1
  238. ipt1.num(j,iel1) = ipt1.num(j,i1)
  239. END DO
  240. ipt1.num(1,i1) = 0
  241. END IF
  242. END IF
  243. END DO
  244. IF (iel1.EQ.0) THEN
  245. SEGSUP,ipt1
  246. mlent1.lect(i) = 0
  247. ELSE
  248. isou = isou + 1
  249. IF (iel1.LT.nbel1) THEN
  250. nbnn = nbnn1
  251. nbelem = iel1
  252. nbsous = 0
  253. nbref = 0
  254. SEGADJ,ipt1
  255. END IF
  256. END IF
  257. 270 CONTINUE
  258. END DO
  259. IF (isou.EQ.0) THEN
  260. nbnn = 1
  261. nbelem = 0
  262. nbsous = 0
  263. nbref = 0
  264. SEGINI,ipt2
  265. ipt2.itypel = 1
  266. ELSE IF (isou.EQ.1) THEN
  267. DO i = 1, NFAMAX
  268. ipt1 = mlent1.lect(i)
  269. IF (ipt1.NE.0) ipt2 = ipt1
  270. END DO
  271. ELSE
  272. nbnn = 0
  273. nbelem = 0
  274. nbsous = isou
  275. nbref = 0
  276. SEGINI,ipt2
  277. jsou = 0
  278. DO i = 1, NFAMAX
  279. ipt1 = mlent1.lect(i)
  280. IF (ipt1.NE.0) THEN
  281. jsou = jsou + 1
  282. ipt2.lisous(jsou) = ipt1
  283. END IF
  284. END DO
  285. if (isou.ne.jsou) then
  286. write(ioimp,*) 'HHOEXT FACE : incompatibility isou-jsou'
  287. end if
  288. END IF
  289. SEGSUP,mlent1
  290. IPOBJ = ipt2
  291. chobj = 'MAILLAGE'
  292. RETURN
  293. END IF
  294.  
  295. C* RETURN
  296. END
  297.  
  298.  
  299.  
  300.  

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