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

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