Télécharger chapo.eso

Retour à la liste

Numérotation des lignes :

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

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