Télécharger chapo.eso

Retour à la liste

Numérotation des lignes :

  1. C CHAPO SOURCE BP208322 18/04/12 21:15:04 9801
  2. C
  3. SUBROUTINE CHAPO(IPMODL,IPCHAM,IPCARA,IPCHPO,IRET)
  4. C=======================================================================
  5. C
  6. C TRANSFORME LE MCHAML IPCHAM EN CHPOINT IPCHPO
  7. C il y a deja eu un reduaf sur IPMODL du mchaml -> IPCHAM
  8. C
  9. C=======================================================================
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8(A-H,O-Z)
  12. -INC SMMODEL
  13. -INC SMCHAML
  14. c -INC SMCHPOI
  15. -INC SMELEME
  16. -INC SMCOORD
  17. -INC CCOPTIO
  18. -INC SMINTE
  19. -INC TMTRAV
  20. *
  21. SEGMENT NOTYPE
  22. CHARACTER*16 TYPE(NBTYPE)
  23. ENDSEGMENT
  24. SEGMENT MPTVAL
  25. INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  26. CHARACTER*16 TYVAL(NCOSOU)
  27. ENDSEGMENT
  28. SEGMENT INFO
  29. INTEGER INFELL(JG)
  30. ENDSEGMENT
  31. c tableau inverse pour retrouver la position d'inconnue
  32. SEGMENT KINCO(NINCO)
  33. SEGMENT MWRK1
  34. REAL*8 XEL(3,NBN1)
  35. ENDSEGMENT
  36. SEGMENT MWRK2
  37. REAL*8 TXR(3,3,NBN1),TH(NBN1)
  38. ENDSEGMENT
  39. PARAMETER (LTIT=72)
  40. CHARACTER*(LTIT) TITCH1
  41. DIMENSION XIGAU(3)
  42. DIMENSION INFOS(3)
  43. * CHARACTER*(LCONMO) CONM
  44. CHARACTER*(NCONCH) CONM
  45.  
  46.  
  47. ************************************************************************
  48. * PRELIMINAIRES
  49. ************************************************************************
  50. SEGACT MCOORD*MOD
  51. *
  52. * ACTIVATION DU MMODEL et MCHAML
  53. *
  54. IRET=1
  55. MMODEL=IPMODL
  56. MCHELM=IPCHAM
  57. SEGACT,MMODEL,MCHELM
  58. NSOUS=KMODEL(/1)
  59. IF(IPCARA.GT.0) THEN
  60. MCHEL1=IPCARA
  61. SEGACT,MCHEL1
  62. ENDIF
  63. *
  64. * Verification du support : noeuds ou points d'integration (Gauss) ?
  65. *
  66. ISUP = INFCHE(1,6)
  67. NSC = INFCHE(/1)
  68. DO 50 ISC=2,NSC
  69. ISUP1 = INFCHE(ISC,6)
  70. IF (ISUP1.NE.ISUP) ISUP = 0
  71. 50 CONTINUE
  72. * si ISUP = 1 : MCHAML aux noeuds
  73. * si ISUP = 2 : MCHAML au centre de gravite
  74. * si ISUP = 3 : MCHAML aux point d integration (rigidite)
  75. * si ISUP = 4 : MCHAML aux point d integration (masse)
  76. * si ISUP = 5 : MCHAML aux point d integration (stresses)
  77. * si ISUP = 6 : MCHAML aux point d integration de T
  78. cbp IF (ISUP.LT.1.OR.ISUP.GT.6) THEN
  79. IF (ISUP.LE.1.OR.ISUP.GT.6) THEN
  80. write(IOIMP,*) 'Supports incoherents',(INFCHE(iou,6),iou=1,NSC)
  81. call erreur(609)
  82. SEGDES MMODEL,MCHELM
  83. RETURN
  84. ENDIF
  85.  
  86. c on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI
  87. LTIT1 = min(LTIT,TITCHE(/1))
  88. TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  89. TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  90.  
  91. c * liste des composantes
  92. c * ...
  93. c
  94. c * Creation du MCHPOI puis du MSOUPO et du MPOVAL
  95. c *
  96. c NAT = 2
  97. c NSOUPO = 1
  98. c SEGINI MCHPOI
  99. c IPCHPO = MCHPOI
  100. c MTYPOI = 'CHAN CHPO'
  101. c MOCHDE(1:LTIT1) = TITCH1(1:LTIT1)
  102. c IFOPOI = IFOUR
  103. c JATTRI(1) = 2
  104. c JATTRI(2) = 0
  105.  
  106. c Segment MTRAV et ses dimensions
  107. NNIN=0
  108. NNNOE=0
  109. MTRAV=0
  110.  
  111. ************************************************************************
  112. * Boucle sur les zones du MCHAML
  113. ************************************************************************
  114. isous = 0
  115. DO 100 ISOU = 1,NSOUS
  116.  
  117. cbp IVACOM = 0
  118. IVAEP = 0
  119.  
  120. * ACTIVATION DU SOUS MODELE
  121.  
  122. c IMODEL = KMODEL(ISOU)
  123. IIIMOD = KMODEL(ISOU)
  124. IMODEL = IIIMOD
  125. SEGACT IMODEL
  126. IPMAIL = IMAMOD
  127. CONM = CONMOD
  128. MELE = NEFMOD
  129. MELEME = IMAMOD
  130. SEGACT,MELEME
  131. NFOR = FORMOD(/2)
  132. NMAT = MATMOD(/2)
  133. c write(6,*) '==== zone',ISOU,'/',NSOUS,' itypel =',itypel
  134. IF (itypel.eq.48) goto 100
  135. isous = isous+1
  136. c write(6,*) ' => zone ok : ISOUS=', ISOUS
  137. *
  138. cbp CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  139. *
  140. * RECUP DU SEGMENT D'INTEGRATION MINTE
  141. if(infmod(/1).lt.7) then
  142. ISUP5 = MIN(ISUP,5)
  143. CALL ELQUOI(MELE,0,ISUP5,IPINF,IMODEL)
  144. IF (IERR.NE.0) THEN
  145. write(*,*) 'erreur apres elquoi'
  146. SEGDES IMODEL,MMODEL
  147. RETURN
  148. ENDIF
  149. INFO = IPINF
  150. NBGS = INFELL(4)
  151. MFR = INFELL(13)
  152. MINTE = INFELL(11)
  153. MINTE1 = INFELL(12)
  154. segsup info
  155. else
  156. NBGS = INFELE(4)
  157. MFR = INFELE(13)
  158. MINTE = INFMOD(ISUP+2)
  159. MINTE1 = INFMOD(8)
  160. endif
  161. *
  162. IPMINT = MINTE
  163. IF (MFR.EQ.5.AND.IPCARA.EQ.0) THEN
  164. MOTERR(1:16) = 'CARACTERISTIQUES'
  165. CALL ERREUR(565)
  166. write(*,*) 'erreur manque IPCARA'
  167. SEGDES IMODEL,MMODEL
  168. RETURN
  169. ENDIF
  170. IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT MINTE1
  171. *
  172. CALL IDENT(IPMAIL,CONM,IPCHAM,0,INFOS,IRET)
  173. c IF (IRET.EQ.0) call erreur(5)
  174. *
  175. SEGACT MINTE
  176. NBPGAU = POIGAU(/1)
  177. c SEGACT MELEME
  178. NBN1 = NUM(/1)
  179. NBELE1 = NUM(/2)
  180. IF (ISUP.EQ.1) THEN
  181. NIPO = NBN1
  182. ELSE
  183. NIPO = NBPGAU
  184. ENDIF
  185.  
  186. * creation des segments de travail
  187. SEGINI MWRK1
  188. NPPO = NIPO * NBELE1
  189. c write(6,*) 'nb pts support', NIPO, '* nb elem',NBELE1,'=',NPPO
  190. IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  191.  
  192. * ACTIVATION DU SOUS-MCHELM MCHAML
  193. MCHAML = ICHAML(ISOUS)
  194. SEGACT,MCHAML
  195. NC=IELVAL(/1)
  196. *
  197. * CREATION/AJUSTEMENT DU MTRAV
  198. * + REMPLISSAGE DE INCO et de KINCO
  199. NINCO=NC
  200. SEGINI,KINCO
  201. c -1er passage :
  202. IF(ISOUS.EQ.1) THEN
  203. NNIN =NC
  204. NNNOE1=0
  205. NNNOE=NPPO
  206. SEGINI,MTRAV
  207. c toutes les composantes sont nouvelles
  208. DO IC=1,NC
  209. INCO(IC)=NOMCHE(IC)
  210. NHAR(IC)=INFCHE(ISOU,3)
  211. KINCO(IC)=IC
  212. ENDDO
  213. c -passages suivants :
  214. ELSE
  215. c on dimensionne au plus large
  216. NNIN1=NNIN
  217. NNIN =NNIN+NC
  218. NNNOE1=NNNOE
  219. NNNOE=NNNOE+NPPO
  220. SEGADJ,MTRAV
  221. c recherche des composantes nouvelles
  222. C pour MCHAML
  223. NCNEW=0
  224. DO 101 IC=1,NC
  225. DO 102 IIN=1,NNIN1
  226. IF(INCO(IIN).NE.NOMCHE(IC)) GOTO 102
  227. IF(NHAR(IIN).EQ.INFCHE(ISOU,3)) THEN
  228. KINCO(IC)=IIN
  229. GOTO 101
  230. ENDIF
  231. 102 CONTINUE
  232. c nouvelle composante !
  233. NCNEW=NCNEW+1
  234. INCO(NCNEW)=NOMCHE(IC)
  235. NHAR(NCNEW)=INFCHE(ISOU,3)
  236. KINCO(IC)=NCNEW
  237. 101 CONTINUE
  238. c on remet a la bonne taille
  239. NNIN=NNIN1+NCNEW
  240. SEGADJ,MTRAV
  241. ENDIF
  242. * + REMPLISSAGE DE IGEO et de IBIN
  243. c sympa: a priori, tous les noeuds sont nouveaux !
  244. NBPTS = XCOOR(/1)/(IDIM+1)
  245. NBPTS1 = NBPTS
  246. DO INOE=NNNOE1+1,NNNOE
  247. NBPTS=NBPTS+1
  248. IGEO(INOE)=NBPTS
  249. do IC=1,NC
  250. IIN=KINCO(IC)
  251. IBIN(IIN,INOE)=1
  252. enddo
  253. ENDDO
  254. SEGADJ,MCOORD
  255. c WRITE(*,*) 'INCO=',(INCO(iou),iou=1,NNIN)
  256. c IN NE RESTE QU'A REMPLIR BB...
  257.  
  258. *
  259. *=======================================================================
  260. * Boucle sur les composantes
  261. *
  262. DO 150 IC = 1,NC
  263.  
  264. c write(6,*) '============ ISOU,IC=',ISOU,IC,'IMODEL=',IMODEL
  265. * Recup du melval
  266. MELVAL=IELVAL(IC)
  267. SEGACT,MELVAL
  268. **
  269. * Cas des coques epaisses : recup de l'epaisseur
  270. * on neglige l'excentrement
  271. IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  272. NBROBL = 1
  273. NBRFAC = 0
  274. SEGINI NOMID
  275. MOEP = NOMID
  276. LESOBL(1) = 'EPAI'
  277. NVEC = NBROBL + NBRFAC
  278. NBTYPE = 1
  279. SEGINI NOTYPE
  280. MOTYPE = NOTYPE
  281. TYPE(1) = 'REAL*8'
  282. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOEP,
  283. & MOTYPE,1,INFOS,3,IVAEP)
  284. SEGSUP NOTYPE
  285. ENDIF
  286. *
  287. * recup de la position IIN dans MTRAV
  288. DO 151 IIN=1,NNIN
  289. IF(INCO(IIN).EQ.NOMCHE(IC)) GOTO 152
  290. 151 CONTINUE
  291. CALL ERREUR(5)
  292. RETURN
  293. 152 CONTINUE
  294. * + debut des nouveaux noeuds
  295. INOE = NNNOE1
  296.  
  297. *
  298. *---------- Boucle sur les elements ------------------------------
  299. *
  300. DO 200 IEL = 1,NBELE1
  301.  
  302. * cas general
  303. CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  304. *
  305. * coques epaisses
  306. IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  307. MPTVAL=IVAEP
  308. MELVA1=IVAL(1)
  309. DO 201 IP = 1,NBN1
  310. IPMN=MIN(IP ,MELVA1.VELCHE(/1))
  311. IEMN=MIN(IEL,MELVA1.VELCHE(/2))
  312. TH(IP)=MELVA1.VELCHE(IPMN,IEMN)
  313. 201 CONTINUE
  314. CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  315. ENDIF
  316. *
  317. *............. Boucle sur les points supports .............
  318. *
  319. DO 300 IPSU = 1,NIPO
  320.  
  321.  
  322. * remplissage des valeurs CHAMELEM -> MTRAV
  323. IPMN = MIN(IPSU,VELCHE(/1))
  324. IEMN = MIN(IEL ,VELCHE(/2))
  325. INOE=INOE+1
  326. BB(IIN,INOE) = VELCHE(IPMN,IEMN)
  327. *
  328. cbp c IF (ISUP.GE.5) THEN
  329. cbp IF (ISUP.GT.1) THEN
  330. * 1er passage : on calcule les coord du pt d integration
  331. IF (IC.EQ.1) THEN
  332. IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  333. Z = DZEGAU(IPSU)
  334. DO 400 I2 = 1,IDIM
  335. XIGAU(I2) = 0.D0
  336. DO 400 IL = 1,NBN1
  337. XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)*
  338. & XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL))
  339. 400 CONTINUE
  340. ELSE
  341. DO 410 I2 = 1,IDIM
  342. XIGAU(I2) = 0.D0
  343. DO 410 IL = 1,NBN1
  344. XIGAU(I2) = XIGAU(I2) +
  345. & (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  346. 410 CONTINUE
  347. ENDIF
  348.  
  349. * Le pdi est cree dans MCOORD
  350. KPTS=IGEO(INOE)
  351. XCOOR((KPTS-1)*(IDIM+1)+1) = XIGAU(1)
  352. XCOOR((KPTS-1)*(IDIM+1)+2) = XIGAU(2)
  353. IF (IDIM.EQ.3) XCOOR((KPTS-1)*(IDIM+1)+3)=XIGAU(3)
  354. XCOOR(KPTS*(IDIM+1)) = 0.D0
  355. ENDIF
  356.  
  357. 300 CONTINUE
  358. *............. fin de Boucle sur les points supports ..........
  359.  
  360. 200 CONTINUE
  361. *---------- Fin de Boucle sur les elements -----------------------
  362. SEGDES,MELVAL
  363.  
  364. 150 CONTINUE
  365.  
  366. * Fin de Boucle sur les composantes
  367. *=======================================================================
  368.  
  369. * Desactivation des segments de la zone ISOU
  370. *
  371. SEGDES IMODEL,MINTE,MELEME,MCHAML
  372. IF (MFR.EQ.5) SEGDES MINTE1
  373. SEGSUP MWRK1
  374. IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  375. SEGSUP,KINCO
  376.  
  377. *
  378. 100 CONTINUE
  379. ************************************************************************
  380. * FIN DE Boucle sur les zones du MCHAML
  381. ************************************************************************
  382. SEGDES MMODEL,MCHELM
  383. IF(IPCARA.GT.0) SEGDES,MCHEL1
  384.  
  385.  
  386. ************************************************************************
  387. * CREATION DU CHPOINT FINAL A PARTIR DU MTRAV
  388. ************************************************************************
  389. CALL CRECHP (MTRAV,IPCHP1)
  390. SEGSUP,MTRAV
  391. IPCHPO=IPCHP1
  392.  
  393. RETURN
  394. END
  395.  
  396.  
  397.  
  398.  

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