Télécharger ccgqme.eso

Retour à la liste

Numérotation des lignes :

  1. C CCGQME SOURCE GOUNAND 07/07/05 21:15:13 5784
  2. SUBROUTINE CCGQME(LCOF,NOMLOI,
  3. $ FC,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : CCGQME
  9. C DESCRIPTION : Lois de comportement aux points de Gauss :
  10. C Qualité du maillage : alignement et isotropie
  11. C cf. Huang
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES :
  18. C APPELE PAR :
  19. C***********************************************************************
  20. C ENTREES :
  21. C ENTREES/SORTIES :
  22. C SORTIES : -
  23. C TRAVAIL :
  24. C***********************************************************************
  25. C VERSION : v1, 11/05/07, version initiale
  26. C HISTORIQUE : v1, 11/05/07, création
  27. C HISTORIQUE :
  28. C***********************************************************************
  29. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  30. C en cas de modification de ce sous-programme afin de faciliter
  31. C la maintenance !
  32. C***********************************************************************
  33. -INC CCOPTIO
  34. -INC CCREEL
  35. CBEGININCLUDE SMCHAEL
  36. SEGMENT MCHAEL
  37. POINTEUR IMACHE(N1).MELEME
  38. POINTEUR ICHEVA(N1).MCHEVA
  39. ENDSEGMENT
  40. SEGMENT MCHEVA
  41. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  42. ENDSEGMENT
  43. SEGMENT LCHEVA
  44. POINTEUR LISCHE(NBCHE).MCHEVA
  45. ENDSEGMENT
  46. CENDINCLUDE SMCHAEL
  47. INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  48. POINTEUR FC.MCHEVA
  49. POINTEUR LCOF.LCHEVA
  50. POINTEUR JMAJAC.MCHEVA
  51. POINTEUR JMIJAC.MCHEVA
  52. POINTEUR JDTJAC.MCHEVA
  53. POINTEUR JMAREG.MCHEVA
  54. POINTEUR JMET.MCHEVA
  55. POINTEUR JTHE.MCHEVA
  56. POINTEUR JGAM.MCHEVA
  57. CHARACTER*8 NOMLOI
  58. INTEGER ICOF
  59. *
  60. -INC TMXMAT
  61. * Objets temporaires
  62. POINTEUR JAC.MXMAT,JT.MXMAT
  63. POINTEUR G.MXMAT,IG.MXMAT,H.MXMAT,HIG.MXMAT,GIH.MXMAT
  64. POINTEUR ME.MXMAT,JTM.MXMAT,MJ.MXMAT
  65. *
  66. SEGMENT MCOF
  67. POINTEUR COEF(IDIM,IDIM).MCHEVA
  68. ENDSEGMENT
  69. POINTEUR MET.MCOF
  70. *
  71. LOGICAL LBID
  72. INTEGER LAXSP
  73. REAL*8 DEUPI,XR
  74. REAL*8 XL,XM
  75. *
  76. INTEGER IMPR,IRET
  77. *
  78. * Executable statements
  79. *
  80. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgqme'
  81. C IF (.NOT.(IDIM.EQ.1)) THEN
  82. C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  83. C GOTO 9999
  84. C ENDIF
  85. NLFC=FC.VELCHE(/6)
  86. NPFC=FC.VELCHE(/5)
  87. ICOF=0
  88. *
  89. * Récupération des coefficients de la metrique
  90. *
  91. SEGINI MET
  92. DO IIDIM=1,IDIM
  93. ICOF=ICOF+1
  94. JMET=LCOF.LISCHE(ICOF)
  95. IF (ICOF.EQ.1) THEN
  96. NLJM=JMET.VELCHE(/6)
  97. NPJM=JMET.VELCHE(/5)
  98. ELSE
  99. NLJM2=JMET.VELCHE(/6)
  100. NPJM2=JMET.VELCHE(/5)
  101. IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  102. WRITE(IOIMP,*) 'Erreur grave dims JMET'
  103. GOTO 9999
  104. ENDIF
  105. ENDIF
  106. MET.COEF(IIDIM,IIDIM)=JMET
  107. ENDDO
  108. DO IIDIM=1,IDIM
  109. NJ=IDIM-IIDIM
  110. IF (NJ.GE.1) THEN
  111. DO JIDIM=IIDIM+1,IDIM
  112. ICOF=ICOF+1
  113. JMET=LCOF.LISCHE(ICOF)
  114. NLJM2=JMET.VELCHE(/6)
  115. NPJM2=JMET.VELCHE(/5)
  116. IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
  117. WRITE(IOIMP,*) 'Erreur grave dims JMET2'
  118. GOTO 9999
  119. ENDIF
  120. MET.COEF(IIDIM,JIDIM)=JMET
  121. ENDDO
  122. ENDIF
  123. ENDDO
  124. *
  125. ICOF=ICOF+1
  126. JMAJAC=LCOF.LISCHE(ICOF)
  127. NLJA=JMAJAC.VELCHE(/6)
  128. NPJA=JMAJAC.VELCHE(/5)
  129. IREF=JMAJAC.VELCHE(/4)
  130. IREL=JMAJAC.VELCHE(/3)
  131. *
  132. IF (IREL.NE.IDIM) THEN
  133. WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  134. GOTO 9999
  135. ENDIF
  136. *
  137. ICOF=ICOF+1
  138. ICOF=ICOF+1
  139. ICOF=ICOF+1
  140. JMAREG=LCOF.LISCHE(ICOF)
  141. NLJR=JMAREG.VELCHE(/6)
  142. NPJR=JMAREG.VELCHE(/5)
  143. I1 =JMAREG.VELCHE(/4)
  144. I2 =JMAREG.VELCHE(/3)
  145. IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
  146. $ THEN
  147. WRITE(IOIMP,*) 'Erreur dims JMAREG'
  148. GOTO 9999
  149. ENDIF
  150. *
  151. * Objets temporaires et à préconditionner
  152. *
  153. LDIM1=IREL
  154. LDIM2=IREF
  155. SEGINI,JAC
  156. SEGINI,MJ
  157. LDIM1=IREF
  158. LDIM2=IREL
  159. SEGINI,JT
  160. SEGINI,JTM
  161. LDIM1=IREF
  162. LDIM2=IREF
  163. SEGINI,G
  164. SEGINI,IG
  165. SEGINI,H
  166. SEGINI,HIG
  167. SEGINI,GIH
  168. LDIM1=IREL
  169. LDIM2=IREL
  170. SEGINI,ME
  171. *
  172. * Calcul de la métrique des éléments réguliers
  173. *
  174. CALL MAMA(JMAREG.VELCHE,IREF,IREF,
  175. $ 'JTJ ',H.XMAT,IREF,IREF,
  176. $ IMPR,IRET)
  177. IF (IRET.NE.0) GOTO 9999
  178. * SEGPRT,H
  179. *
  180. DO ILFC=1,NLFC
  181. IF (NLJM.EQ.1) THEN
  182. ILJM=1
  183. ELSE
  184. ILJM=ILFC
  185. ENDIF
  186. IF (NLJA.EQ.1) THEN
  187. ILJA=1
  188. ELSE
  189. ILJA=ILFC
  190. ENDIF
  191. DO IPFC=1,NPFC
  192. IF (NPJM.EQ.1) THEN
  193. IPJM=1
  194. ELSE
  195. IPJM=IPFC
  196. ENDIF
  197. IF (NPJA.EQ.1) THEN
  198. IPJA=1
  199. ELSE
  200. IPJA=IPFC
  201. ENDIF
  202. *
  203. * Copie des coefficients de la métrique
  204. *
  205. DO IIDIM=1,IDIM
  206. JMET=MET.COEF(IIDIM,IIDIM)
  207. ME.XMAT(IIDIM,IIDIM)=JMET.VELCHE(1,1,1,1,IPJM,ILJM)
  208. ENDDO
  209. DO IIDIM=1,IIDIM
  210. NJ=IDIM-IIDIM
  211. IF (NJ.GE.1) THEN
  212. DO JIDIM=IIDIM+1,IDIM
  213. JMET=MET.COEF(IIDIM,JIDIM)
  214. ME.XMAT(IIDIM,JIDIM)=JMET.VELCHE(1,1,1,1,IPJM,ILJM)
  215. ME.XMAT(JIDIM,IIDIM)=JMET.VELCHE(1,1,1,1,IPJM,ILJM)
  216. ENDDO
  217. ENDIF
  218. ENDDO
  219. *
  220. * Copie du jacobien
  221. *
  222. CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  223. $ 'COPIE ',
  224. $ JAC.XMAT,IREL,IREF,
  225. $ IMPR,IRET)
  226. IF (IRET.NE.0) GOTO 9999
  227. * SEGPRT,JAC
  228. *
  229. * Calcul de la métrique G
  230. *
  231. * Calcul de Jt
  232. CALL MAMA(JAC.XMAT,IREL,IREF,
  233. $ 'TRANSPOS',JT.XMAT,IREF,IREL,
  234. $ IMPR,IRET)
  235. IF (IRET.NE.0) GOTO 9999
  236. * Calcul de MJ
  237. CALL MAMAMA(ME.XMAT,IREL,IREL,JAC.XMAT,IREL,IREF,
  238. $ 'FOIS ',MJ.XMAT,IREL,IREF,
  239. $ IMPR,IRET)
  240. IF (IRET.NE.0) GOTO 9999
  241. * Calcul de JTM
  242. CALL MAMA(MJ.XMAT,IREL,IREF,
  243. $ 'TRANSPOS',JTM.XMAT,IREF,IREL,
  244. $ IMPR,IRET)
  245. IF (IRET.NE.0) GOTO 9999
  246. * Calcul de G=JtMJ
  247. CALL MAMAMA(JT.XMAT,IREF,IREL,MJ.XMAT,IREL,IREF,
  248. $ 'FOIS ',G.XMAT,IREF,IREF,
  249. $ IMPR,IRET)
  250. IF (IRET.NE.0) GOTO 9999
  251. * Calcul de l'inverse, du déterminant et trace de l'inverse de g
  252. LBID=.FALSE.
  253. CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,LBID,IMPR,IRET)
  254. IF (IRET.NE.0) GOTO 9999
  255. * Calcul de hg-1, de sa trace et de son déterminant
  256. CALL MAMAMA(H.XMAT,IREF,IREF,IG.XMAT,IREF,IREF,
  257. $ 'FOIS ',HIG.XMAT,IREF,IREF,IMPR,IRET)
  258. IF (IRET.NE.0) GOTO 9999
  259. LBID=.FALSE.
  260. CALL GEOLI2(IREF,1,1,HIG.XMAT,GIH.XMAT,DETHIG,
  261. $ LBID,IMPR,IRET)
  262. IF (IRET.NE.0) GOTO 9999
  263. XM=1.D0/SQRT(DETHIG)
  264. CALL MARE(GIH.XMAT,IREF,IREF,'TRACE ',
  265. $ XL,IMPR,IRET)
  266. IF (IRET.NE.0) GOTO 9999
  267. *
  268. * Calcul des qualités de maillage
  269. *
  270. IF (NOMLOI.EQ.'QEQU ') THEN
  271. CONTRI=XM
  272. ELSEIF (NOMLOI.EQ.'QALI') THEN
  273. IF (IREF.EQ.1) THEN
  274. CONTRI=1.D0
  275. ELSE
  276. XIREF=DBLE(IREF)
  277. XNUM=XL
  278. XDEN=XIREF*(XM**(2.D0/XIREF))
  279. XEXP=XIREF/(2.D0*(XIREF-1.D0))
  280. CONTRI=(XNUM/XDEN)**XEXP
  281. C SEGPRT,GIH
  282. C WRITE(IOIMP,*) 'TRGIH =',XL
  283. C WRITE(IOIMP,*) 'DETGIH=',(1.D0/DETHIG)
  284. C WRITE(IOIMP,*) 'XNUM=',XNUM
  285. C WRITE(IOIMP,*) 'XDEN=',XDEN
  286. ENDIF
  287. ELSE
  288. WRITE(IOIMP,*) 'Erreur grave'
  289. GOTO 9999
  290. ENDIF
  291. FC.VELCHE(1,1,1,1,IPFC,ILFC)=
  292. $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+
  293. $ CONTRI
  294. ENDDO
  295. ENDDO
  296. SEGSUP,ME
  297. SEGSUP,GIH
  298. SEGSUP,HIG
  299. SEGSUP,H
  300. SEGSUP,IG
  301. SEGSUP,G
  302. SEGSUP,JTM
  303. SEGSUP,JT
  304. SEGSUP,MJ
  305. SEGSUP,JAC
  306. SEGSUP,MET
  307. *
  308. * Normal termination
  309. *
  310. IRET=0
  311. RETURN
  312. *
  313. * Format handling
  314. *
  315. *
  316. * Error handling
  317. *
  318. 9999 CONTINUE
  319. IRET=1
  320. WRITE(IOIMP,*) 'An error was detected in subroutine ccgqme'
  321. RETURN
  322. *
  323. * End of subroutine CCGQME
  324. *
  325. END
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  

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