Télécharger ccgtsu.eso

Retour à la liste

Numérotation des lignes :

  1. C CCGTSU SOURCE GOUNAND 11/04/29 21:15:21 6947
  2. SUBROUTINE CCGTSU(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 : CCGTSU
  9. C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss :
  10. C Tension de surface
  11. C
  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, 17/01/07, version initiale
  26. C HISTORIQUE : v1, 17/01/07, création
  27. C HISTORIQUE :
  28. C HISTORIQUE :
  29. C***********************************************************************
  30. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  31. C en cas de modification de ce sous-programme afin de faciliter
  32. C la maintenance !
  33. C***********************************************************************
  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 JPC.MCHEVA
  56. POINTEUR JTS.MCHEVA
  57. CHARACTER*8 NOMLOI
  58. INTEGER ICOF
  59. *
  60. -INC TMXMAT
  61. POINTEUR JAC.MXMAT,JT.MXMAT
  62. POINTEUR G.MXMAT
  63. POINTEUR IG.MXMAT
  64. POINTEUR JPT.MXMAT
  65. POINTEUR JPTJT.MXMAT
  66. *
  67. LOGICAL LBID
  68. INTEGER LAXSP
  69. REAL*8 DEUPI,QUATPI,XR
  70. PARAMETER (DEUPI=2.D0*XPI,QUATPI=4.D0*XPI)
  71. *
  72. INTEGER IMPR,IRET
  73. *
  74. * Executable statements
  75. *
  76. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgtsu'
  77. C IF (.NOT.(IDIM.EQ.1)) THEN
  78. C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  79. C GOTO 9999
  80. C ENDIF
  81. NLFC=FC.VELCHE(/6)
  82. NPFC=FC.VELCHE(/5)
  83. ICOF=0
  84. *
  85. * Récupération du coefficent de tension de surface
  86. *
  87. ICOF=ICOF+1
  88. JTS =LCOF.LISCHE(ICOF)
  89. NLTS=JTS.VELCHE(/6)
  90. NPTS=JTS.VELCHE(/5)
  91. *
  92. ICOF=ICOF+1
  93. JMAJAC=LCOF.LISCHE(ICOF)
  94. NLJA=JMAJAC.VELCHE(/6)
  95. NPJA=JMAJAC.VELCHE(/5)
  96. IREF=JMAJAC.VELCHE(/4)
  97. IREL=JMAJAC.VELCHE(/3)
  98. *
  99. IF (IREL.NE.IDIM) THEN
  100. WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  101. GOTO 9999
  102. ENDIF
  103. *
  104. ICOF=ICOF+1
  105. ICOF=ICOF+1
  106. ICOF=ICOF+1
  107. *
  108. *! WRITE(IOIMP,*) 'IFOMOD=',IFOMOD
  109. IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.4) THEN
  110. *! WRITE(IOIMP,*) 'MODE AXISYMETRIQUE !!!!!!'
  111. LAXSP=1
  112. ELSEIF (IFOMOD.EQ.5) THEN
  113. *! WRITE(IOIMP,*) 'MODE SPHERIQUE !!!!!!'
  114. LAXSP=2
  115. ELSE
  116. *! WRITE(IOIMP,*) 'MODE PLAN !!!!!!'
  117. LAXSP=0
  118. ENDIF
  119. *! WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  120. *! WRITE(IOIMP,*) 'LAXSP=',LAXSP
  121. *
  122. IF (LAXSP.GT.0) THEN
  123. ICOF=ICOF+1
  124. ICOF=ICOF+1
  125. JPC=LCOF.LISCHE(ICOF)
  126. NLPC=JPC.VELCHE(/6)
  127. NPPC=JPC.VELCHE(/5)
  128. IF (((NLPC.NE.1).AND.(NLPC.NE.NLFC)).OR.
  129. $ ((NPPC.NE.1).AND.(NPPC.NE.NPFC))) THEN
  130. WRITE(IOIMP,*) 'Erreur dims JPC'
  131. GOTO 9999
  132. ENDIF
  133. ELSE
  134. JPC=0
  135. NLPC=0
  136. NPPC=0
  137. ENDIF
  138. *
  139. * Objets temporaires
  140. *
  141. LDIM1=IREL
  142. LDIM2=IREF
  143. SEGINI,JAC
  144. SEGINI,JPT
  145. LDIM1=IREF
  146. LDIM2=IREL
  147. SEGINI,JT
  148. LDIM1=IREF
  149. LDIM2=IREF
  150. SEGINI,G
  151. SEGINI,IG
  152. LDIM1=IREL
  153. LDIM2=IREL
  154. SEGINI,JPTJT
  155. *
  156. DO ILFC=1,NLFC
  157. IF (NLTS.EQ.1) THEN
  158. ILTS=1
  159. ELSE
  160. ILTS=ILFC
  161. ENDIF
  162. IF (NLJA.EQ.1) THEN
  163. ILJA=1
  164. ELSE
  165. ILJA=ILFC
  166. ENDIF
  167. IF (NLPC.EQ.1) THEN
  168. ILPC=1
  169. ELSE
  170. ILPC=ILFC
  171. ENDIF
  172.  
  173.  
  174. DO IPFC=1,NPFC
  175. IF (NPTS.EQ.1) THEN
  176. IPTS=1
  177. ELSE
  178. IPTS=IPFC
  179. ENDIF
  180. IF (NPJA.EQ.1) THEN
  181. IPJA=1
  182. ELSE
  183. IPJA=IPFC
  184. ENDIF
  185. IF (NPPC.EQ.1) THEN
  186. IPPC=1
  187. ELSE
  188. IPPC=IPFC
  189. ENDIF
  190. *
  191. * Valeur du coefficient
  192. *
  193. IF (JTS.NE.0) THEN
  194. XTS=JTS.VELCHE(1,1,1,1,IPTS,ILTS)
  195. ENDIF
  196. *
  197. * Première coordonnée
  198. *
  199. IF (JPC.NE.0) THEN
  200. XR=JPC.VELCHE(1,1,1,1,IPPC,ILPC)
  201. ENDIF
  202. *
  203. * Copie du jacobien
  204. *
  205. CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  206. $ 'COPIE ',
  207. $ JAC.XMAT,IREL,IREF,
  208. $ IMPR,IRET)
  209. IF (IRET.NE.0) GOTO 9999
  210. C SEGPRT,JAC
  211. *
  212. * Calcul de la métrique G
  213. *
  214. * Calcul de Jt
  215. CALL MAMA(JAC.XMAT,IREL,IREF,
  216. $ 'TRANSPOS',JT.XMAT,IREF,IREL,
  217. $ IMPR,IRET)
  218. IF (IRET.NE.0) GOTO 9999
  219. * Calcul de G=JtJ
  220. CALL MAMAMA(JT.XMAT,IREF,IREL,JAC.XMAT,IREL,IREF,
  221. $ 'FOIS ',G.XMAT,IREF,IREF,
  222. $ IMPR,IRET)
  223. IF (IRET.NE.0) GOTO 9999
  224. *
  225. * Calcul de l'inverse, du déterminant et trace de l'inverse
  226. *
  227. LBID=.FALSE.
  228. CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,LBID,IMPR,IRET)
  229. IF (IRET.NE.0) GOTO 9999
  230. SDETG=SQRT(DETG)
  231. * Calcul de JPT=J (JtJ)-1
  232. CALL MAMAMA(JAC.XMAT,IREL,IREF,IG.XMAT,IREF,IREF,
  233. $ 'FOIS ',JPT.XMAT,IREL,IREF,
  234. $ IMPR,IRET)
  235. IF (IRET.NE.0) GOTO 9999
  236. * Calcul de JPT=J (JtJ)-1
  237. CALL MAMAMA(JPT.XMAT,IREL,IREF,JT.XMAT,IREF,IREL,
  238. $ 'FOIS ',JPTJT.XMAT,IREL,IREL,
  239. $ IMPR,IRET)
  240. IF (IRET.NE.0) GOTO 9999
  241. *
  242. * Calcul de la fonctionnelle
  243. *
  244. IF (NOMLOI.EQ.'TSUF ') THEN
  245. CONTRI=XTS*SDETG
  246. IF (LAXSP.EQ.1) THEN
  247. CONTRI=CONTRI*2.D0*XPI*XR
  248. ELSEIF (LAXSP.EQ.2) THEN
  249. CONTRI=CONTRI*4.D0*XPI*XR*XR
  250. ENDIF
  251. *
  252. * Calcul du résidu
  253. *
  254. ELSEIF (NOMLOI(1:4).EQ.'TSUR') THEN
  255. CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  256. IF (IRET.NE.0) GOTO 9999
  257. CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  258. IF (IRET.NE.0) GOTO 9999
  259. IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  260. IF (LAXSP.EQ.1) THEN
  261. CONTRI=XTS*2.D0*XPI*SDETG
  262. ELSEIF (LAXSP.EQ.2) THEN
  263. CONTRI=XTS*8.D0*XPI*XR*SDETG
  264. ELSE
  265. WRITE(IOIMP,*) 'LAXSP=',LAXSP
  266. GOTO 9999
  267. ENDIF
  268. ELSE
  269. CONTRI=XTS*SDETG*JPT.XMAT(IDIM1,IDIM2)
  270. IF (LAXSP.EQ.1) THEN
  271. CONTRI=CONTRI*DEUPI*XR
  272. ELSEIF (LAXSP.EQ.2) THEN
  273. CONTRI=CONTRI*QUATPI*XR*XR
  274. ENDIF
  275. ENDIF
  276. *
  277. * Calcul du jacobien
  278. *
  279. ELSEIF (NOMLOI(1:4).EQ.'TSUJ') THEN
  280. CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  281. IF (IRET.NE.0) GOTO 9999
  282. CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  283. IF (IRET.NE.0) GOTO 9999
  284. CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  285. IF (IRET.NE.0) GOTO 9999
  286. CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  287. IF (IRET.NE.0) GOTO 9999
  288. IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)
  289. $ .AND.(IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  290. IF (LAXSP.EQ.2) THEN
  291. CONTRI=XTS*8.D0*XPI*SDETG
  292. ELSE
  293. WRITE(IOIMP,*) 'LAXSP=',LAXSP
  294. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  295. GOTO 9999
  296. ENDIF
  297. ELSEIF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  298. IF (LAXSP.GE.1) THEN
  299. CONTRI=XTS*DEUPI*SDETG*JPT.XMAT(IDIM3,IDIM4)
  300. IF (LAXSP.EQ.2) THEN
  301. CONTRI=CONTRI*4.D0*XR
  302. ENDIF
  303. ELSE
  304. WRITE(IOIMP,*) 'LAXSP=',LAXSP
  305. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  306. GOTO 9999
  307. ENDIF
  308. ELSEIF ((IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  309. IF (LAXSP.GE.1) THEN
  310. CONTRI=XTS*DEUPI*SDETG*JPT.XMAT(IDIM1,IDIM2)
  311. IF (LAXSP.EQ.2) THEN
  312. CONTRI=CONTRI*4.D0*XR
  313. ENDIF
  314. ELSE
  315. WRITE(IOIMP,*) 'LAXSP=',LAXSP
  316. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  317. GOTO 9999
  318. ENDIF
  319. ELSE
  320. CONTRI=JPT.XMAT(IDIM1,IDIM2)*JPT.XMAT(IDIM3,IDIM4)
  321. IF (IDIM1.EQ.IDIM3) THEN
  322. CONTRI=CONTRI+IG.XMAT(IDIM2,IDIM4)
  323. ENDIF
  324. CONTRI=CONTRI-
  325. $ (JPTJT.XMAT(IDIM1,IDIM3)*IG.XMAT(IDIM2,IDIM4))
  326. CONTRI=CONTRI-
  327. $ (JPT.XMAT(IDIM3,IDIM2)*JPT.XMAT(IDIM1,IDIM4))
  328. CONTRI=CONTRI*XTS*SDETG
  329. IF (LAXSP.EQ.1) THEN
  330. CONTRI=CONTRI*DEUPI*XR
  331. ELSEIF (LAXSP.EQ.2) THEN
  332. CONTRI=CONTRI*QUATPI*XR*XR
  333. ENDIF
  334. ENDIF
  335. *
  336. * Calcul d'une partie du jacobien
  337. *
  338. ELSEIF (NOMLOI(1:3).EQ.'TSU') THEN
  339. CALL CH2INT(NOMLOI(4:4),IDIM0,IMPR,IRET)
  340. IF (IRET.NE.0) GOTO 9999
  341. CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  342. IF (IRET.NE.0) GOTO 9999
  343. CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  344. IF (IRET.NE.0) GOTO 9999
  345. CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  346. IF (IRET.NE.0) GOTO 9999
  347. CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  348. IF (IRET.NE.0) GOTO 9999
  349. IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)
  350. $ .AND.(IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  351. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  352. GOTO 9999
  353. ELSEIF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  354. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  355. GOTO 9999
  356. ELSEIF ((IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  357. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  358. GOTO 9999
  359. ELSE
  360. IF (IDIM0.EQ.1) THEN
  361. CONTRI=JPT.XMAT(IDIM1,IDIM2)*JPT.XMAT(IDIM3,IDIM4)
  362. ELSEIF (IDIM0.EQ.2) THEN
  363. IF (IDIM1.EQ.IDIM3) THEN
  364. CONTRI=IG.XMAT(IDIM2,IDIM4)
  365. ELSE
  366. CONTRI=0.D0
  367. ENDIF
  368. ELSEIF (IDIM0.EQ.3) THEN
  369. CONTRI=
  370. $ -(JPTJT.XMAT(IDIM1,IDIM3)*IG.XMAT(IDIM2,IDIM4)
  371. $ )
  372. ELSEIF (IDIM0.EQ.4) THEN
  373. CONTRI=-(JPT.XMAT(IDIM3,IDIM2)*JPT.XMAT(IDIM1,IDIM4
  374. $ ))
  375. ELSE
  376. WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  377. GOTO 9999
  378. ENDIF
  379. CONTRI=CONTRI*XTS*SDETG
  380. IF (LAXSP.EQ.1) THEN
  381. CONTRI=CONTRI*DEUPI*XR
  382. ELSEIF (LAXSP.EQ.2) THEN
  383. CONTRI=CONTRI*QUATPI*XR*XR
  384. ENDIF
  385. ENDIF
  386. *! WRITE(IOIMP,*) 'CONTRI=',CONTRI
  387. ELSE
  388. WRITE(IOIMP,*) 'Erreur grave'
  389. GOTO 9999
  390. ENDIF
  391. FC.VELCHE(1,1,1,1,IPFC,ILFC)=
  392. $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+
  393. $ CONTRI
  394. ENDDO
  395. ENDDO
  396. SEGSUP,JPTJT
  397. SEGSUP,JPT
  398. SEGSUP,IG
  399. SEGSUP,G
  400. SEGSUP,JT
  401. SEGSUP,JAC
  402. *
  403. * Normal termination
  404. *
  405. IRET=0
  406. RETURN
  407. *
  408. * Format handling
  409. *
  410. *
  411. * Error handling
  412. *
  413. 9999 CONTINUE
  414. IRET=1
  415. WRITE(IOIMP,*) 'An error was detected in subroutine ccgtsu'
  416. RETURN
  417. *
  418. * End of subroutine CCGTSU
  419. *
  420. END
  421.  
  422.  
  423.  
  424.  
  425.  
  426.  
  427.  

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