Télécharger hhoeps.eso

Retour à la liste

Numérotation des lignes :

hhoeps
  1. C HHOEPS SOURCE OF166741 24/06/19 21:15:05 11942
  2. C HHOEPS SOURCE FANDEUR
  3.  
  4. C-----------------------------------------------------------------------*
  5. C Elements massifs HHO en FORMULATION 'MECANIQUE'
  6. C HHO calcul des deformations (HHP), du gradient
  7. C-----------------------------------------------------------------------*
  8.  
  9. SUBROUTINE HHOEPS(chaopt, imoHHO, ichDEP,nmoDEP,
  10. & IIPDPG,UZDPG,RYDPG,RXDPG,
  11. & IVACAR, NCARR, IPMINT, NBPTEL,
  12. & IVAEPS,NCEPS, iret)
  13.  
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8(A-H,O-Z)
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCREEL
  20.  
  21. -INC CCHHOPA
  22. -INC CCHHOPR
  23.  
  24. -INC SMCHAML
  25. -INC SMCOORD
  26. -INC SMELEME
  27. -INC SMMODEL
  28. -INC SMINTE
  29. -INC SMLENTI
  30. POINTEUR mlent4.mlenti
  31. -INC SMLMOTS
  32. -INC SMLREEL
  33. POINTEUR mlrdef.mlreel, mlrdec.mlreel, mlrmbh.mlreel
  34.  
  35. SEGMENT MPTVAL
  36. INTEGER IPOS(NS),NSOF(NS)
  37. INTEGER IVAL(NCOSOU)
  38. CHARACTER*16 TYVAL(NCOSOU)
  39. ENDSEGMENT
  40.  
  41. SEGMENT MWKHHO
  42. INTEGER TABINT(NBINT)
  43. REAL*8 TABFLO(NBFLO)
  44. ENDSEGMENT
  45.  
  46. CHARACTER*(*) chaopt
  47.  
  48. DIMENSION UDPGE(3)
  49.  
  50. iret = 0
  51.  
  52. C- OPTION DE CALCUL : GRADIENT DU DEPLACEMENT OU TENSEUR DES DEFORMATIONS
  53. IF (chaopt(1:4).EQ.'EPSI') THEN
  54. NCHOPT = 1
  55. IF (NCEPS.GT.9) THEN
  56. write(ioimp,*) 'HHOEPS: NCEPS incorrect (> 9)'
  57. iret = 5
  58. RETURN
  59. END IF
  60. ELSE IF (chaopt(1:4).EQ.'GRAD') THEN
  61. NCHOPT = 2
  62. IF (NCEPS.NE.9) THEN
  63. write(ioimp,*) 'HHOGRA: NCGRA incorrect (/= 9)'
  64. iret = 5
  65. RETURN
  66. END IF
  67. ELSE
  68. NCHOPT = 0
  69. write(ioimp,*) 'HHOEPS '//chaopt(1:4)//' unknown option'
  70. iret = 5
  71. RETURN
  72. END IF
  73.  
  74. imodel = imoHHO
  75. c* segact,imodel <- actif en entree/sortie
  76.  
  77. C- Premieres verifications :
  78. CALL HHONOB(imoHHO, nobHHO, iret)
  79. IF (nobHHO.LE.0)THEN
  80. write(ioimp,*) 'HHOEPS: IMODEL incorrect (not HHO)'
  81. iret = 5
  82. RETURN
  83. END IF
  84.  
  85. C- Introduction du point autour duquel se fait le mouvement
  86. C de la section en defo plane generalisee
  87. C IIPDPG = numero du noeud/point support si defini pour le modele
  88. C NDPGE > 0 si prise en compte du point support
  89. IF (IIPDPG.GT.0) THEN
  90. write(ioimp,*) 'HHOEPS: GENE mode not implemented!'
  91. iret = 5
  92. return
  93. IF (IFOUR.EQ.-3) THEN
  94. NDPGE = 3
  95. UDPGE(1) = UZDPG
  96. UDPGE(2) = RYDPG
  97. UDPGE(3) = RXDPG
  98. C SEGACT,MCOORD
  99. IREF = (IIPDPG-1)*(IDIM+1)
  100. XDPGE = XCOOR(IREF+1)
  101. YDPGE = XCOOR(IREF+2)
  102. ELSE IF (IFOUR.EQ.11) THEN
  103. NDPGE = 2
  104. UDPGE(1) = UZDPG
  105. UDPGE(2) = RXDPG
  106. UDPGE(3) = XZero
  107. XDPGE = XZero
  108. YDPGE = XZero
  109. ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  110. & IFOUR.EQ.10 .OR. IFOUR.EQ.14) THEN
  111. NDPGE = 1
  112. UDPGE(1) = UZDPG
  113. UDPGE(2) = XZero
  114. UDPGE(3) = XZero
  115. XDPGE = XZero
  116. YDPGE = XZero
  117. else
  118. write(ioimp,*) 'HHOEPS: ERREUR NDPGE'
  119. iret = 5
  120. return
  121. ENDIF
  122. ELSE
  123. NDPGE = 0
  124. UDPGE(1) = XZero
  125. UDPGE(2) = XZero
  126. UDPGE(3) = XZero
  127. XDPGE = XZero
  128. YDPGE = XZero
  129. END IF
  130.  
  131. C- Recuperation des donnees de infell en entree
  132. c* MELE = imodel.NEFMOD
  133. c* MFR = imodel.infele(13)
  134. meleme = imodel.IMAMOD
  135. NBNOE = meleme.NUM(/1)
  136. NBELT = meleme.NUM(/2)
  137.  
  138. mlenti = imodel.IVAMOD(nobHHO+1)
  139. c* segact,mlenti
  140. mlent3 = imodel.IVAMOD(nobHHO+3)
  141. c* segact,mlent3
  142. mlent4 = imodel.IVAMOD(nobHHO+4)
  143. c* segact,mlent4
  144.  
  145. n_d_face = mlenti.lect(3)
  146. n_d_cell = mlenti.lect(5)
  147. nb_faces = mlenti.lect(7)
  148. NBPGAU = mlenti.lect(8)
  149. idifo = mlenti.lect(9)
  150. NBDDL = mlenti.lect(11)
  151. NDEPF = idifo * n_d_face
  152. NDEPC = idifo * n_d_cell
  153. lhook = 9
  154.  
  155. nbel3 = mlent3.lect(/1) / 2
  156. nbfa3 = 2 * nb_faces
  157. nbel4 = mlent4.lect(/1) / 2
  158.  
  159. IF (mlenti.lect(6).NE.NBNOE) THEN
  160. write(ioimp,*) 'HHOEPS: Bizarre nb_vertices'
  161. END IF
  162. IF (NBDDL .NE. imodel.INFELE(9)) then
  163. write(ioimp,*) 'HHOEPS: Bizarre NBDDL'
  164. END IF
  165. c NBPGAU =? (NBPTEL = imodel.INFELE(4))
  166. IF (NBPGAU .NE. imodel.INFELE(4)) then
  167. write(ioimp,*) 'HHOEPS: Bizarre nb.p.gau(1)'
  168. END IF
  169. c NBPGAU =? minte.POIGAU(/1)
  170. minte = IPMINT
  171. c* SEGACT minte <- actif en E/S
  172. if (NBPGAU .NE. minte.POIGAU(/1)) then
  173. write(ioimp,*) 'HHOEPS: Bizarre nb.p.gau (2)'
  174. end if
  175. c-dbg write(ioimp,*) 'HHOEPS nbpgau=',NBPGAU
  176. c-dbg write(ioimp,*) 'HHOEPS: dof face/cell',n_d_face,n_d_cell,nb_faces
  177. if (nbel3.NE.(NBELT*nb_faces)) then
  178. write(ioimp,*) 'HHOEPS: Bizarre nbel3'
  179. end if
  180. if (nbel4.NE.NBELT) then
  181. write(ioimp,*) 'HHOEPS: Bizarre nbel4'
  182. end if
  183.  
  184. ivid = 1
  185. C- Deplacements des faces et des cellules :
  186. nomid = nmoDEP
  187. c* segact,nomid
  188. JGN = nomid.lesobl(/1)
  189. c-dbg write(ioimp,*) 'HHOEPS=',NDEPC,NDEPF,lesobl(/2),lesfac(/2)
  190. nfac = 0
  191. C Deplacements des cellules - Points supports des cellules
  192. JGM = NDEPC + nfac
  193. SEGINI,mlmots
  194. DO i = 1, NDEPC
  195. mlmots.MOTS(i)(1:JGN) = nomid.lesobl(i)(1:JGN)
  196. END DO
  197. c* DO i = 1, nfac
  198. c* mlmots.MOTS(NDEP+i)(1:JGN) = nomid.lesfac(i)(1:JGN)
  199. c* END DO
  200. CALL EXTR23(ichDEP,mlmots,MPCHHO,mlrDEC,ivid)
  201. SEGACT,mlrDEC
  202. c* IF (IERR.NE.0) THEN
  203. c* iret = 21
  204. c* return
  205. c* END IF
  206. c-dbg write(ioimp,*) 'mlmots DEPC ',(mots(i),i=1,mots(/2))
  207. c-dbg write(ioimp,*) 'U.CELL',mlrdec.prog(/1),NCEHHO,NDEPC
  208. c-dbg write(ioimp,*) ' ',(mlrdec.prog(i),i=1,mlrdec.prog(/1))
  209. c-dbg write(ioimp,*)
  210.  
  211. C Deplacements des faces - Points supports des faces
  212. JGM = NDEPF + nfac
  213. SEGADJ,mlmots
  214. DO i = 1, NDEPF
  215. mlmots.MOTS(i)(1:JGN) = nomid.lesobl(NDEPC+i)(1:JGN)
  216. END DO
  217. c* DO i = 1, nfac
  218. c* mlmots.MOTS(NDEP+i)(1:JGN) = nomid.lesfac(i)(1:JGN)
  219. c* END DO
  220. CALL EXTR23(ichDEP,mlmots,MPFHHO,mlrDEF,ivid)
  221. SEGACT,mlrDEF
  222. c* IF (IERR.NE.0) THEN
  223. c* iret = 21
  224. c* return
  225. c* END IF
  226. c-dbg write(ioimp,*) 'mlmots DEPF ',(mots(i),i=1,mots(/2))
  227. c-dbg write(ioimp,*) 'U.FACE',mlrdef.prog(/1),NFAHHO,NDEPF
  228. c-dbg write(ioimp,*) ' ',(mlrdef.prog(i),i=1,mlrdef.prog(/1))
  229. c-dbg write(ioimp,*)
  230.  
  231. C- Verification des caracteristiques :
  232. mptval = IVACAR
  233. IVMBHO = mptval.IVAL(NCARR)
  234. melval = IVMBHO
  235. IGMB = melval.IELCHE(/1)
  236. IEMB = melval.IELCHE(/2)
  237. c-dbg write(ioimp,*) 'IVMBHO',melval,igmb,iemb,tyval(nvmat)
  238. mlrmbh = melval.IELCHE(1,1)
  239. c* segact,mlrmbh
  240. c* write(ioimp,*) 'HHOEPS MBHHO SIZE:',mlrmbh.prog(/1),
  241. c* & NBDDL,9*NBDDL,mlenti.lect(14)
  242. IF ((mlrmbh.prog(/1).NE.(9*NBDDL)) .OR.
  243. & (mlrmbh.prog(/1).NE.mlenti.lect(14))) THEN
  244. write(ioimp,*) 'HHOEPS: BHHO matrix size incorrect'
  245. iret = 21
  246. RETURN
  247. END IF
  248.  
  249. C- Indices et tableau de travail
  250. ir_coo = 0
  251. c* si besoin des coordonnees ir_eps = ir_coo + (IDIM*NBNOE)
  252. ir_eps = ir_coo + 0
  253. ir_uce = ir_eps + lhook
  254. ir_ufa = ir_uce + NDEPC
  255. ir_uge = ir_ufa + (NDEPF*nb_faces)
  256. ir_fin = ir_uge + NDPGE
  257.  
  258. NBINT = 1
  259. NBFLO = ir_fin
  260. SEGINI,MWKHHO
  261.  
  262. IF (NDPGE.GT.0) THEN
  263. DO ic = 1, NDPGE
  264. TABFLO(ir_uge+ic) = UDPGE(ic)
  265. END DO
  266. END IF
  267. c* si besoin des coordonnees SEGACT,MCOORD*NOMOD
  268.  
  269. C-------------------------
  270. C Boucle sur les elements
  271. C-------------------------
  272. DO IEL = 1, NBELT
  273.  
  274. C- Recuperation des coordonnees des noeuds de l element IEL
  275. c* CALL HHOCOO(meleme.num,NBNOE, mcoord.xcoor, IEL,
  276. c* & TABFLO(ir_coo+1), iret)
  277. c* IF (iret.NE.0) RETURN
  278.  
  279. C- Valeurs des inconnues primales pour l'element IEL (cell+faces)
  280. in1 = IEL * 2
  281. je = mlent4.lect(in1-1)
  282. ip = mlent4.lect(in1)
  283. if (ip.le.0) write(ioimp,*) 'HHOEPS ICEL Bizarre...',iel,je,ip
  284. jp = ip + NBCHHO(je-1)
  285.  
  286. DO ic = 1, NDEPC
  287. jc = NCEHHO * (ic - 1)
  288. TABFLO(ir_uce + ic) = mlrDEC.prog(jp + jc)
  289. END DO
  290. c-dbg write(ioimp,*) 'HHOEPS ICEL',iel,je,ip,jp,ir_uce
  291. c-dbg write(ioimp,*) (TABFLO(ir_uce+ic),ic=1,ndepc)
  292.  
  293. in1 = (IEL-1) * nbfa3
  294. ir_kc = ir_ufa
  295. DO j1 = 1, nb_faces
  296. in2 = in1 + (2 * j1)
  297. je = mlent3.lect(in2-1)
  298. ip = ABS(mlent3.lect(in2))
  299. if (ip.eq.0) write(ioimp,*) 'HHOEPS IFAE Bizarre...',iel,j1,je,ip
  300. jp = ip + NBFHHO(je-1)
  301. DO ic = 1, NDEPF
  302. jc = NFAHHO * (ic - 1)
  303. TABFLO(ir_kc + ic) = mlrDEF.prog(jp + jc)
  304. END DO
  305. c-dbg write(ioimp,*) 'HHOEPS IFAE',iel,j1,je,ip,jp,ir_kc
  306. c-dbg write(ioimp,*) (TABFLO(ir_kc+ic),ic=1,ndepf)
  307. ir_kc = ir_kc + NDEPF
  308. END DO
  309.  
  310. c-dbg write(ioimp,*) 'HHOEPS ...',ir_uce,ir_kc,NBDDL
  311.  
  312. JEMB = MIN(IEL,IEMB)
  313. C-- -- -- -- -- -- -- -- --
  314. C - Boucle sur les points de Gauss
  315. C-- -- -- -- -- -- -- -- --
  316. DO IGAU = 1, NBPGAU
  317.  
  318. melval = IVMBHO
  319. JGMB = MIN(IGAU,IGMB)
  320. mlrmbh = melval.IELCHE(JGMB,JEMB)
  321. c* segact,mlrmbh
  322. c* !! matrice BHHO stockee colonne par colonne : lhook*NBDDL
  323. DO ic = 1, lhook
  324. r_z = XZero
  325. DO jc = 1, NBDDL
  326. jnc = lhook * (jc-1)
  327. r_z = r_z + mlrmbh.prog(ic + jnc) * TABFLO(ir_uce + jc)
  328. END DO
  329. TABFLO(ir_eps + ic) = r_z
  330. END DO
  331.  
  332. mptval = IVAEPS
  333. C -- Remplissage du segment contenant les "deformations"
  334. IF (NCHOPT.EQ.1) THEN
  335. C -- Deformations "Diagonales" EP (11,22,33)
  336. melval = mptval.IVAL(1)
  337. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 1)
  338. melval = mptval.IVAL(2)
  339. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 2)
  340. melval = mptval.IVAL(3)
  341. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 3)
  342. C -- Glissements "hors diagonale" GA (12,13,23)
  343. melval = mptval.IVAL(4)
  344. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 4)
  345. & + TABFLO(ir_eps + 5)
  346. IF (NCEPS.GT.4) THEN
  347. melval = mptval.IVAL(5)
  348. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 6)
  349. & + TABFLO(ir_eps + 7)
  350. melval = mptval.IVAL(6)
  351. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 8)
  352. & + TABFLO(ir_eps + 9)
  353. END IF
  354. C -- Remplissage du segment contenant le "gradient du deplacement"
  355. ELSE IF (NCHOPT.EQ.2) THEN
  356. melval = mptval.IVAL(1)
  357. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 1)
  358. melval = mptval.IVAL(2)
  359. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 4)
  360. melval = mptval.IVAL(3)
  361. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 6)
  362. melval = mptval.IVAL(4)
  363. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 5)
  364. melval = mptval.IVAL(5)
  365. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 2)
  366. melval = mptval.IVAL(6)
  367. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 8)
  368. melval = mptval.IVAL(7)
  369. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 7)
  370. melval = mptval.IVAL(8)
  371. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 9)
  372. melval = mptval.IVAL(9)
  373. melval.velche(IGAU,IEL) = TABFLO(ir_eps + 3)
  374. END IF
  375. C-- -- -- -- -- -- -- -- --
  376. END DO
  377. C-- -- -- -- -- -- -- -- --
  378.  
  379. C-------------------------
  380. END DO
  381. C-------------------------
  382. SEGSUP,MWKHHO
  383. SEGSUP,mlrdec,mlrdef
  384. SEGSUP,mlmots
  385.  
  386. c* RETURN
  387. END
  388.  
  389.  
  390.  
  391.  

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