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

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