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

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