Télécharger ccgime.eso

Retour à la liste

Numérotation des lignes :

  1. C CCGIME SOURCE GOUNAND 11/04/29 21:15:16 6947
  2. SUBROUTINE CCGIME(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 : CCGIME
  9. C DESCRIPTION : Lois de comportement aux points de Gauss :
  10. C Inverse de la métrique par rapport à un
  11. C élément de référence régulier.
  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, 22/09/10, version initiale
  26. C HISTORIQUE : v1, 22/09/10, 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.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCREEL
  37. CBEGININCLUDE SMCHAEL
  38. SEGMENT MCHAEL
  39. POINTEUR IMACHE(N1).MELEME
  40. POINTEUR ICHEVA(N1).MCHEVA
  41. ENDSEGMENT
  42. SEGMENT MCHEVA
  43. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  44. ENDSEGMENT
  45. SEGMENT LCHEVA
  46. POINTEUR LISCHE(NBCHE).MCHEVA
  47. ENDSEGMENT
  48. CENDINCLUDE SMCHAEL
  49. INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  50. POINTEUR FC.MCHEVA
  51. POINTEUR LCOF.LCHEVA
  52. POINTEUR JMAJAC.MCHEVA
  53. POINTEUR JMIJAC.MCHEVA
  54. POINTEUR JDTJAC.MCHEVA
  55. POINTEUR JMAREG.MCHEVA
  56. CHARACTER*8 NOMLOI
  57. INTEGER ICOF
  58. *
  59. -INC TMXMAT
  60. * Objets temporaires
  61. POINTEUR JAC.MXMAT,JT.MXMAT,MJT.MXMAT
  62. POINTEUR G.MXMAT,IG.MXMAT,H.MXMAT,HIG.MXMAT,IGHIG.MXMAT
  63. POINTEUR ME.MXMAT
  64. *
  65. SEGMENT MCOF
  66. POINTEUR COEF(IDIM,IDIM).MCHEVA
  67. ENDSEGMENT
  68. *
  69. LOGICAL LBID
  70. INTEGER LAXSP
  71. REAL*8 DEUPI,XR
  72. REAL*8 XL,XM
  73. *
  74. INTEGER IMPR,IRET
  75. *
  76. * Executable statements
  77. *
  78. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgime'
  79. C IF (.NOT.(IDIM.EQ.1)) THEN
  80. C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  81. C GOTO 9999
  82. C ENDIF
  83. NLFC=FC.VELCHE(/6)
  84. NPFC=FC.VELCHE(/5)
  85. ICOF=0
  86. *
  87. ICOF=ICOF+1
  88. JMAJAC=LCOF.LISCHE(ICOF)
  89. NLJA=JMAJAC.VELCHE(/6)
  90. NPJA=JMAJAC.VELCHE(/5)
  91. IREF=JMAJAC.VELCHE(/4)
  92. IREL=JMAJAC.VELCHE(/3)
  93. *
  94. IF (IREL.NE.IDIM) THEN
  95. WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  96. GOTO 9999
  97. ENDIF
  98. *
  99. ICOF=ICOF+1
  100. ICOF=ICOF+1
  101. ICOF=ICOF+1
  102. JMAREG=LCOF.LISCHE(ICOF)
  103. NLJR=JMAREG.VELCHE(/6)
  104. NPJR=JMAREG.VELCHE(/5)
  105. I1 =JMAREG.VELCHE(/4)
  106. I2 =JMAREG.VELCHE(/3)
  107. IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
  108. $ THEN
  109. WRITE(IOIMP,*) 'Erreur dims JMAREG'
  110. GOTO 9999
  111. ENDIF
  112. *
  113. * Objets temporaires et à préconditionner
  114. *
  115. LDIM1=IREL
  116. LDIM2=IREF
  117. SEGINI,JAC
  118. LDIM1=IREF
  119. LDIM2=IREL
  120. SEGINI,JT
  121. SEGINI,MJT
  122. LDIM1=IREF
  123. LDIM2=IREF
  124. SEGINI,G
  125. SEGINI,IG
  126. SEGINI,H
  127. SEGINI,HIG
  128. SEGINI,IGHIG
  129. LDIM1=IREL
  130. LDIM2=IREL
  131. SEGINI,ME
  132. *
  133. * Calcul de la métrique des éléments réguliers
  134. *
  135. CALL MAMA(JMAREG.VELCHE,IREF,IREF,
  136. $ 'JTJ ',H.XMAT,IREF,IREF,
  137. $ IMPR,IRET)
  138. IF (IRET.NE.0) GOTO 9999
  139. * SEGPRT,H
  140. *
  141. DO ILFC=1,NLFC
  142. IF (NLJA.EQ.1) THEN
  143. ILJA=1
  144. ELSE
  145. ILJA=ILFC
  146. ENDIF
  147. DO IPFC=1,NPFC
  148. IF (NPJA.EQ.1) THEN
  149. IPJA=1
  150. ELSE
  151. IPJA=IPFC
  152. ENDIF
  153. *
  154. * Copie du jacobien
  155. *
  156. CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  157. $ 'COPIE ',
  158. $ JAC.XMAT,IREL,IREF,
  159. $ IMPR,IRET)
  160. IF (IRET.NE.0) GOTO 9999
  161. * SEGPRT,JAC
  162. *
  163. * Calcul de la métrique ME = J (JtJ)-1 h (JtJ)-1 Jt = J M Jt
  164. *
  165. * Calcul de Jt
  166. CALL MAMA(JAC.XMAT,IREL,IREF,
  167. $ 'TRANSPOS',JT.XMAT,IREF,IREL,
  168. $ IMPR,IRET)
  169. IF (IRET.NE.0) GOTO 9999
  170. * SEGPRT,JT
  171. * Calcul de G=JtJ
  172. CALL MAMAMA(JT.XMAT,IREF,IREL,JAC.XMAT,IREL,IREF,
  173. $ 'FOIS ',G.XMAT,IREF,IREF,
  174. $ IMPR,IRET)
  175. IF (IRET.NE.0) GOTO 9999
  176. * SEGPRT,G
  177. * Calcul de l'inverse, du déterminant et trace de l'inverse de g
  178. LBID=.FALSE.
  179. CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,
  180. $ LBID,IMPR,IRET)
  181. IF (IRET.NE.0) GOTO 9999
  182. * SEGPRT,IG
  183. * Calcul de hg-1, de sa trace et de son déterminant
  184. CALL MAMAMA(H.XMAT,IREF,IREF,IG.XMAT,IREF,IREF,
  185. $ 'FOIS ',HIG.XMAT,IREF,IREF,IMPR,IRET)
  186. IF (IRET.NE.0) GOTO 9999
  187. CALL MAMAMA(IG.XMAT,IREF,IREF,HIG.XMAT,IREF,IREF,
  188. $ 'FOIS ',IGHIG.XMAT,IREF,IREF,IMPR,IRET)
  189. IF (IRET.NE.0) GOTO 9999
  190. CALL MAMAMA(IGHIG.XMAT,IREF,IREF,JT.XMAT,IREF,IREL,
  191. $ 'FOIS ',MJT.XMAT,IREF,IREL,IMPR,IRET)
  192. IF (IRET.NE.0) GOTO 9999
  193. CALL MAMAMA(JAC.XMAT,IREL,IREF,MJT.XMAT,IREF,IREL,
  194. $ 'FOIS ',ME.XMAT,IREL,IREL,IMPR,IRET)
  195. IF (IRET.NE.0) GOTO 9999
  196. *
  197. * Calcul des la métrique inverse de l'élément
  198. *
  199. IF (NOMLOI(1:4).EQ.'IMET') THEN
  200. CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  201. IF (IRET.NE.0) GOTO 9999
  202. CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  203. IF (IRET.NE.0) GOTO 9999
  204. CONTRI=ME.XMAT(IDIM1,IDIM2)
  205. * WRITE(IOIMP,*) 'CONTRI=',CONTRI
  206. ELSE
  207. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  208. WRITE(IOIMP,*) 'Erreur grave'
  209. GOTO 9999
  210. ENDIF
  211. FC.VELCHE(1,1,1,1,IPFC,ILFC)=
  212. $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+
  213. $ CONTRI
  214. ENDDO
  215. ENDDO
  216. SEGSUP,ME
  217. SEGSUP,IGHIG
  218. SEGSUP,HIG
  219. SEGSUP,H
  220. SEGSUP,IG
  221. SEGSUP,G
  222. SEGSUP,MJT
  223. SEGSUP,JT
  224. SEGSUP,JAC
  225. *
  226. * Normal termination
  227. *
  228. IRET=0
  229. RETURN
  230. *
  231. * Format handling
  232. *
  233. *
  234. * Error handling
  235. *
  236. 9999 CONTINUE
  237. IRET=1
  238. WRITE(IOIMP,*) 'An error was detected in subroutine ccgime'
  239. RETURN
  240. *
  241. * End of subroutine CCGIME
  242. *
  243. END
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  

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