Télécharger kpres.eso

Retour à la liste

Numérotation des lignes :

  1. C KPRES SOURCE CB215821 17/01/16 21:15:54 9279
  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. ELSE
  372. IRIGEL(7, ISOUS) = 2
  373. ENDIF
  374. C_______________________________________________________________________
  375. C
  376. C VALEURS DE PRESSION
  377. C_______________________________________________________________________
  378. C
  379. CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
  380. MCHAM1=MCHEL1.ICHAML(IM)
  381. SEGACT MCHAM1
  382. IVAPR=MCHAM1.IELVAL(1)
  383. SEGDES MCHAM1
  384. MELVAL=IVAPR
  385. IF(IVAPR.NE.0)SEGACT MELVAL
  386. *
  387. C=======================================================================
  388. C NUMERO DES ETIQUETTES :
  389. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  390. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  391. C 5 CONTINUE
  392. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  393. C 44 CONTINUE
  394. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  395. C=======================================================================
  396.  
  397. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  398. 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  399. 2 41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
  400. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  401. 4 99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
  402. C
  403.  
  404. if(mele.eq.260) go to 1260
  405. GOTO 99
  406. 27 CONTINUE
  407. C_______________________________________________________________________
  408. C
  409. C ELEMENT COQ3
  410. C_______________________________________________________________________
  411. C
  412. NBBB=NBNN
  413. SEGINI WRK1,WRK3,WRK4
  414. DO 3027 IB=1,NBELEM
  415. C
  416. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  417. C
  418. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  419. CALL ZERO(REL,LRE,LRE)
  420. C
  421. C ON CHERCHE LES PRESSIONS
  422. C
  423. PRESS=0.D0
  424. IF(MELVAL.NE.0)THEN
  425. IBMN=MIN(IB ,VELCHE(/2))
  426. DO 4027 IGAU=1,NBNN
  427. IGMN=MIN(IGAU,VELCHE(/1))
  428. PRESS=PRESS+VELCHE(IGMN,IBMN)
  429. 4027 CONTINUE
  430. PRESS=PRESS/NBNN
  431. ENDIF
  432. C
  433. C ON CALCULE K(P)
  434. C
  435. * SEGINI XMATRI
  436. CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  437. * SEGINI XMATRI
  438. * IMATTT(IB)=XMATRI
  439. C
  440. C REMPLISSAGE DE XMATRI
  441. C
  442. * CALL REMPMC(REL,LRE,RE(1,1,ib))
  443. * SEGDES XMATRI
  444. 3027 CONTINUE
  445. SEGDES xMATRI
  446. SEGSUP WRK1,WRK3,WRK4
  447. GOTO 510
  448. C_______________________________________________________________________
  449. C
  450. C ELEMENT DKT POUR L INSTANT = COQ3
  451. C_______________________________________________________________________
  452. C
  453. 28 CONTINUE
  454. NBBB=NBNN
  455. SEGINI WRK1,WRK3,WRK4
  456. DO 3028 IB=1,NBELEM
  457. C
  458. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  459. C
  460. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  461. C
  462. CALL ZERO(REL,LRE,LRE)
  463. C
  464. C ON CHERCHE LES PRESSIONS
  465. C
  466. PRESS=0.D0
  467. IF(MELVAL.NE.0)THEN
  468. IBMN=MIN(IB ,VELCHE(/2))
  469. DO 4028 IGAU=1,NBNN
  470. IGMN=MIN(IGAU,VELCHE(/1))
  471. PRESS=PRESS+VELCHE(IGMN,IBMN)
  472. 4028 CONTINUE
  473. PRESS=PRESS/NBNN
  474. ENDIF
  475. C
  476. C ON CALCULE K(P)
  477. C
  478. * SEGINI XMATRI
  479. CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
  480. * SEGINI XMATRI
  481. * IMATTT(IB)=XMATRI
  482. C
  483. C REMPLISSAGE DE XMATRI
  484. C
  485. * CALL REMPMC(REL,LRE,RE)
  486. * SEGDES XMATRI
  487. 3028 CONTINUE
  488. SEGDES xMATRI
  489. SEGSUP WRK1,WRK3,WRK4
  490. GOTO 510
  491. C_______________________________________________________________________
  492. C
  493. C ELEMENT COQ8 NON ENCORE BRANCHE
  494. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  495. C_______________________________________________________________________
  496. C
  497. 41 CONTINUE
  498. NBBB=NBNN
  499. SEGINI WRK1,WRK3
  500. DO 3041 IB=1,NBELEM
  501. C
  502. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  503. C
  504. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  505. C
  506. CALL ZERO(REL,LRE,LRE)
  507. C
  508. C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
  509. C
  510. PRESS=0.D0
  511. IF(MELVAL.NE.0)THEN
  512. IBMN=MIN(IB ,VELCHE(/2))
  513. DO 4041 IGAU=1,NBNN
  514. IGMN=MIN(IGAU,VELCHE(/1))
  515. PRESS=PRESS+VELCHE(IGMN,IBMN)
  516. 4041 CONTINUE
  517. PRESS=PRESS/NBNN
  518. ENDIF
  519. * IE=0
  520. * DO 7041 IGAU=1,NBNN
  521. * IE=IE+1
  522. * IF (MELVAL.NE.0) THEN
  523. * IGMN=MIN(IGAU,VELCHE(/1))
  524. * IBMN=MIN(IB ,VELCHE(/2))
  525. * WORK(IE)=VELCHE(IGMN,IBMN)
  526. * ELSE
  527. * WORK(IE)=0.D0
  528. * ENDIF
  529. * 7041 CONTINUE
  530. C
  531. C ON CALCULE LA RIGIDITE GEOMETRIQUE
  532. C
  533. * SEGINI XMATRI
  534. CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
  535. C
  536. C REMPLISSAGE DE XMATRI
  537. C
  538. * SEGINI XMATRI
  539. * IMATTT(IB)=XMATRI
  540. * CALL REMPMC(REL,LRE,RE)
  541. * SEGDES XMATRI
  542. 3041 CONTINUE
  543. SEGDES xMATRI
  544. SEGSUP WRK1,WRK3
  545. GO TO 510
  546. C_______________________________________________________________________
  547. C
  548. C ELEMENT COQ2
  549. C_______________________________________________________________________
  550. C
  551. 44 CONTINUE
  552. *
  553. * AM 01/09/94 PETIT TEST SUR IFOUR CAR NE FONCTIONNE
  554. * QU'EN SERIE DE FOURIER
  555. *
  556. IF(IFOUR.NE.1) GO TO 99
  557.  
  558. * BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
  559. IF(IASYM.NE.0) THEN
  560. write(ioimp,*) 'L option de calcul ASYMetrique ',
  561. & 'n est pas disponible avec les coq2 !'
  562. call ERREUR(19)
  563. goto 9990
  564. ENDIF
  565.  
  566. NBBB=NBNN
  567. SEGINI WRK1,WRK3,WRK4
  568. DO 3044 IB=1,NBELEM
  569. C
  570. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  571. C
  572. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  573. CALL ZERO(REL,LRE,LRE)
  574. C
  575. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  576. C
  577. WORK(1)=0.D0
  578.  
  579. IF(MELVAL.NE.0)THEN
  580. IBMN=MIN(IB ,VELCHE(/2))
  581. DO 1344 IGAU=1,NBNN
  582. IGMN=MIN(IGAU,VELCHE(/1))
  583. WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
  584. 1344 CONTINUE
  585. WORK(1)=WORK(1)/NBNN
  586. ENDIF
  587. C
  588. C APPEL A COQUE2 KP
  589. C
  590. AN=NHRM
  591. CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
  592. 1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
  593. 2 WORK(157),WORK(221),WORK(285))
  594. C
  595. C REMPLISSAGE DE XMATRI
  596. C
  597. * SEGINI XMATRI
  598. * IMATTT(IB)=XMATRI
  599. CALL REMPMT(REL,LRE,RE(1,1,ib))
  600. * SEGDES XMATRI
  601. 3044 CONTINUE
  602. SEGDES xMATRI
  603. SEGSUP WRK1,WRK3,WRK4
  604. GOTO 510
  605. C_______________________________________________________________________
  606. C
  607. C ELEMENT COQ4 NON ENCORE BRANCHE
  608. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  609. C_______________________________________________________________________
  610. C
  611. 49 CONTINUE
  612. NBBB=NBNN
  613. SEGINI WRK1,WRK3,WRK4
  614. DO 3049 IB=1,NBELEM
  615. C
  616. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  617. C
  618. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  619. C
  620. CALL ZERO(REL,LRE,LRE)
  621. C
  622. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  623. C
  624. PRESS=0.D0
  625. IF(MELVAL.NE.0)THEN
  626. IBMN=MIN(IB ,VELCHE(/2))
  627. DO 4049 IGAU=1,NBNN
  628. IGMN=MIN(IGAU,VELCHE(/1))
  629. PRESS=PRESS+VELCHE(IGMN,IBMN)
  630. 4049 CONTINUE
  631. PRESS=PRESS/NBNN
  632. ENDIF
  633. * IE=0
  634. * DO 5049 IGAU=1,NBNN
  635. * IE=IE+1
  636. * IF (MELVAL.NE.0) THEN
  637. * IGMN=MIN(IGAU,VELCHE(/1))
  638. * IBMN=MIN(IB ,VELCHE(/2))
  639. * WORK(IE)=VELCHE(IGMN,IBMN)
  640. * ELSE
  641. * WORK(IE)=0.D0
  642. * ENDIF
  643. * 5049 CONTINUE
  644. C
  645. C APPEL A COQUE4 KSIGMA...
  646. C
  647. AN=NHRM
  648. * SEGINI XMATRI
  649. * CALL KPCOQ4(XE,PRESS,REL,IASYM)
  650. CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
  651. C
  652. C REMPLISSAGE DE XMATRI
  653. C
  654. * SEGINI XMATRI
  655. * IMATTT(IB)=XMATRI
  656. * CALL REMPMC(REL,LRE,RE)
  657. * SEGDES XMATRI
  658. 3049 CONTINUE
  659. SEGDES xMATRI
  660. SEGSUP WRK1,WRK3,WRK4
  661. GOTO 510
  662. C_______________________________________________________________________
  663. C
  664. C element SHB8
  665. C_______________________________________________________________________
  666. C
  667. 1260 continue
  668. *
  669. NBBB=NBNN
  670. SEGINI WRK1,wrk7
  671. * reperage du chpoint de pression
  672. segini icpr
  673. mchpoi=ipchpO
  674. segact mchpoi
  675. ino=0
  676. if(ipchp(/1).ne.1) then
  677. call erreur(19)
  678. return
  679. endif
  680. msoupo=ipchp(1)
  681. segact msoupo
  682. if(noharm(/1).ne.1)then
  683. call erreur(180)
  684. return
  685. endif
  686. meleme=igeoc
  687. segact meleme
  688. do ia=1,num(/2)
  689. ib=num(1,ia)
  690. if(icpr(ib).eq.0) then
  691. ino=ino+1
  692. icpr(ib)=ino
  693. endif
  694. enddo
  695. segdes meleme
  696. mpoval=ipoval
  697. segact mpoval
  698. * on cherche si surf interne ou externe
  699. meleme=ipmail
  700. if(lisref(/1).ne.2) then
  701. call erreur (1004)
  702. return
  703. endif
  704. isur=0
  705. do icas=1,2
  706. ipt3=lisref(icas)
  707. segact ipt3
  708. do ia=1,ipt3.num(/2)
  709. do ic=1,4
  710. ib=ipt3.num(ic,ia)
  711. if(icpr(ib).eq.0) go to 2260
  712. enddo
  713. enddo
  714. isur=icas
  715. go to 3260
  716. 2260 continue
  717. segdes ipt3
  718. enddo
  719. call erreur(286)
  720. return
  721. 3260 continue
  722. propel(2)=isur
  723.  
  724. DO 4260 IB=1,NBELEM
  725. C
  726. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  727. C
  728. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  729. CALL ZERO(REL,LRE,LRE)
  730. C
  731. C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
  732. C
  733. pre=0.d0
  734. do ia=1,4
  735. ibb=ipt3.num(ia,ib)
  736. pre=pre+vpocha(icpr(ibb),1)/4
  737. enddo
  738. propel(1)=pre
  739.  
  740. C
  741. C APPEL A shb8 KP
  742. C
  743. call shb8(10,xe,D,propel,work1,rel,out)
  744. C
  745. C REMPLISSAGE DE XMATRI
  746. C
  747. * SEGINI XMATRI
  748. * IMATTT(IB)=XMATRI
  749. CALL REMPMT(REL,LRE,RE(1,1,ib))
  750. * SEGDES XMATRI
  751. 4260 CONTINUE
  752. SEGDES xMATRI
  753. SEGSUP WRK1,WRK7
  754. segsup icpr
  755. segdes mpoval
  756. GOTO 510
  757. C_______________________________________________________________________
  758. C
  759. C ELEMENT COQ6 NON ENCORE BRANCHE
  760. C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
  761. C_______________________________________________________________________
  762. C
  763. 56 CONTINUE
  764. NBBB=NBNN
  765. SEGINI WRK1,WRK3
  766. DO 3056 IB=1,NBELEM
  767. C
  768. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  769. C
  770. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  771. C
  772. CALL ZERO(REL,LRE,LRE)
  773. C
  774. C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
  775. C
  776. PRESS=0.D0
  777. IF(MELVAL.NE.0)THEN
  778. IBMN=MIN(IB ,VELCHE(/2))
  779. DO 4056 IGAU=1,NBNN
  780. IGMN=MIN(IGAU,VELCHE(/1))
  781. PRESS=PRESS+VELCHE(IGMN,IBMN)
  782. 4056 CONTINUE
  783. PRESS=PRESS/NBNN
  784. ENDIF
  785. * IE= 0
  786. * DO 7056 IGAU=1,NBNN
  787. * IE=IE+1
  788. * IF (MELVAL.NE.0) THEN
  789. * IGMN=MIN(IGAU,VELCHE(/1))
  790. * IBMN=MIN(IB ,VELCHE(/2))
  791. * WORK(IE)=VELCHE(IGMN,IBMN)
  792. * ELSE
  793. * WORK(IE)=0.D0
  794. * ENDIF
  795. * 7056 CONTINUE
  796. C
  797. C ON CALCULE LA RIGIDITE GEOMETRIQUE
  798. C
  799. * SEGINI XMATRI
  800. CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
  801. C
  802. C REMPLISSAGE DE XMATRI
  803. C
  804. * SEGINI XMATRI
  805. * IMATTT(IB)=XMATRI
  806. * CALL REMPMC(REL,LRE,RE)
  807. * SEGDES XMATRI
  808. 3056 CONTINUE
  809. SEGDES xMATRI
  810. SEGSUP WRK1,WRK3
  811. GO TO 510
  812. C_______________________________________________________________________
  813. C
  814. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  815. C_______________________________________________________________________
  816. C
  817. 510 CONTINUE
  818. SEGDES MELEME
  819. SEGDES IMODEL
  820. IF (IVAPR.NE.0) SEGDES MELVAL
  821. C
  822. if(mele.ne.260)SEGDES MINTE
  823. C SEGSUP INFO
  824. C_______________________________________________________________________
  825. C
  826. C FIN DE BOUCLE SUR LES MODELES ELEMENTAIRES
  827. C_______________________________________________________________________
  828. C
  829. 500 CONTINUE
  830. C
  831. SEGDES MRIGID
  832. SEGDES MMODEL
  833. SEGDES MCHEL1
  834. SEGSUP,LIMODL
  835. IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  836. RETURN
  837. C
  838. C_______________________________________________________________________
  839. C
  840. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  841. C_______________________________________________________________________
  842. C
  843. C ELEMENT NON IMPLEMENTE
  844. C
  845. 99 CONTINUE
  846. MOTERR(1:4)=NOMTP(MELE)
  847. MOTERR(5:12)='KPRES '
  848. CALL ERREUR(86)
  849. C
  850. 9990 CONTINUE
  851. IRET=0
  852.  
  853. IF(IVAPR.NE.0)SEGDES MELVAL
  854. C
  855. SEGSUP,LIMODL
  856. SEGDES MELEME
  857. SEGDES IMODEL
  858. SEGSUP DESCR
  859. SEGSUP xMATRI
  860. C
  861. SEGDES MMODEL
  862. SEGDES MCHEL1
  863. IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
  864. SEGDES MINTE
  865. C SEGSUP INFO
  866. SEGSUP MRIGID
  867. RETURN
  868. END
  869.  
  870.  
  871.  
  872.  
  873.  
  874.  
  875.  
  876.  
  877.  

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