Télécharger ccgadv.eso

Retour à la liste

Numérotation des lignes :

  1. C CCGADV SOURCE GOUNAND 11/04/29 21:15:14 6947
  2. SUBROUTINE CCGADV(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 : CCGADV
  9. C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss :
  10. C
  11. C
  12. C LANGAGE : ESOPE
  13. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  14. C mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES :
  17. C APPELE PAR :
  18. C***********************************************************************
  19. C ENTREES :
  20. C ENTREES/SORTIES :
  21. C SORTIES : -
  22. C TRAVAIL :
  23. C***********************************************************************
  24. C VERSION : v1, 04/08/04, version initiale
  25. C HISTORIQUE : v1, 04/08/04, création
  26. C HISTORIQUE :
  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. CBEGININCLUDE SMCHAEL
  35. SEGMENT MCHAEL
  36. POINTEUR IMACHE(N1).MELEME
  37. POINTEUR ICHEVA(N1).MCHEVA
  38. ENDSEGMENT
  39. SEGMENT MCHEVA
  40. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  41. ENDSEGMENT
  42. SEGMENT LCHEVA
  43. POINTEUR LISCHE(NBCHE).MCHEVA
  44. ENDSEGMENT
  45. CENDINCLUDE SMCHAEL
  46. INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  47. POINTEUR FC.MCHEVA
  48. POINTEUR LCOF.LCHEVA
  49. POINTEUR JMAJAC.MCHEVA
  50. POINTEUR JMIJAC.MCHEVA
  51. POINTEUR JDTJAC.MCHEVA
  52. CHARACTER*8 NOMLOI
  53. INTEGER ICOF
  54. *
  55. -INC TMXMAT
  56. POINTEUR JAC.MXMAT
  57. POINTEUR JM1.MXMAT
  58. POINTEUR M1.MXMAT
  59. POINTEUR M2.MXMAT
  60. POINTEUR M3.MXMAT
  61. *
  62. INTEGER IMPR,IRET
  63. *
  64. * Executable statements
  65. *
  66. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgadv'
  67. C IF (.NOT.(IDIM.EQ.1)) THEN
  68. C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  69. C GOTO 9999
  70. C ENDIF
  71. NLFC=FC.VELCHE(/6)
  72. NPFC=FC.VELCHE(/5)
  73. ICOF=0
  74. *
  75. ICOF=ICOF+1
  76. JMAJAC=LCOF.LISCHE(ICOF)
  77. NLJA=JMAJAC.VELCHE(/6)
  78. NPJA=JMAJAC.VELCHE(/5)
  79. ICOF=ICOF+1
  80. JMIJAC=LCOF.LISCHE(ICOF)
  81. NLJI=JMIJAC.VELCHE(/6)
  82. NPJI=JMIJAC.VELCHE(/5)
  83. ICOF=ICOF+1
  84. JDTJAC=LCOF.LISCHE(ICOF)
  85. NLJD=JDTJAC.VELCHE(/6)
  86. NPJD=JDTJAC.VELCHE(/5)
  87. *g LDIM1=JMAJAC.VELCHE(/3)
  88. *g LDIM2=JMAJAC.VELCHE(/4)
  89. *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
  90. *g WRITE(IOIMP,*) 'Erreur grave 1'
  91. *g GOTO 9999
  92. *g ENDIF
  93. *g SEGINI,JAC
  94. *g LDIM1=JMIJAC.VELCHE(/3)
  95. *g LDIM2=JMIJAC.VELCHE(/4)
  96. *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
  97. *g WRITE(IOIMP,*) 'Erreur grave 2'
  98. *g GOTO 9999
  99. *g ENDIF
  100. *g SEGINI,JM1
  101. *
  102. * Objet temporaire
  103. *
  104. *g LDIM1=IDIM
  105. *g LDIM2=IDIM
  106. *g SEGINI,M1
  107. *g SEGINI,M2=M1
  108. *g SEGINI,M3=M1
  109. DO ILFC=1,NLFC
  110. IF (NLJA.EQ.1) THEN
  111. ILJA=1
  112. ELSE
  113. ILJA=ILFC
  114. ENDIF
  115. IF (NLJI.EQ.1) THEN
  116. ILJI=1
  117. ELSE
  118. ILJI=ILFC
  119. ENDIF
  120. IF (NLJD.EQ.1) THEN
  121. ILJD=1
  122. ELSE
  123. ILJD=ILFC
  124. ENDIF
  125. DO IPFC=1,NPFC
  126. IF (NPJA.EQ.1) THEN
  127. IPJA=1
  128. ELSE
  129. IPJA=IPFC
  130. ENDIF
  131. IF (NPJI.EQ.1) THEN
  132. IPJI=1
  133. ELSE
  134. IPJI=IPFC
  135. ENDIF
  136. IF (NPJD.EQ.1) THEN
  137. IPJD=1
  138. ELSE
  139. IPJD=IPFC
  140. ENDIF
  141. C CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IDIM,IDIM
  142. C $ 'COPIE ',
  143. C $ JAC.XMAT,IDIM,IDIM,
  144. C $ IMPR,IRET)
  145. C IF (IRET.NE.0) GOTO 9999
  146. *g CALL MAMA(JMIJAC.VELCHE(1,1,1,1,IPJI,ILJI),IDIM,IDIM,
  147. *g $ 'COPIE ',
  148. *g $ JM1.XMAT,IDIM,IDIM,
  149. *g $ IMPR,IRET)
  150. *g IF (IRET.NE.0) GOTO 9999
  151. DET =JDTJAC.VELCHE(1,1,1,1,IPJD,ILJD)
  152. SDET =SIGN(1.D0,DET)
  153. IF (NOMLOI.EQ.'VOLORI ') THEN
  154. CONTRI=DET
  155. C ELSEIF (NOMLOI.EQ.'ADAF ') THEN
  156. C CALL ERREUR(5)
  157. CC WRITE(IOIMP,*) 'J-1=',JM1.XMAT(1,1)
  158. CC WRITE(IOIMP,*) 'DET=',DET
  159. CC WRITE(IOIMP,*) 'SDET=',SDET
  160. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  161. C $ 'TRJJT ',
  162. C $ TIJIJT,
  163. C $ IMPR,IRET)
  164. C IF (IRET.NE.0) GOTO 9999
  165. C CONTRI=0.5D0*TIJIJT*DET*SDET
  166. C ELSEIF (NOMLOI(1:4).EQ.'ADAR') THEN
  167. C CALL ERREUR(5)
  168. C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  169. C IF (IRET.NE.0) GOTO 9999
  170. C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  171. C IF (IRET.NE.0) GOTO 9999
  172. C CALL MAMA(JM1.XMAT,IDIM,IDIM,
  173. C $ 'JJT ',
  174. C $ M1.XMAT,IDIM,IDIM,
  175. C $ IMPR,IRET)
  176. C IF (IRET.NE.0) GOTO 9999
  177. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  178. C $ 'TRJJT ',
  179. C $ TIJIJT,
  180. C $ IMPR,IRET)
  181. C TR1=0.D0
  182. C DO IIDIM=1,IDIM
  183. C TR1=TR1+
  184. C $ (JM1.XMAT(IIDIM,IDIM1)*M1.XMAT(IDIM2,IIDIM))
  185. C ENDDO
  186. C TR2=JM1.XMAT(IDIM2,IDIM1)
  187. C CONTRI=((0.5D0*TIJIJT*TR2)-TR1)*DET*SDET
  188. C ELSEIF (NOMLOI(1:4).EQ.'ADAK') THEN
  189. C CALL ERREUR(5)
  190. C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  191. C IF (IRET.NE.0) GOTO 9999
  192. C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  193. C IF (IRET.NE.0) GOTO 9999
  194. C CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  195. C IF (IRET.NE.0) GOTO 9999
  196. C CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  197. C IF (IRET.NE.0) GOTO 9999
  198. C CALL MAMA(JM1.XMAT,IDIM,IDIM,
  199. C $ 'TRANSPOS',
  200. C $ M1.XMAT,IDIM,IDIM,
  201. C $ IMPR,IRET)
  202. C IF (IRET.NE.0) GOTO 9999
  203. C WRITE(IOIMP,*) 'transpos'
  204. C SEGPRT,JM1
  205. C SEGPRT,M1
  206. C CALL MAMA(M1.XMAT,IDIM,IDIM,
  207. C $ 'JJT ',
  208. C $ M2.XMAT,IDIM,IDIM,
  209. C $ IMPR,IRET)
  210. C IF (IRET.NE.0) GOTO 9999
  211. C WRITE(IOIMP,*) 'JJT'
  212. C SEGPRT,M1
  213. C SEGPRT,M2
  214. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  215. C $ 'TRJJT ',
  216. C $ TIJIJT,
  217. C $ IMPR,IRET)
  218. C IF (IRET.NE.0) GOTO 9999
  219. C WRITE(IOIMP,*) 'trace JJT'
  220. C SEGPRT,JM1
  221. C WRITE(IOIMP,*) 'TRJJT=',TIJIJT
  222. C XX=-0.5D0*TIJIJT
  223. C CALL REMA(XX,IDIM,IDIM,
  224. C $ 'DIAGONAL',
  225. C $ M1.XMAT,
  226. C $ IMPR,IRET)
  227. C IF (IRET.NE.0) GOTO 9999
  228. C WRITE(IOIMP,*) 'diagonal'
  229. C WRITE(IOIMP,*) 'XX=',XX
  230. C SEGPRT,M1
  231. C CALL MAMAMA(M1.XMAT,IDIM,IDIM,M2.XMAT,IDIM,IDIM,
  232. C $ 'PLUS ',
  233. C $ M3.XMAT,IDIM,IDIM,
  234. C $ IMPR,IRET)
  235. C IF (IRET.NE.0) GOTO 9999
  236. C STOP 16
  237. C TR1=0.D0
  238. C SEGPRT,M1
  239. C SEGPRT,M2
  240. C SEGPRT,M3
  241. C DO IIDIM=1,IDIM
  242. C TR1=TR1+(M3.XMAT(IDIM1,IIDIM)*JM1.XMAT(IDIM4,IIDIM)
  243. C $ *JM1.XMAT(IDIM2,IDIM3))
  244. C ENDDO
  245. C WRITE(IOIMP,*) 'TR1=',TR1
  246. C WRITE(IOIMP,*) 'DET=',DET
  247. C WRITE(IOIMP,*) 'SDET=',SDET
  248. C CONTRI=TR1*DET*SDET
  249. ELSE
  250. WRITE(IOIMP,*) 'Erreur grave'
  251. GOTO 9999
  252. ENDIF
  253. FC.VELCHE(1,1,1,1,IPFC,ILFC)=
  254. $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+
  255. $ CONTRI
  256. ENDDO
  257. ENDDO
  258. *g SEGSUP,M3
  259. *g SEGSUP,M2
  260. *g SEGSUP,M1
  261. *g SEGSUP,JM1
  262. *g SEGSUP,JAC
  263. *
  264. * Normal termination
  265. *
  266. IRET=0
  267. RETURN
  268. *
  269. * Format handling
  270. *
  271. *
  272. * Error handling
  273. *
  274. 9999 CONTINUE
  275. IRET=1
  276. WRITE(IOIMP,*) 'An error was detected in subroutine ccgadv'
  277. RETURN
  278. *
  279. * End of subroutine CCGADV
  280. *
  281. END
  282.  
  283.  
  284.  
  285.  

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