Télécharger kpres.eso

Retour à la liste

Numérotation des lignes :

  1. C KPRES SOURCE PV 17/09/29 21:15:18 9578
  2. SUBROUTINE KPRES(IPMODL,IPCHPO,ICHA,ICONV,IFLAM,IASYM,IPRIG,IRET)
  3. C_______________________________________________________________________
  4. C
  5. C
  6. C 99
  7. C Entrees:
  8. C ________
  9. C
  10. C IPMODL Pointeur sur un MMODEL
  11. C IPCHPO Pointeur sur un MCHAML ou CHPOINT de PRESSION
  12. C
  13. C ICHA Flag : =1 IPCHPO est un pointeur sur un MCHAML
  14. C =0 IPCHPO est un pointeur sur un CHPOINT
  15. C
  16. C ICONV Flag de conversion
  17. C IFLAM Flag de flambage
  18. C
  19. C Sorties:
  20. C ________
  21. C
  22. C IPRIG Pointeur sur un objet RIGIDITE
  23. C IRET Flag de retour
  24. C
  25. C CODE COMBESCURE JANV 87
  26. C
  27. C Passage aux nouveaux CHAMELEMs par P.DOWLATYARI le 5/04/91
  28. C
  29. C
  30. C_______________________________________________________________________
  31. C
  32. IMPLICIT INTEGER(I-N)
  33. IMPLICIT REAL*8(A-H,O-Z)
  34. *
  35. -INC CCHAMP
  36. -INC CCOPTIO
  37. -INC SMRIGID
  38. -INC SMCHAML
  39. -INC SMELEME
  40. -INC SMCOORD
  41. -INC SMINTE
  42. -INC SMMODEL
  43. -INC SMCHPOI
  44. C
  45. SEGMENT WRK1
  46. REAL*8 REL(LRE,LRE) ,XE(3,NBBB)
  47. ENDSEGMENT
  48. *
  49. SEGMENT WRK2
  50. REAL*8 SHPWRK(6,NBNO)
  51. ENDSEGMENT
  52. *
  53. SEGMENT WRK3
  54. REAL*8 WORK(LW)
  55. ENDSEGMENT
  56. *
  57. SEGMENT WRK4
  58. REAL*8 BPSS(3,3) ,XEL(3,NBBB)
  59. ENDSEGMENT
  60. segment wrk7
  61. real*8 propel(2),d(1),work1(1),out(1)
  62. endsegment
  63. segment icpr (xcoor(/1)/(idim+1))
  64. *
  65. SEGMENT MPTVAL
  66. INTEGER IPOS(NS) ,NSOF(NS)
  67. INTEGER IVAL(NCOSOU)
  68. CHARACTER*16 TYVAL(NCOSOU)
  69. ENDSEGMENT
  70. *
  71. PARAMETER ( NINF=3 )
  72. INTEGER INFOS(NINF)
  73. LOGICAL lsupfo,lsupdp
  74. *
  75. SEGMENT LIMODL(0)
  76. *
  77. IRET=1
  78. IVAPR=0
  79. *
  80. * CHPOINT DE PRESSION ---> CHAMELEM AUX NOEUDS
  81. *
  82. IF(ICHA.EQ.0)THEN
  83. CALL CHAME1(0,IPMODL,IPCHPO,' ',IPCHE0,1)
  84. IF (IERR.NE.0) RETURN
  85. CALL REDUAF(IPCHE0,IPMODL,IPCHE1,0,IR,KER)
  86. IF(IR .NE. 1) CALL ERREUR(KER)
  87. IF(IERR .NE. 0) RETURN
  88. ELSE
  89. IPCHE1=IPCHPO
  90. ENDIF
  91. MCHEL1=IPCHE1
  92. SEGACT,MCHEL1
  93. NBMAIC=MCHEL1.IMACHE(/1)
  94. IF (NBMAIC.EQ.0) THEN
  95. SEGDES,MCHEL1
  96. IRET=0
  97. CALL ERREUR(472)
  98. RETURN
  99. ENDIF
  100. C_______________________________________________________________________
  101. C
  102. C ACTIVATION DU MODELE
  103. C_______________________________________________________________________
  104. C
  105. MMODEL=IPMODL
  106. SEGACT MMODEL
  107. NSOUS=KMODEL(/1)
  108. C
  109. C RECUPERATION DES MODELES
  110. C
  111. SEGINI,LIMODL
  112. DO 100 ISOUS=1,NSOUS
  113. IMODEL=KMODEL(ISOUS)
  114. SEGACT, IMODEL
  115. IF(FORMOD(1).EQ.'MECANIQUE'.OR.(FORMOD(1).EQ.'CHARGEMENT'.AND.
  116. & MATMOD(1).EQ.'PRESSION')) THEN
  117. LIMODL(**)=IMODEL
  118. ELSE
  119. SEGDES,IMODEL
  120. ENDIF
  121. 100 CONTINUE
  122. C
  123. NSOUS = LIMODL(/1)
  124. IF (NSOUS.LE.0) THEN
  125. SEGDES, MMODEL
  126. SEGSUP, LIMODL
  127. IF (ICHA.EQ.0) THEN
  128. CALL DTCHAM(MCHEL1)
  129. ELSE
  130. SEGDES,MCHEL1
  131. ENDIF
  132. CALL ERREUR(610)
  133. RETURN
  134. ENDIF
  135. *
  136. * verif si element shb8 d'avoir recu un chpoint de pression
  137. *
  138. if(icha.eq.1) then
  139. nsous=kmodel(/1)
  140. do io=1,nsous
  141. imodel=kmodel(io)
  142. segact imodel
  143. if(nefmod.eq.260) then
  144. call erreur(1007)
  145. return
  146. endif
  147. enddo
  148. endif
  149. C
  150. C
  151. C INITIALISATION DU CHAPEAU DE L OBJET RIGIDITE
  152. C
  153. NRIGE=7
  154. NRIGEL=NSOUS
  155. SEGINI MRIGID
  156. IPRIG=MRIGID
  157. ICHOLE=0
  158. IMGEO1=0
  159. IMGEO2=0
  160. IFORIG=IFOMOD
  161. IF (IFLAM.NE.0) THEN
  162. MTYMAT='MASSE'
  163. ELSE
  164. MTYMAT='RIGIDITE'
  165. ENDIF
  166. C
  167. DO 140 ISOUS=1,NSOUS
  168. IRIGEL(4,ISOUS)=0
  169. COERIG(ISOUS)=1.D0
  170. 140 CONTINUE
  171. C_______________________________________________________________________
  172. C
  173. C BOUCLE SUR LES SOUS ZONES DU MAILLAGE
  174. C_______________________________________________________________________
  175. C
  176. DO 500 ISOUS=1,NSOUS
  177. C
  178. C TRAITEMENT DU MODELE
  179. C
  180. IMODEL=LIMODL(ISOUS)
  181. MELE=NEFMOD
  182. IPMAIL=IMAMOD
  183. C_______________________________________________________________________
  184. C
  185. C INFOS. ELEMENT FINI
  186. C_______________________________________________________________________
  187. C
  188. * CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  189. IF ( IERR.NE.0 ) THEN
  190. SEGDES IMODEL,MMODEL
  191. SEGDES MCHEL1
  192. IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
  193. SEGSUP MRIGID
  194. IRET=0
  195. RETURN
  196. ENDIF
  197. * INFO=IPINF
  198. LHOOK = INFELE(10)
  199. LHOO2 = LHOOK*LHOOK
  200. NSTRS = INFELE(16)
  201. MFR = INFELE(13)
  202. LW = INFELE(7)
  203. IF(MELE.EQ.28)LW=600
  204. NDDL = INFELE(15)
  205. LRE = INFELE(9)
  206. IPORE = INFELE(8)
  207. LVAL = (LRE*(LRE+1))/2
  208. NHRM = NIFOUR
  209. C
  210. C CREATION DU TABLEAU INFOS
  211. C
  212. INFOS(1)=0
  213. INFOS(2)=0
  214. INFOS(3)=NIFOUR
  215. C_______________________________________________________________________
  216. C
  217. C INFOS. MAILLAGE
  218. C_______________________________________________________________________
  219. C
  220. MELEME=IPMAIL
  221. SEGACT MELEME
  222. NBNN=NUM(/1)
  223. NBELEM=NUM(/2)
  224. C_______________________________________________________________________
  225. C
  226. C SEGMENTS D'INTEGRATION
  227. C_______________________________________________________________________
  228. C
  229. * Minte : 1er segment d'integration, il existe pour tous les e.f.
  230. * Minte1: 2eme segment d'integration, uniquement pour certains e.f.
  231. * en particulier pour Coq6 et Coq8
  232. * nbpg:nb de points de gauss = nbpgau du segment minte
  233. * iele:no d'element geometrique associe a l'e.f. mele
  234. * nbff:nb de fonctions de forme = nbno du segment minte
  235. *
  236. NBPGAU= INFELE( 6)
  237. IELE = INFELE( 14)
  238. ICARA = INFELE( 5)
  239. * MINTE = INFELE(11)
  240. MINTE=INFMOD(5)
  241. MINTE1= INFMOD(8)
  242. if(mele.ne.260)SEGACT MINTE
  243. C_______________________________________________________________________
  244. C
  245. C INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES
  246. C DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE
  247. C_______________________________________________________________________
  248. C
  249. NLIGRP = INFELE(9)
  250. NLIGRD = INFELE(9)
  251. SEGINI DESCR
  252. IPDESC=DESCR
  253. if(lnomid(1).ne.0) then
  254. nomid=lnomid(1)
  255. segact nomid
  256. modepl=nomid
  257. ndepl=lesobl(/2)
  258. ndum=lesfac(/2)
  259. lsupdp=.false.
  260. else
  261. lsupdp=.true.
  262. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  263. endif
  264. if(lnomid(2).ne.0) then
  265. nomid=lnomid(2)
  266. segact nomid
  267. moforc=nomid
  268. nforc=lesobl(/2)
  269. lsupfo=.false.
  270. else
  271. lsupfo=.true.
  272. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  273. endif
  274. *
  275. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  276. CALL ERREUR(5)
  277. SEGSUP DESCR,MRIGID
  278. SEGDES MCHEL1
  279. IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
  280. SEGDES MMODEL,MELEME,MINTE
  281. SEGDES IMODEL
  282. IRET=0
  283. RETURN
  284. ENDIF
  285. *
  286. * REMPLISSAGE DU SEGMENT DESCRIPTEUR
  287. *
  288. IDDL=1
  289. NCOMP=NDEPL
  290. NBNNS=NBNN
  291. NOMID=MODEPL
  292. SEGACT NOMID
  293. NOMID=MOFORC
  294. SEGACT NOMID
  295. IF (MFR.EQ.33) NCOMP=NDEPL-1
  296. IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
  297. DO 1004 INOEUD=1,NBNNS
  298. DO 1005 ICOMP=1,NCOMP
  299. NOMID=MODEPL
  300. LISINC(IDDL)=LESOBL(ICOMP)
  301. NOMID=MOFORC
  302. LISDUA(IDDL)=LESOBL(ICOMP)
  303. NOELEP(IDDL)=INOEUD
  304. NOELED(IDDL)=INOEUD
  305. IDDL=IDDL+1
  306. 1005 CONTINUE
  307. 1004 CONTINUE
  308. NOMID=MODEPL
  309. if(lsupdp)SEGSUP NOMID
  310. NOMID=MOFORC
  311. if(lsupfo)SEGSUP NOMID
  312. *
  313. * CAS DES MILIEUX POREUX
  314. *
  315. * IF (MFR.EQ.33) THEN
  316. * DO 1104 INOEUD=1,NBSOM(IELE)
  317. * NOMID=MODEPL
  318. * LISINC(IDDL)=LESOBL(NDEPL)
  319. * NOMID=MOFORC
  320. * LISDUA(IDDL)=LESOBL(NDEPL)
  321. * NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  322. * NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
  323. * IDDL=IDDL+1
  324. *1104 CONTINUE
  325. * ENDIF
  326. *
  327. * CAS DES ELEMENT RACCORD
  328. *
  329. IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  330. CALL IDPRIM(IMODEL,MFR+1000,MODEPL,NDEPL,NDUM)
  331. CALL IDDUAL(IMODEL,MFR+1000,MOFORC,NFORC,NDUM)
  332. DO 1106 INOEUD=NBNNS+1,NBNN
  333. DO 1107 ICOMP=1,NDEPL
  334. NOMID=MODEPL
  335. LISINC(IDDL)=LESOBL(ICOMP)
  336. NOMID=MOFORC
  337. LISDUA(IDDL)=LESOBL(ICOMP)
  338. NOELEP(IDDL)=INOEUD
  339. NOELED(IDDL)=INOEUD
  340. IDDL=IDDL+1
  341. 1107 CONTINUE
  342. 1106 CONTINUE
  343. NOMID=MODEPL
  344. SEGSUP NOMID
  345. NOMID=MOFORC
  346. SEGSUP NOMID
  347. ENDIF
  348.  
  349. SEGDES DESCR
  350. C_______________________________________________________________________
  351. C
  352. C INITIALISATION DU SEGMENT IMATRI,
  353. C CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES
  354. C_______________________________________________________________________
  355. C
  356. * NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE
  357. NELRIG = NBELEM
  358. SEGINI xMATRI
  359. C_______________________________________________________________________
  360. C
  361. C TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID
  362. C_______________________________________________________________________
  363. C
  364. IRIGEL(1,ISOUS)=IPMAIL
  365. IRIGEL(2,ISOUS)=0
  366. IRIGEL(3,ISOUS)=IPDESC
  367. IRIGEL(4,ISOUS)=xMATRI
  368. IRIGEL(5,ISOUS)=NIFOUR
  369. IF (IASYM .EQ. 0) THEN
  370. IRIGEL(7, ISOUS) = 0
  371. xmatri.symre=0
  372. ELSE
  373. IRIGEL(7, ISOUS) = 2
  374. xmatri.symre=2
  375. ENDIF
  376. C_______________________________________________________________________
  377. C
  378. C VALEURS DE PRESSION
  379. C_______________________________________________________________________
  380. C
  381. CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
  382. MCHAM1=MCHEL1.ICHAML(IM)
  383. SEGACT MCHAM1
  384. IVAPR=MCHAM1.IELVAL(1)
  385. SEGDES MCHAM1
  386. MELVAL=IVAPR
  387. IF(IVAPR.NE.0)SEGACT MELVAL
  388. *
  389. C=======================================================================
  390. C NUMERO DES ETIQUETTES :
  391. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  392. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  393. C 5 CONTINUE
  394. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  395. C 44 CONTINUE
  396. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  397. C=======================================================================
  398.  
  399. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  400. 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  401. 2 41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
  402. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  403. 4 99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
  404. C
  405.  
  406. if(mele.eq.260) go to 1260
  407. GOTO 99
  408. 27 CONTINUE
  409. C_______________________________________________________________________
  410. C
  411. C ELEMENT COQ3
  412. C_______________________________________________________________________
  413. C
  414. NBBB=NBNN
  415. SEGINI WRK1,WRK3,WRK4
  416. DO 3027 IB=1,NBELEM
  417. C
  418. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  419. C
  420. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  421. CALL ZERO(REL,LRE,LRE)
  422. C
  423. C ON CHERCHE LES PRESSIONS
  424. C
  425. PRESS=0.D0
  426. IF(MELVAL.NE.0)THEN
  427. IBMN=MIN(IB ,VELCHE(/2))
  428. DO 4027 IGAU=1,NBNN
  429. IGMN=MIN(IGAU,VELCHE(/1))
  430. PRESS=PRESS+VELCHE(IGMN,IBMN)
  431. 4027 CONTINUE
  432. PRESS=PRESS/NBNN
  433. ENDIF
  434. C
  435. C ON CALCULE K(P)
  436. C
  437. * SEGINI XMATRI
  438. CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  439. * SEGINI XMATRI
  440. * IMATTT(IB)=XMATRI
  441. C
  442. C REMPLISSAGE DE XMATRI
  443. C
  444. * CALL REMPMC(REL,LRE,RE(1,1,ib))
  445. * SEGDES XMATRI
  446. 3027 CONTINUE
  447. SEGDES xMATRI
  448. SEGSUP WRK1,WRK3,WRK4
  449. GOTO 510
  450. C_______________________________________________________________________
  451. C
  452. C ELEMENT DKT POUR L INSTANT = COQ3
  453. C_______________________________________________________________________
  454. C
  455. 28 CONTINUE
  456. NBBB=NBNN
  457. SEGINI WRK1,WRK3,WRK4
  458. DO 3028 IB=1,NBELEM
  459. C
  460. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  461. C
  462. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  463. C
  464. CALL ZERO(REL,LRE,LRE)
  465. C
  466. C ON CHERCHE LES PRESSIONS
  467. C
  468. PRESS=0.D0
  469. IF(MELVAL.NE.0)THEN
  470. IBMN=MIN(IB ,VELCHE(/2))
  471. DO 4028 IGAU=1,NBNN
  472. IGMN=MIN(IGAU,VELCHE(/1))
  473. PRESS=PRESS+VELCHE(IGMN,IBMN)
  474. 4028 CONTINUE
  475. PRESS=PRESS/NBNN
  476. ENDIF
  477. C
  478. C ON CALCULE K(P)
  479. C
  480. * SEGINI XMATRI
  481. CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  482. * SEGINI XMATRI
  483. * IMATTT(IB)=XMATRI
  484. C
  485. C REMPLISSAGE DE XMATRI
  486. C
  487. * CALL REMPMC(REL,LRE,RE)
  488. * SEGDES XMATRI
  489. 3028 CONTINUE
  490. SEGDES xMATRI
  491. SEGSUP WRK1,WRK3,WRK4
  492. GOTO 510
  493. C_______________________________________________________________________
  494. C
  495. C ELEMENT COQ8 NON ENCORE BRANCHE
  496. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  497. C_______________________________________________________________________
  498. C
  499. 41 CONTINUE
  500. NBBB=NBNN
  501. SEGINI WRK1,WRK3
  502. DO 3041 IB=1,NBELEM
  503. C
  504. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  505. C
  506. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  507. C
  508. CALL ZERO(REL,LRE,LRE)
  509. C
  510. C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
  511. C
  512. PRESS=0.D0
  513. IF(MELVAL.NE.0)THEN
  514. IBMN=MIN(IB ,VELCHE(/2))
  515. DO 4041 IGAU=1,NBNN
  516. IGMN=MIN(IGAU,VELCHE(/1))
  517. PRESS=PRESS+VELCHE(IGMN,IBMN)
  518. 4041 CONTINUE
  519. PRESS=PRESS/NBNN
  520. ENDIF
  521. * IE=0
  522. * DO 7041 IGAU=1,NBNN
  523. * IE=IE+1
  524. * IF (MELVAL.NE.0) THEN
  525. * IGMN=MIN(IGAU,VELCHE(/1))
  526. * IBMN=MIN(IB ,VELCHE(/2))
  527. * WORK(IE)=VELCHE(IGMN,IBMN)
  528. * ELSE
  529. * WORK(IE)=0.D0
  530. * ENDIF
  531. * 7041 CONTINUE
  532. C
  533. C ON CALCULE LA RIGIDITE GEOMETRIQUE
  534. C
  535. * SEGINI XMATRI
  536. CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
  537. C
  538. C REMPLISSAGE DE XMATRI
  539. C
  540. * SEGINI XMATRI
  541. * IMATTT(IB)=XMATRI
  542. * CALL REMPMC(REL,LRE,RE)
  543. * SEGDES XMATRI
  544. 3041 CONTINUE
  545. SEGDES xMATRI
  546. SEGSUP WRK1,WRK3
  547. GO TO 510
  548. C_______________________________________________________________________
  549. C
  550. C ELEMENT COQ2
  551. C_______________________________________________________________________
  552. C
  553. 44 CONTINUE
  554. *
  555. * AM 01/09/94 PETIT TEST SUR IFOUR CAR NE FONCTIONNE
  556. * QU'EN SERIE DE FOURIER
  557. *
  558. IF(IFOUR.NE.1) GO TO 99
  559.  
  560. * BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
  561. IF(IASYM.NE.0) THEN
  562. write(ioimp,*) 'L option de calcul ASYMetrique ',
  563. & 'n est pas disponible avec les coq2 !'
  564. call ERREUR(19)
  565. goto 9990
  566. ENDIF
  567.  
  568. NBBB=NBNN
  569. SEGINI WRK1,WRK3,WRK4
  570. DO 3044 IB=1,NBELEM
  571. C
  572. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  573. C
  574. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  575. CALL ZERO(REL,LRE,LRE)
  576. C
  577. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  578. C
  579. WORK(1)=0.D0
  580.  
  581. IF(MELVAL.NE.0)THEN
  582. IBMN=MIN(IB ,VELCHE(/2))
  583. DO 1344 IGAU=1,NBNN
  584. IGMN=MIN(IGAU,VELCHE(/1))
  585. WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
  586. 1344 CONTINUE
  587. WORK(1)=WORK(1)/NBNN
  588. ENDIF
  589. C
  590. C APPEL A COQUE2 KP
  591. C
  592. AN=NHRM
  593. CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
  594. 1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
  595. 2 WORK(157),WORK(221),WORK(285))
  596. C
  597. C REMPLISSAGE DE XMATRI
  598. C
  599. * SEGINI XMATRI
  600. * IMATTT(IB)=XMATRI
  601. CALL REMPMT(REL,LRE,RE(1,1,ib))
  602. * SEGDES XMATRI
  603. 3044 CONTINUE
  604. SEGDES xMATRI
  605. SEGSUP WRK1,WRK3,WRK4
  606. GOTO 510
  607. C_______________________________________________________________________
  608. C
  609. C ELEMENT COQ4 NON ENCORE BRANCHE
  610. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  611. C_______________________________________________________________________
  612. C
  613. 49 CONTINUE
  614. NBBB=NBNN
  615. SEGINI WRK1,WRK3,WRK4
  616. DO 3049 IB=1,NBELEM
  617. C
  618. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  619. C
  620. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  621. C
  622. CALL ZERO(REL,LRE,LRE)
  623. C
  624. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  625. C
  626. PRESS=0.D0
  627. IF(MELVAL.NE.0)THEN
  628. IBMN=MIN(IB ,VELCHE(/2))
  629. DO 4049 IGAU=1,NBNN
  630. IGMN=MIN(IGAU,VELCHE(/1))
  631. PRESS=PRESS+VELCHE(IGMN,IBMN)
  632. 4049 CONTINUE
  633. PRESS=PRESS/NBNN
  634. ENDIF
  635. * IE=0
  636. * DO 5049 IGAU=1,NBNN
  637. * IE=IE+1
  638. * IF (MELVAL.NE.0) THEN
  639. * IGMN=MIN(IGAU,VELCHE(/1))
  640. * IBMN=MIN(IB ,VELCHE(/2))
  641. * WORK(IE)=VELCHE(IGMN,IBMN)
  642. * ELSE
  643. * WORK(IE)=0.D0
  644. * ENDIF
  645. * 5049 CONTINUE
  646. C
  647. C APPEL A COQUE4 KSIGMA...
  648. C
  649. AN=NHRM
  650. * SEGINI XMATRI
  651. * CALL KPCOQ4(XE,PRESS,REL,IASYM)
  652. CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
  653. C
  654. C REMPLISSAGE DE XMATRI
  655. C
  656. * SEGINI XMATRI
  657. * IMATTT(IB)=XMATRI
  658. * CALL REMPMC(REL,LRE,RE)
  659. * SEGDES XMATRI
  660. 3049 CONTINUE
  661. SEGDES xMATRI
  662. SEGSUP WRK1,WRK3,WRK4
  663. GOTO 510
  664. C_______________________________________________________________________
  665. C
  666. C element SHB8
  667. C_______________________________________________________________________
  668. C
  669. 1260 continue
  670. *
  671. NBBB=NBNN
  672. SEGINI WRK1,wrk7
  673. * reperage du chpoint de pression
  674. segini icpr
  675. mchpoi=ipchpO
  676. segact mchpoi
  677. ino=0
  678. if(ipchp(/1).ne.1) then
  679. call erreur(19)
  680. return
  681. endif
  682. msoupo=ipchp(1)
  683. segact msoupo
  684. if(noharm(/1).ne.1)then
  685. call erreur(180)
  686. return
  687. endif
  688. meleme=igeoc
  689. segact meleme
  690. do ia=1,num(/2)
  691. ib=num(1,ia)
  692. if(icpr(ib).eq.0) then
  693. ino=ino+1
  694. icpr(ib)=ino
  695. endif
  696. enddo
  697. segdes meleme
  698. mpoval=ipoval
  699. segact mpoval
  700. * on cherche si surf interne ou externe
  701. meleme=ipmail
  702. if(lisref(/1).ne.2) then
  703. call erreur (1004)
  704. return
  705. endif
  706. isur=0
  707. do icas=1,2
  708. ipt3=lisref(icas)
  709. segact ipt3
  710. do ia=1,ipt3.num(/2)
  711. do ic=1,4
  712. ib=ipt3.num(ic,ia)
  713. if(icpr(ib).eq.0) go to 2260
  714. enddo
  715. enddo
  716. isur=icas
  717. go to 3260
  718. 2260 continue
  719. segdes ipt3
  720. enddo
  721. call erreur(286)
  722. return
  723. 3260 continue
  724. propel(2)=isur
  725.  
  726. DO 4260 IB=1,NBELEM
  727. C
  728. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  729. C
  730. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  731. CALL ZERO(REL,LRE,LRE)
  732. C
  733. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  734. C
  735. pre=0.d0
  736. do ia=1,4
  737. ibb=ipt3.num(ia,ib)
  738. pre=pre+vpocha(icpr(ibb),1)/4
  739. enddo
  740. propel(1)=pre
  741.  
  742. C
  743. C APPEL A shb8 KP
  744. C
  745. call shb8(10,xe,D,propel,work1,rel,out)
  746. C
  747. C REMPLISSAGE DE XMATRI
  748. C
  749. * SEGINI XMATRI
  750. * IMATTT(IB)=XMATRI
  751. CALL REMPMT(REL,LRE,RE(1,1,ib))
  752. * SEGDES XMATRI
  753. 4260 CONTINUE
  754. SEGDES xMATRI
  755. SEGSUP WRK1,WRK7
  756. segsup icpr
  757. segdes mpoval
  758. GOTO 510
  759. C_______________________________________________________________________
  760. C
  761. C ELEMENT COQ6 NON ENCORE BRANCHE
  762. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  763. C_______________________________________________________________________
  764. C
  765. 56 CONTINUE
  766. NBBB=NBNN
  767. SEGINI WRK1,WRK3
  768. DO 3056 IB=1,NBELEM
  769. C
  770. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  771. C
  772. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  773. C
  774. CALL ZERO(REL,LRE,LRE)
  775. C
  776. C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
  777. C
  778. PRESS=0.D0
  779. IF(MELVAL.NE.0)THEN
  780. IBMN=MIN(IB ,VELCHE(/2))
  781. DO 4056 IGAU=1,NBNN
  782. IGMN=MIN(IGAU,VELCHE(/1))
  783. PRESS=PRESS+VELCHE(IGMN,IBMN)
  784. 4056 CONTINUE
  785. PRESS=PRESS/NBNN
  786. ENDIF
  787. * IE= 0
  788. * DO 7056 IGAU=1,NBNN
  789. * IE=IE+1
  790. * IF (MELVAL.NE.0) THEN
  791. * IGMN=MIN(IGAU,VELCHE(/1))
  792. * IBMN=MIN(IB ,VELCHE(/2))
  793. * WORK(IE)=VELCHE(IGMN,IBMN)
  794. * ELSE
  795. * WORK(IE)=0.D0
  796. * ENDIF
  797. * 7056 CONTINUE
  798. C
  799. C ON CALCULE LA RIGIDITE GEOMETRIQUE
  800. C
  801. * SEGINI XMATRI
  802. CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
  803. C
  804. C REMPLISSAGE DE XMATRI
  805. C
  806. * SEGINI XMATRI
  807. * IMATTT(IB)=XMATRI
  808. * CALL REMPMC(REL,LRE,RE)
  809. * SEGDES XMATRI
  810. 3056 CONTINUE
  811. SEGDES xMATRI
  812. SEGSUP WRK1,WRK3
  813. GO TO 510
  814. C_______________________________________________________________________
  815. C
  816. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  817. C_______________________________________________________________________
  818. C
  819. 510 CONTINUE
  820. SEGDES MELEME
  821. SEGDES IMODEL
  822. IF (IVAPR.NE.0) SEGDES MELVAL
  823. C
  824. if(mele.ne.260)SEGDES MINTE
  825. C SEGSUP INFO
  826. C_______________________________________________________________________
  827. C
  828. C FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
  829. C_______________________________________________________________________
  830. C
  831. 500 CONTINUE
  832. C
  833. SEGDES MRIGID
  834. SEGDES MMODEL
  835. SEGDES MCHEL1
  836. SEGSUP,LIMODL
  837. IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  838. RETURN
  839. C
  840. C_______________________________________________________________________
  841. C
  842. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  843. C_______________________________________________________________________
  844. C
  845. C ELEMENT NON IMPLEMENTE
  846. C
  847. 99 CONTINUE
  848. MOTERR(1:4)=NOMTP(MELE)
  849. MOTERR(5:12)='KPRES '
  850. CALL ERREUR(86)
  851. C
  852. 9990 CONTINUE
  853. IRET=0
  854.  
  855. IF(IVAPR.NE.0)SEGDES MELVAL
  856. C
  857. SEGSUP,LIMODL
  858. SEGDES MELEME
  859. SEGDES IMODEL
  860. SEGSUP DESCR
  861. SEGSUP xMATRI
  862. C
  863. SEGDES MMODEL
  864. SEGDES MCHEL1
  865. IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  866. SEGDES MINTE
  867. C SEGSUP INFO
  868. SEGSUP MRIGID
  869. RETURN
  870. END
  871.  
  872.  
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  
  880.  

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