Télécharger ccgadv.eso

Retour à la liste

Numérotation des lignes :

ccgadv
  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 PPARAM
  34. -INC CCOPTIO
  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. CHARACTER*8 NOMLOI
  54. INTEGER ICOF
  55. *
  56. -INC TMXMAT
  57. POINTEUR JAC.MXMAT
  58. POINTEUR JM1.MXMAT
  59. POINTEUR M1.MXMAT
  60. POINTEUR M2.MXMAT
  61. POINTEUR M3.MXMAT
  62. *
  63. INTEGER IMPR,IRET
  64. *
  65. * Executable statements
  66. *
  67. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgadv'
  68. C IF (.NOT.(IDIM.EQ.1)) THEN
  69. C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  70. C GOTO 9999
  71. C ENDIF
  72. NLFC=FC.VELCHE(/6)
  73. NPFC=FC.VELCHE(/5)
  74. ICOF=0
  75. *
  76. ICOF=ICOF+1
  77. JMAJAC=LCOF.LISCHE(ICOF)
  78. NLJA=JMAJAC.VELCHE(/6)
  79. NPJA=JMAJAC.VELCHE(/5)
  80. ICOF=ICOF+1
  81. JMIJAC=LCOF.LISCHE(ICOF)
  82. NLJI=JMIJAC.VELCHE(/6)
  83. NPJI=JMIJAC.VELCHE(/5)
  84. ICOF=ICOF+1
  85. JDTJAC=LCOF.LISCHE(ICOF)
  86. NLJD=JDTJAC.VELCHE(/6)
  87. NPJD=JDTJAC.VELCHE(/5)
  88. *g LDIM1=JMAJAC.VELCHE(/3)
  89. *g LDIM2=JMAJAC.VELCHE(/4)
  90. *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
  91. *g WRITE(IOIMP,*) 'Erreur grave 1'
  92. *g GOTO 9999
  93. *g ENDIF
  94. *g SEGINI,JAC
  95. *g LDIM1=JMIJAC.VELCHE(/3)
  96. *g LDIM2=JMIJAC.VELCHE(/4)
  97. *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
  98. *g WRITE(IOIMP,*) 'Erreur grave 2'
  99. *g GOTO 9999
  100. *g ENDIF
  101. *g SEGINI,JM1
  102. *
  103. * Objet temporaire
  104. *
  105. *g LDIM1=IDIM
  106. *g LDIM2=IDIM
  107. *g SEGINI,M1
  108. *g SEGINI,M2=M1
  109. *g SEGINI,M3=M1
  110. DO ILFC=1,NLFC
  111. IF (NLJA.EQ.1) THEN
  112. ILJA=1
  113. ELSE
  114. ILJA=ILFC
  115. ENDIF
  116. IF (NLJI.EQ.1) THEN
  117. ILJI=1
  118. ELSE
  119. ILJI=ILFC
  120. ENDIF
  121. IF (NLJD.EQ.1) THEN
  122. ILJD=1
  123. ELSE
  124. ILJD=ILFC
  125. ENDIF
  126. DO IPFC=1,NPFC
  127. IF (NPJA.EQ.1) THEN
  128. IPJA=1
  129. ELSE
  130. IPJA=IPFC
  131. ENDIF
  132. IF (NPJI.EQ.1) THEN
  133. IPJI=1
  134. ELSE
  135. IPJI=IPFC
  136. ENDIF
  137. IF (NPJD.EQ.1) THEN
  138. IPJD=1
  139. ELSE
  140. IPJD=IPFC
  141. ENDIF
  142. C CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IDIM,IDIM
  143. C $ 'COPIE ',
  144. C $ JAC.XMAT,IDIM,IDIM,
  145. C $ IMPR,IRET)
  146. C IF (IRET.NE.0) GOTO 9999
  147. *g CALL MAMA(JMIJAC.VELCHE(1,1,1,1,IPJI,ILJI),IDIM,IDIM,
  148. *g $ 'COPIE ',
  149. *g $ JM1.XMAT,IDIM,IDIM,
  150. *g $ IMPR,IRET)
  151. *g IF (IRET.NE.0) GOTO 9999
  152. DET =JDTJAC.VELCHE(1,1,1,1,IPJD,ILJD)
  153. SDET =SIGN(1.D0,DET)
  154. IF (NOMLOI.EQ.'VOLORI ') THEN
  155. CONTRI=DET
  156. C ELSEIF (NOMLOI.EQ.'ADAF ') THEN
  157. C CALL ERREUR(5)
  158. CC WRITE(IOIMP,*) 'J-1=',JM1.XMAT(1,1)
  159. CC WRITE(IOIMP,*) 'DET=',DET
  160. CC WRITE(IOIMP,*) 'SDET=',SDET
  161. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  162. C $ 'TRJJT ',
  163. C $ TIJIJT,
  164. C $ IMPR,IRET)
  165. C IF (IRET.NE.0) GOTO 9999
  166. C CONTRI=0.5D0*TIJIJT*DET*SDET
  167. C ELSEIF (NOMLOI(1:4).EQ.'ADAR') THEN
  168. C CALL ERREUR(5)
  169. C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  170. C IF (IRET.NE.0) GOTO 9999
  171. C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  172. C IF (IRET.NE.0) GOTO 9999
  173. C CALL MAMA(JM1.XMAT,IDIM,IDIM,
  174. C $ 'JJT ',
  175. C $ M1.XMAT,IDIM,IDIM,
  176. C $ IMPR,IRET)
  177. C IF (IRET.NE.0) GOTO 9999
  178. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  179. C $ 'TRJJT ',
  180. C $ TIJIJT,
  181. C $ IMPR,IRET)
  182. C TR1=0.D0
  183. C DO IIDIM=1,IDIM
  184. C TR1=TR1+
  185. C $ (JM1.XMAT(IIDIM,IDIM1)*M1.XMAT(IDIM2,IIDIM))
  186. C ENDDO
  187. C TR2=JM1.XMAT(IDIM2,IDIM1)
  188. C CONTRI=((0.5D0*TIJIJT*TR2)-TR1)*DET*SDET
  189. C ELSEIF (NOMLOI(1:4).EQ.'ADAK') THEN
  190. C CALL ERREUR(5)
  191. C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  192. C IF (IRET.NE.0) GOTO 9999
  193. C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  194. C IF (IRET.NE.0) GOTO 9999
  195. C CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  196. C IF (IRET.NE.0) GOTO 9999
  197. C CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  198. C IF (IRET.NE.0) GOTO 9999
  199. C CALL MAMA(JM1.XMAT,IDIM,IDIM,
  200. C $ 'TRANSPOS',
  201. C $ M1.XMAT,IDIM,IDIM,
  202. C $ IMPR,IRET)
  203. C IF (IRET.NE.0) GOTO 9999
  204. C WRITE(IOIMP,*) 'transpos'
  205. C SEGPRT,JM1
  206. C SEGPRT,M1
  207. C CALL MAMA(M1.XMAT,IDIM,IDIM,
  208. C $ 'JJT ',
  209. C $ M2.XMAT,IDIM,IDIM,
  210. C $ IMPR,IRET)
  211. C IF (IRET.NE.0) GOTO 9999
  212. C WRITE(IOIMP,*) 'JJT'
  213. C SEGPRT,M1
  214. C SEGPRT,M2
  215. C CALL MARE(JM1.XMAT,IDIM,IDIM,
  216. C $ 'TRJJT ',
  217. C $ TIJIJT,
  218. C $ IMPR,IRET)
  219. C IF (IRET.NE.0) GOTO 9999
  220. C WRITE(IOIMP,*) 'trace JJT'
  221. C SEGPRT,JM1
  222. C WRITE(IOIMP,*) 'TRJJT=',TIJIJT
  223. C XX=-0.5D0*TIJIJT
  224. C CALL REMA(XX,IDIM,IDIM,
  225. C $ 'DIAGONAL',
  226. C $ M1.XMAT,
  227. C $ IMPR,IRET)
  228. C IF (IRET.NE.0) GOTO 9999
  229. C WRITE(IOIMP,*) 'diagonal'
  230. C WRITE(IOIMP,*) 'XX=',XX
  231. C SEGPRT,M1
  232. C CALL MAMAMA(M1.XMAT,IDIM,IDIM,M2.XMAT,IDIM,IDIM,
  233. C $ 'PLUS ',
  234. C $ M3.XMAT,IDIM,IDIM,
  235. C $ IMPR,IRET)
  236. C IF (IRET.NE.0) GOTO 9999
  237. C STOP 16
  238. C TR1=0.D0
  239. C SEGPRT,M1
  240. C SEGPRT,M2
  241. C SEGPRT,M3
  242. C DO IIDIM=1,IDIM
  243. C TR1=TR1+(M3.XMAT(IDIM1,IIDIM)*JM1.XMAT(IDIM4,IIDIM)
  244. C $ *JM1.XMAT(IDIM2,IDIM3))
  245. C ENDDO
  246. C WRITE(IOIMP,*) 'TR1=',TR1
  247. C WRITE(IOIMP,*) 'DET=',DET
  248. C WRITE(IOIMP,*) 'SDET=',SDET
  249. C CONTRI=TR1*DET*SDET
  250. ELSE
  251. WRITE(IOIMP,*) 'Erreur grave'
  252. GOTO 9999
  253. ENDIF
  254. FC.VELCHE(1,1,1,1,IPFC,ILFC)=
  255. $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+
  256. $ CONTRI
  257. ENDDO
  258. ENDDO
  259. *g SEGSUP,M3
  260. *g SEGSUP,M2
  261. *g SEGSUP,M1
  262. *g SEGSUP,JM1
  263. *g SEGSUP,JAC
  264. *
  265. * Normal termination
  266. *
  267. IRET=0
  268. RETURN
  269. *
  270. * Format handling
  271. *
  272. *
  273. * Error handling
  274. *
  275. 9999 CONTINUE
  276. IRET=1
  277. WRITE(IOIMP,*) 'An error was detected in subroutine ccgadv'
  278. RETURN
  279. *
  280. * End of subroutine CCGADV
  281. *
  282. END
  283.  
  284.  
  285.  
  286.  

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