Télécharger capa1.eso

Retour à la liste

Numérotation des lignes :

capa1
  1. C CAPA1 SOURCE CB215821 21/03/03 21:15:05 10910
  2.  
  3. C=======================================================================
  4. C= C A P A 1 =
  5. C= --------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= Calcul de la matrice de CAPACITE CALORIFIQUE (type RIGIDITE) =
  10. C= =
  11. C= Parametres : (E)=Entree (S)=Sortie =
  12. C= ------------ =
  13. C= IPMODE (E) Segment IMODEL pour un modele elementaire (ACTIF) =
  14. C= IPCHEL (E) Segment MCHELM de CARACTERISTIQUES (?) =
  15. C= ISUPC (E) Support du champ de CARACTERISTIQUES =
  16. C= ITABCP (E) TABLE pour le changement de PHASE =
  17. C= IPRIGI (E/S) Segment MRIGID : CAPACITE (ACTIF) =
  18. C= =
  19. C= Creation par Denis ROBERT le 15 fevrier 1988. =
  20. C= Modifications par DEGAY le 10 mai 1994 et ulterieurement. =
  21. C=======================================================================
  22.  
  23. SUBROUTINE CAPA1 (IPMODE,IPCHEL,ISUPC,ITABCP, IPRIGI)
  24.  
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8 (A-H,O-Z)
  27.  
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCHAMP
  32. -INC CCREEL
  33.  
  34. -INC SMELEME
  35. -INC SMMODEL
  36. POINTEUR NOMID1.NOMID,NOMID2.NOMID
  37. -INC SMRIGID
  38.  
  39. INTEGER OOOVAL
  40.  
  41. SEGMENT NOTYPE
  42. CHARACTER*16 TYPE(NBTYPE)
  43. ENDSEGMENT
  44.  
  45. SEGMENT MPTVAL
  46. INTEGER IPOS(NS),NSOF(NS), IVAL(NCOSOU)
  47. CHARACTER*16 TYVAL(NCOSOU)
  48. ENDSEGMENT
  49.  
  50. CHARACTER*8 CMATE
  51. CHARACTER*16 MOFOR
  52. CHARACTER*(LCONMO) CONM
  53.  
  54. PARAMETER ( NINF=3 )
  55. DIMENSION INFOS(NINF)
  56.  
  57. C= LEFMAS Liste des numeros d'elements finis MASSIFs implementes
  58. C= NEFMAS Longueur de cette liste =
  59. C= LEFCOQ Liste des numeros d'elements finis COQUEs implementes
  60. C= NEFCOQ Longueur de cette liste =
  61. PARAMETER (NEFMAS=14, NEFCOQ=5,neftuy=2)
  62. DIMENSION LEFMAS(NEFMAS), LEFCOQ(NEFCOQ),leftuy(neftuy)
  63.  
  64. C Elements TRI3 TRI6 QUA4 QUA8 CUB8 CU20 PRI6 PR15 TET4
  65. C MASSIFs TE10 PYR5 PY13 T1D2 T1D3
  66. DATA LEFMAS / 4, 6, 8, 10, 14, 15, 16, 17, 23,
  67. & 24, 25, 26, 191, 192 /
  68. C COQUEs COQ2 COQ3 COQ6 COQ4 COQ8
  69. DATA LEFCOQ / 44, 27, 56, 49, 41 /
  70. C Tuyau(pour advection)
  71. C TUY2 TUY3
  72. DATA leftuy/ 269 , 270/
  73.  
  74. IPINTE = 0
  75. IPINT2 = 0
  76. MOMATE = 0
  77. MOTYPE = 0
  78. IPCPHA = 0
  79. MOCPHA = 0
  80.  
  81. C- Matrice de capacite
  82. MRIGID = IPRIGI
  83. c* SEGACT,MRIGID
  84. NRIGE0 = IRIGEL(/2)
  85.  
  86. C- Recuperation du sous-modele et de la zone elementaire associee
  87. IMODEL = IPMODE
  88. C* SEGACT,IMODEL
  89.  
  90. NEF = NEFMOD
  91. MFR = NUMMFR(NEF)
  92. IF (NEF.EQ.22) RETURN
  93.  
  94. IMAS = 0
  95. ICOQ = 0
  96. ituy = 0
  97. CALL PLACE2(LEFMAS,NEFMAS,IMAS,NEF)
  98. CALL PLACE2(LEFCOQ,NEFCOQ,ICOQ,NEF)
  99. CALL PLACE2(LEFTUY,NEFTUY,ituy,NEF)
  100. C- Recuperation d'informations sur le maillage elementaire
  101. IPT1 = IMAMOD
  102. SEGACT,IPT1
  103. NBNOE1 = IPT1.NUM(/1)
  104. NBELE1 = IPT1.NUM(/2)
  105.  
  106. C- Quelques informations sur le modele
  107. CONM = CONMOD
  108. CMATE = CMATEE
  109. MATE = IMATEE
  110.  
  111. IRET = 1
  112.  
  113.  
  114. CALL IDENT(IPT1,CONM,IPCHEL,0, INFOS,IRET)
  115. IF (IRET.EQ.0) GOTO 9990
  116.  
  117. C- Recuperation d'informations sur l'element fini
  118. CALL TSHAPE(NEF,'GAUSS',IPINTE)
  119. IF (IERR.NE.0) GOTO 9990
  120. IF (ICOQ.NE.0) THEN
  121. IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN
  122. CALL TSHAPE(NEF,'NOEUD',IPINT2)
  123. ENDIF
  124. ENDIF
  125.  
  126. C- Recuperation des caracteristiques materielles (obligatoires)
  127. nbrfac = 0
  128. nbrobl = 0
  129. MOFOR = FORMOD(1)
  130. IF (MOFOR .EQ. 'THERMIQUE') THEN
  131. INFOR = 1
  132. IF (NEF.EQ.46 .OR. ICOQ.NE.0 .or. ituy.ne.0) THEN
  133. nbrobl = 3
  134. ELSE
  135. nbrobl = 2
  136. ENDIF
  137. SEGINI,nomid
  138.  
  139. IF(MFR .EQ. 75)THEN
  140. C Cas des JOI1 (MFR=75) ==> Ressorts THERMIQUES
  141. C ====================
  142. lesobl(1) = 'M '
  143. lesobl(2) = 'C '
  144. ELSE
  145. lesobl(1) = 'RHO '
  146. lesobl(2) = 'C '
  147. ENDIF
  148.  
  149. ELSEIF(MOFOR .EQ. 'DIFFUSION') THEN
  150. INFOR = 2
  151. IF (NEF.EQ.46 .OR. ICOQ.NE.0 .or. ituy.ne.0) THEN
  152. nbrobl = 2
  153. ELSE
  154. nbrobl = 1
  155. ENDIF
  156. SEGINI,nomid
  157. lesobl(1) = 'CDIF'
  158. ELSE
  159. CALL ERREUR(21)
  160. RETURN
  161. ENDIF
  162.  
  163. IF (NEF.EQ.46.or.ituy.ne.0) THEN
  164. lesobl(nbrobl) = 'SECT'
  165. ELSE IF (ICOQ.NE.0) THEN
  166. lesobl(nbrobl) = 'EPAI'
  167. ENDIF
  168.  
  169. NMATT = nbrobl + nbrfac
  170. MOMATE = nomid
  171. c
  172. nbtype = 1
  173. SEGINI,notype
  174. type(1) = 'REAL*8'
  175. MOTYPE = notype
  176.  
  177. C- Recuperation de donnees dans le cas d'un CHANGEMENT DE PHASE
  178. C Dans le cas d'un changement de phase, on calcule une capacite
  179. C calorifique equivalente liee a la chaleur latente (MCHAML IPCPHA).
  180. C Le support de ce champ est celui des points de GAUSS (IPINTE).
  181. IF (ITABCP.NE.0) THEN
  182. CALL CAPA7(ITABCP,IPT1,ICOQ,IPINTE, IPCPHA)
  183. IF (IERR.NE.0) GOTO 9990
  184. nbrobl = 1
  185. nbrfac = 0
  186. SEGINI,nomid
  187. lesobl(1) = 'C '
  188. MOCPHA = nomid
  189. NPHAT = nbrobl + nbrfac
  190. ENDIF
  191.  
  192. C- Definition du descripteur IDESCR pour le modele elementaire
  193. IDESCR = 0
  194. NOMPRI = LNOMID(1)
  195. NOMDUA = LNOMID(2)
  196. CALL TCOND2(ICOQ,NBNOE1,IDESCR,NOMPRI,NOMDUA)
  197. DESCR = IDESCR
  198. SEGACT,DESCR
  199. NLIGRD = LISDUA(/2)
  200. NLIGRP = LISINC(/2)
  201. SEGDES,DESCR
  202. LRE = NLIGRD
  203.  
  204. C- Partionnement si necessaire de la matrice de capacite
  205. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  206. LTRK = oooval(1,4)
  207. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  208. * Ajout a la taille en mots de la matrice des infos du segment
  209. LSEG = LRE*LRE*NBELE1 + 16
  210. NBLPRT = (LSEG-1)/LTRK + 1
  211. NBLMAX = (NBELE1-1)/NBLPRT + 1
  212. NBLPRT = (NBELE1-1)/NBLMAX + 1
  213. * write(ioimp,*) ' capa1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  214.  
  215. C Ajout de la matrice de CAPACITE a la matrice globale
  216. C ====================================================
  217. NRIGEL = NRIGE0 + NBLPRT
  218. SEGADJ,MRIGID
  219.  
  220. descr = IDESCR
  221. meleme = IPT1
  222. nbnn = NBNOE1
  223. nbelem = NBELE1
  224. nbsous = 0
  225. nbref = 0
  226.  
  227. C Boucle sur les PARTITIONS elementaires de la matrice
  228. C ====================================================
  229. DO irige = 1, NBLPRT
  230.  
  231. IVAMAT = 0
  232. IVAPHA = 0
  233.  
  234. IF (NBLPRT.GT.1) THEN
  235. C- Partitionnement du maillage support de la matrice elementaire
  236. SEGACT,IPT1
  237. ielem = (irige-1)*NBLMAX
  238. nbelem = MIN(NBLMAX,NBELE1-ielem)
  239. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  240. SEGINI,meleme
  241. itypel = IPT1.itypel
  242. DO ielt = 1, nbelem
  243. jelt = ielt + ielem
  244. DO inoe = 1, nbnn
  245. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  246. ENDDO
  247. icolor(ielt) = IPT1.ICOLOR(jelt)
  248. ENDDO
  249. C- Recopie du descripteur
  250. des1 = IDESCR
  251. SEGINI,descr=des1
  252. SEGDES,descr
  253. ENDIF
  254. ipmail = meleme
  255. ipdesc = descr
  256.  
  257. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  258. NELRIG = nbelem
  259. SEGINI,xmatri
  260. ipmatr = xmatri
  261.  
  262. C- Recuperation des valeurs de caracteristiques sur la partition
  263. CALL KOMCHA(IPCHEL,ipmail,CONM,MOMATE,MOTYPE,1,INFOS,3,IVAMAT)
  264. IF (IERR.NE.0) GOTO 9991
  265. IF (ISUPC.EQ.1 .AND. NEF.NE.265) THEN
  266. C On ne change pas le support pour JOI1
  267. CALL VALCHE(IVAMAT,NMATT,IPINTE,0,MOMATE,NEF)
  268. IF (IERR.NE.0) THEN
  269. ISUPC = 0
  270. GOTO 9991
  271. ENDIF
  272. ENDIF
  273.  
  274. C- Idem pour capacite equivalente en cas de changement de phase
  275. IF (ITABCP.NE.0) THEN
  276. CALL KOMCHA(IPCPHA,ipmail,CONM,MOCPHA,MOTYPE,1,INFOS,3,IVAPHA)
  277. IF (IERR.NE.0) GOTO 9991
  278. ENDIF
  279.  
  280. C- Calcul de la matrice elementaire pour la paritition elementaire et
  281. C Remplissage de la matrice globale (IPRIGI)
  282. C---> Elements MASSIFs a integration NUMERIQUE
  283. IF (IMAS.NE.0) THEN
  284. CALL CAPANU(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  285. & ipmatr,LRE,INFOR)
  286. C---> Elements de COQUEs
  287. ELSE IF (ICOQ.NE.0) THEN
  288. C-----> Element COQ2 (axisymetrique)
  289. IF (NEF.EQ.44) THEN
  290. CALL CAPAC1(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  291. & ipmatr,LRE,INFOR)
  292. C-----> Element COQ3
  293. ELSE IF (NEF.EQ.27) THEN
  294. CALL CAPAC3(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  295. & ipmatr,LRE,INFOR)
  296. C-----> Elements COQ4, COQ6 et COQ8
  297. C* ELSE IF (NEF.EQ.56 .OR. NEF.EQ.41 .OR. NEF.EQ.49) THEN
  298. ELSE
  299. CALL CAPAC2(NEF,ipmail,IPINTE,IPINT2,IVAMAT,NMATT,
  300. & IVAPHA,NPHAT, ipmatr,LRE,INFOR)
  301. ENDIF
  302. C---> Element BARRE (integration NUMERIQUE)
  303. ELSE IF (NEF.EQ.46.or.nef.eq.269.or.nef.eq.270) THEN
  304. CALL CAPABA(NEF,ipmail,IPINTE,IVAMAT,NMATT,IVAPHA,NPHAT,
  305. & ipmatr,LRE,INFOR)
  306. C---> Elements seg3, RAC2 et RAC3 : non implementes
  307. ELSE IF (NEF.EQ.3 .OR. NEF.EQ.12 .OR. NEF.EQ.13) THEN
  308. CALL ERREUR(251)
  309. RETURN
  310. C---> Elements JOI1 : pas d'integration
  311. ELSE IF (NEF.EQ.265) THEN
  312. CALL CAPAJ1(IPMAIL,IVAMAT,NMATT,IPMATR,INFOR)
  313. C---> Elements POI1 : pas d'integration
  314. ELSE IF (NEF.EQ.45) THEN
  315. CALL CAPAP1(IPMAIL,IVAMAT,IPMATR,INFOR)
  316. C---> Option indisponible : ERREUR
  317. ELSE
  318. CALL ERREUR(19)
  319. RETURN
  320. ENDIF
  321.  
  322. C- Un peu de menage dans les segments
  323. 9991 CONTINUE
  324. IF (ISUPC.EQ.1 .AND. NEF.NE.265 .OR. NBLPRT.NE.1) THEN
  325. CALL DTMVAL(IVAMAT,3)
  326. ELSE
  327. CALL DTMVAL(IVAMAT,1)
  328. ENDIF
  329. IF (ITABCP.NE.0) THEN
  330. IF (NBLPRT.NE.1) THEN
  331. CALL DTMVAL(IVAPHA,3)
  332. ELSE
  333. CALL DTMVAL(IVAPHA,1)
  334. ENDIF
  335. ENDIF
  336. C- Sortie prematuree en cas d'erreur
  337. IF (IERR.NE.0) GOTO 9990
  338.  
  339. xmatri = ipmatr
  340. SEGDES,xmatri
  341. IF (NBLPRT.NE.1) THEN
  342. meleme = ipmail
  343. ENDIF
  344.  
  345. C- Stockage de la matrice de CAPACITE du modele
  346. jrige = NRIGE0 + irige
  347. COERIG(jrige) = 1.
  348. IRIGEL(1,jrige) = ipmail
  349. IRIGEL(2,jrige) = 0
  350. IRIGEL(3,jrige) = ipdesc
  351. IRIGEL(4,jrige) = ipmatr
  352. IRIGEL(5,jrige) = NIFOUR
  353. IRIGEL(6,jrige) = 0
  354. IRIGEL(7,jrige) = 0
  355. IRIGEL(8,jrige) = 0
  356.  
  357. ENDDO
  358.  
  359. IPRIGI = MRIGID
  360.  
  361. C MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  362. C ==============================================
  363. 9990 CONTINUE
  364. IF (MOMATE.NE.0) THEN
  365. nomid = MOMATE
  366. SEGSUP,nomid
  367. ENDIF
  368. IF (MOTYPE.NE.0) THEN
  369. notype = MOTYPE
  370. SEGSUP,notype
  371. ENDIF
  372. IF (MOCPHA.NE.0) THEN
  373. nomid = MOCPHA
  374. SEGSUP,nomid
  375. ENDIF
  376. IF (IPCPHA.NE.0) THEN
  377. CALL DTCHAM(IPCPHA)
  378. ENDIF
  379.  
  380. RETURN
  381. END
  382.  
  383.  
  384.  

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