Télécharger cadgsi.eso

Retour à la liste

Numérotation des lignes :

  1. C CADGSI SOURCE GF238795 18/02/01 21:15:01 9724
  2. SUBROUTINE CADGSI
  3. C************************************************************************
  4. C
  5. C OBJET :
  6. C
  7. C CALCUL DE LA MATRICE MASSE DIAGONALE ---> Creation d'un CHAMPOIN
  8. C Pour les SOMMETS D0=NI ( MASSE LUMPE )
  9. C Pour les FACES D0=1/2(Vol1 + Vol2)
  10. C Pour les CENTRES D0=Vol Elt
  11. C
  12. C SYNTAXE :
  13. C
  14. C RES = DGSI OBJ1 <TYPE> <'IMPR'> ;
  15. C
  16. C OBJ1 : Table DOMAINE
  17. C TYPE ; SOMMET , FACE , CENTRE (par defaut SOMMET) MSOMMET CENTREP1
  18. C
  19. C
  20. C************************************************************************
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8 (A-H,O-Z)
  23. INTEGER INEFMD
  24. -INC CCGEOME
  25. -INC SMCHAML
  26. -INC CCOPTIO
  27. -INC SMELEME
  28. POINTEUR MELEMP.MELEME
  29. -INC SMTABLE
  30. POINTEUR MTABD.MTABLE
  31. -INC SMCOORD
  32. -INC SMLENTI
  33. -INC SMCHPOI
  34. -INC SIZFFB
  35. POINTEUR IZF1.IZFFM,IZH2.IZHR
  36. CHARACTER*8 NOM0,CHAI,LISMO(5),TYPE,TYPC,NOM
  37. DATA LISMO/'SOMMET ','FACE ','CENTRE ','MSOMMET ','CENTREP1'/
  38. C ***************************************************************
  39. C----------------------------------------------------------------------
  40. C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 5-> MSOMMET
  41. C INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE, INEFMD=4 LINB
  42. C************************************************************************
  43.  
  44.  
  45. INEFMD=0
  46. IKAS=1
  47. IMPR=0
  48. IAXI=0
  49. IF(IFOMOD.EQ.0)IAXI=2
  50.  
  51. CALL LITABS('DOMAINE ',MTABD,1,1,IRET)
  52. IF(IRET.EQ.0)THEN
  53. WRITE(6,*)' On attend une table de soustype DOMAINE'
  54. RETURN
  55. ENDIF
  56.  
  57. 19 CONTINUE
  58. CALL LIRCHA(CHAI,0,IRET)
  59. IF(IRET.EQ.0)GO TO 20
  60. CALL OPTLI(IP,LISMO,CHAI,5)
  61. IF(IP.EQ.0)THEN
  62. WRITE(6,*)' On attend un mot cle parmi SOMMET FACE CENTRE ',
  63. & 'MSOMMET CENTREP1 '
  64. RETURN
  65. ENDIF
  66. IKAS=IP
  67.  
  68. 20 CONTINUE
  69.  
  70. IF(IKAS.EQ.1.OR.IKAS.EQ.4)THEN
  71. C SOMMET et MSOMMET
  72. C SOMMET
  73. IF(IKAS.EQ.1)THEN
  74. TYPE=' '
  75. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  76. IF(TYPE.NE.'MAILLAGE')RETURN
  77. TYPE=' '
  78. CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
  79. IF(TYPE.NE.'MAILLAGE')RETURN
  80. CALL CRCHPT('SOMMET',MELEMS,1,MCHPOI)
  81. ENDIF
  82. C MSOMMET
  83. IF(IKAS.EQ.4)THEN
  84. c write(6,*)' CADGSI: IKAS=4'
  85. TYPE=' '
  86. CALL ACMO(MTABD,'MMAIL ',TYPE,MELEME)
  87. IF(TYPE.NE.'MAILLAGE')RETURN
  88. TYPE=' '
  89. CALL ACMO(MTABD,'MSOMMET',TYPE,MELEMS)
  90. IF(TYPE.NE.'MAILLAGE')RETURN
  91. CALL CRCHPT('MSOMMET',MELEMS,1,MCHPOI)
  92. ENDIF
  93.  
  94. CALL KRIPAD(MELEMS,MLENTI)
  95.  
  96. C CREATION DE LA DIAGONALE
  97. CALL LICHTM(MCHPOI,MPOVAL,TYPC,IGEOM)
  98. SEGACT MELEME
  99. NBSOUS=LISOUS(/1)
  100. IF(NBSOUS.EQ.0)NBSOUS=1
  101. C
  102. C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
  103. C
  104. DO 1 KSOUS=1,NBSOUS
  105. IF(NBSOUS.EQ.1)IPT1=MELEME
  106. IF(NBSOUS.GT.1)IPT1=LISOUS(KSOUS)
  107. SEGACT IPT1
  108.  
  109. NP=IPT1.NUM(/1)
  110. NEL=IPT1.NUM(/2)
  111. C
  112. NOM0=NOMS(IPT1.ITYPEL)//' '
  113. IF(INEFMD.EQ.1.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'P1P1'
  114. IF(INEFMD.EQ.2.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCF1'
  115. IF(INEFMD.EQ.3.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PFP1'
  116. c write(6,*)'4 NOM0=',NOM0
  117. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  118. SEGACT IZFFM*MOD
  119. IZHR=KZHR(1)
  120. SEGACT IZHR*MOD
  121. C
  122. NPG=FN(/2)
  123. NES=GR(/1)
  124.  
  125. IF(IMPR.NE.0)THEN
  126. WRITE(6,*)' SUB CADGSI : NES,NP,NPG,IDIM,NEL='
  127. & ,NES,NP,NPG,IDIM,NEL
  128. ENDIF
  129. C
  130. DO 10 K=1,NEL
  131. C
  132. NPGR=0
  133. IF(IAXI.NE.0)NPGR=NPG
  134. C
  135. DO 12 I=1,NP
  136. J=IPT1.NUM(I,K)
  137. DO 12 N=1,IDIM
  138. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  139. 12 CONTINUE
  140.  
  141. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
  142.  
  143. IF(IMPR.NE.0)THEN
  144. WRITE(6,*)' SUB CADGSI : AIRE=',AIRE
  145. WRITE(6,*)' SUB CADGSI : LER '
  146. WRITE(6,1001)(IPT1.NUM(I,K),I=1,NP)
  147. WRITE(6,*)' SUB CADGSI : XYZ '
  148. WRITE(6,1002)((XYZ(N,I),N=1,2),I=1,NP)
  149. ENDIF
  150. C
  151. DO 3 J=1,NP
  152. SJ=0.D0
  153. DO 4 L=1,NPG
  154. SJ=SJ+FN(J,L)*PGSQ(L)
  155. 4 CONTINUE
  156. C SD(J,K)=SJ
  157. JU=LECT(IPT1.NUM(J,K))
  158. C D0(JU)=D0(JU)+SJ
  159. VPOCHA(JU,1)=VPOCHA(JU,1)+SJ
  160. 3 CONTINUE
  161. C
  162. 10 CONTINUE
  163.  
  164. SEGDES IPT1
  165. SEGSUP IZFFM,IZHR
  166. 1 CONTINUE
  167. SEGDES MELEME
  168. SEGSUP MLENTI
  169. SEGDES MPOVAL
  170.  
  171. IF(IMPR.NE.0)THEN
  172. WRITE(6,*)' SUB CADGSI : CALCUL DE LA DIAGONALE'
  173. C WRITE(6,1003)(I,VPOCHA(I,1),I=1,NPT)
  174. WRITE(6,*)' FIN DE CADGSI'
  175. ENDIF
  176.  
  177. C FACE
  178. ELSEIF(IKAS.EQ.2)THEN
  179.  
  180. TYPE=' '
  181. CALL ACMO(MTABD,'FACE',TYPE,MELEMF)
  182. IF(TYPE.NE.'MAILLAGE')RETURN
  183. TYPE=' '
  184. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  185. IF(TYPE.NE.'MAILLAGE')RETURN
  186. CALL LEKTAB(MTABD,'FACEL',MELEME)
  187. IF(MELEME.EQ.0)RETURN
  188. CALL LEKTAB(MTABD,'XXVOLUM',MCHPO1)
  189. IF(MCHPO1.EQ.0)RETURN
  190.  
  191. CALL KRIPAD(MELEMC,MLENT1)
  192. CALL KRIPAD(MELEMF,MLENT2)
  193.  
  194. C CREATION DE LA DIAGONALE
  195. CALL CRCHPT('FACE',MELEMF,1,MCHPOI)
  196. CALL LICHTM(MCHPOI,MPOVAL,TYPC,IGEOM)
  197. CALL LICHTM(MCHPO1,MPOVA1,TYPC,IGEOM)
  198. SEGACT MELEME
  199. C
  200. C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
  201. C
  202. NBEL=NUM(/2)
  203. DO 2 K=1,NBEL
  204. I1=NUM(1,K)
  205. I2=NUM(2,K)
  206. I3=NUM(3,K)
  207. I1=MLENT1.LECT(I1)
  208. I2=MLENT2.LECT(I2)
  209. I3=MLENT1.LECT(I3)
  210. V=(MPOVA1.VPOCHA(I1,1)+MPOVA1.VPOCHA(I3,1) )*0.5D0
  211. VPOCHA(I2,1)=V
  212. 2 CONTINUE
  213.  
  214. SEGDES MELEME
  215. SEGDES MPOVA1,MPOVAL
  216. SEGSUP MLENT1,MLENT2
  217.  
  218. ELSEIF(IKAS.EQ.3)THEN
  219. C CENTRE
  220. CALL LEKTAB(MTABD,'XXVOLUM',MCHPOI)
  221. IF(MCHPOI.EQ.0)RETURN
  222.  
  223. ELSEIF(IKAS.EQ.5.OR.IKAS.EQ.6)THEN
  224. C CENTREP1 et CENTREP0
  225.  
  226. CALL ACME(MTABD,'INEFMD',INEFMD)
  227.  
  228. IF(INEFMD.EQ.1)THEN
  229. C% Le type d'élément fini %m1:8 ne convient pas.
  230. MOTERR( 1: 8) = 'LINE'
  231. CALL ERREUR(927)
  232. RETURN
  233. ENDIF
  234.  
  235. TYPE = ' '
  236. CALL ACMO(MTABD,'XXPSOML',TYPE,MCHELM)
  237. TYPE = ' '
  238. IF (TYPE.NE.'MCHAML ') THEN
  239. CALL ECROBJ('TABLE',MTABD)
  240. CALL KPSOML
  241. TYPE = 'MCHAML'
  242. CALL LIROBJ(TYPE,MCHELM,1,IRET)
  243. IF (IRET.EQ.0)THEN
  244. NOM='XXPSOML'
  245. GOTO 5000
  246. ENDIF
  247. CALL ECMO(MTABD,'XXPSOML','MCHAML',MCHELM)
  248. ENDIF
  249. SEGACT MCHELM
  250.  
  251. TYPE=' '
  252. IF(INEFMD.EQ.2)THEN
  253. CALL ACMO(MTABD,'MACRO1 ',TYPE,MELEME)
  254. IF(TYPE.NE.'MAILLAGE')RETURN
  255. ELSEIF(INEFMD.EQ.3)THEN
  256. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  257. NOM='MAILLAGE'
  258. IF(TYPE.NE.'MAILLAGE')GO TO 5000
  259. ENDIF
  260.  
  261. TYPE=' '
  262. CALL ACMO(MTABD,'CENTREP1',TYPE,MELEMS)
  263. IF(TYPE.NE.'MAILLAGE')THEN
  264. CALL KCTRP1(MTABD,MELEMS,1)
  265. ENDIF
  266. CALL KRIPAD(MELEMS,MLENTI)
  267. CALL ACMO(MTABD,'ELTP1NC ',TYPE,MELEMP)
  268. NOM='ELTP1NC '
  269. IF(TYPE.NE.'MAILLAGE')GO TO 5000
  270. CALL CRCHPT('CENTREP1',MELEMS,1,MCHPOI)
  271.  
  272.  
  273. CALL LICHTM(MCHPOI,MPOVAL,TYPC,IGEOM)
  274. SEGACT MELEME
  275. NBSOUS=LISOUS(/1)
  276. IF(NBSOUS.EQ.0)NBSOUS=1
  277. NUTOEL=0
  278.  
  279. NPTD=VPOCHA(/1)
  280. IES=IDIM
  281. MP10=0
  282.  
  283. DO 11 L=1,NBSOUS
  284. IPT1=MELEME
  285. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  286. SEGACT IPT1
  287.  
  288. MCHAML=ICHAML(L)
  289. SEGACT MCHAML
  290. MELVAL=IELVAL(1)
  291. SEGACT MELVAL
  292.  
  293. NP =IPT1.NUM(/1)
  294. NBEL=IPT1.NUM(/2)
  295.  
  296. IPT2=MELEMP
  297. IF(NBSOUS.NE.1)IPT2=LISOUS(L)
  298. SEGACT IPT2
  299.  
  300. IF(INEFMD.EQ.2.AND.IKAS.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'MCP1'
  301. IF(INEFMD.EQ.3.AND.IKAS.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'PRP1'
  302.  
  303. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  304.  
  305.  
  306. SEGACT IZFFM*MOD
  307. IZHR=KZHR(1)
  308. IZH2=KZHR(2)
  309. SEGACT IZHR*MOD,IZH2*MOD
  310. NES=GR(/1)
  311. NPG=GR(/3)
  312. IZF1=KTP(1)
  313. SEGACT IZF1*MOD
  314. MP1=IZF1.FN(/1)
  315. NP = IPT1.NUM(/1)
  316.  
  317. DO 21 K=1,NBEL
  318. DO 109 I=1,NP
  319. J=IPT1.NUM(I,K)
  320. JC = (J-1)*(IDIM+1)
  321. DO 109 N=1,IDIM
  322. XYZ(N,I)=XCOOR( JC + N )
  323. 109 CONTINUE
  324.  
  325. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
  326.  
  327. DO 39 M=1,MP1
  328. M11=LECT(IPT2.NUM(M,K))
  329. M1=M+MP10
  330. c IF(KPOIND.EQ.5)M1=M11
  331.  
  332. U=0.D0
  333. DO 33 LL=1,NPG
  334. U=U+IZF1.FN(M,LL)*PGSQ(LL)
  335. 33 CONTINUE
  336.  
  337. VPOCHA(M1,1)=VPOCHA(M1,1)+U
  338. 39 CONTINUE
  339.  
  340. MP10=MP10+MP1
  341. 21 CONTINUE
  342.  
  343. SEGSUP IZFFM,IZF1,IZHR,IZH2
  344.  
  345.  
  346. SEGDES IPT1,MCHAML,MELVAL,IPT2
  347. NUTOEL=NUTOEL+NBEL
  348.  
  349. 11 CONTINUE
  350.  
  351. SEGSUP MLENTI
  352.  
  353. ENDIF
  354.  
  355.  
  356. SEGDES MTABD,MPOVAL,MCHPOI
  357. CALL ECROBJ('CHPOINT',MCHPOI)
  358. RETURN
  359. 5000 CONTINUE
  360. C Indice %m1:8 : Problème de données détecté dans lektab
  361. IPOINT = 0
  362. MOTERR(1:8) = NOM
  363. CALL ERREUR(792)
  364. RETURN
  365. 1001 FORMAT(20(1X,I5))
  366. 1002 FORMAT(10(1X,1PE11.4))
  367. 1003 FORMAT(6(1X,I7,1X,1PE11.4))
  368. END
  369.  
  370.  
  371.  
  372.  
  373.  
  374.  
  375.  
  376.  

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