Télécharger permab.eso

Retour à la liste

Numérotation des lignes :

  1. C PERMAB SOURCE BP208322 17/03/01 21:17:56 9325
  2. SUBROUTINE PERMAB (MODORI,MCHORI,IPRIGI,IRET)
  3. *______________________________________________________________________
  4. *
  5. * OPERATEUR PERMEABILITE (MILIEUX POREUX) APPELE PAR PERMEA
  6. *
  7. * Entrees :
  8. * ---------
  9. *
  10. * MODORI Pointeur sur un MMODEL
  11. * MCHORI Pointeur sur un MCHAML de materiau
  12. *
  13. * Sorties :
  14. * ---------
  15. *
  16. * IPRIGI Pointeur sur un objet RIGIDITE de permeabilite
  17. * IRET =1 ou 0 suivant succes ou non
  18. *
  19. * Passage aux nouveaux CHAMELEMs par jm CAMPENON le 07/91
  20. *______________________________________________________________________
  21. *
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8(A-H,O-Z)
  24. *
  25. -INC CCHAMP
  26. -INC CCOPTIO
  27. -INC CCGEOME
  28. -INC SMRIGID
  29. -INC SMCHAML
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC SMINTE
  33. -INC SMMODEL
  34. *
  35. SEGMENT WRK1
  36. REAL*8 REL(LRE,LRE),XE(3,NBBB)
  37. ENDSEGMENT
  38. *
  39. SEGMENT WRK2
  40. REAL*8 SHPWRK(6,NBNO),BGENE(NSTB,LRE)
  41. ENDSEGMENT
  42. *
  43. SEGMENT WRK3
  44. REAL*8 XGENE(NSTN,LRN)
  45. ENDSEGMENT
  46. *
  47. SEGMENT WRK4
  48. REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  49. REAL*8 VALMAT(NMATT)
  50. REAL*8 PMAT(NSTB,NSTB),PMAT1(IDIM,IDIM),PMAT2(IDIM,IDIM)
  51. ENDSEGMENT
  52. *
  53. SEGMENT WRK5
  54. REAL*8 BPSS(3,3),XEL(3,NBBB)
  55. REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP)
  56. ENDSEGMENT
  57. *
  58. SEGMENT WRK6
  59. REAL*8 PKK(NSTPK,NSTPK)
  60. ENDSEGMENT
  61. *
  62. SEGMENT INFO
  63. INTEGER INFELL(JG)
  64. ENDSEGMENT
  65. *
  66. SEGMENT NOTYPE
  67. CHARACTER*16 TYPE(NBTYPE)
  68. ENDSEGMENT
  69. *
  70. SEGMENT MPTVAL
  71. INTEGER IPOS(NS),NSOF(NS)
  72. INTEGER IVAL(NCOSOU)
  73. CHARACTER*16 TYVAL(NCOSOU)
  74. ENDSEGMENT
  75. *
  76.  
  77. INTEGER OOOVAL
  78.  
  79. CHARACTER*8 CMATE
  80. CHARACTER*(NCONCH) CONM
  81.  
  82.  
  83. * INTTYP correspond au type de points d'integration utilise
  84. PARAMETER ( INTTYP=3 )
  85.  
  86. PARAMETER (NINF=3)
  87. INTEGER INFOS(NINF)
  88. LOGICAL lsupfo,lsupdp
  89. *
  90. NHRM=NIFOUR
  91. IRET = 0
  92. IPRIGI = 0
  93. *
  94. * Reduction du modele a la formulation poreuse
  95. *
  96. MMODE1 = MODORI
  97. SEGINI,MMODEL=MMODE1
  98. NSOUS = KMODEL(/1)
  99. N1 = 0
  100. DO isous = 1, NSOUS
  101. IMODEL = KMODEL(isous)
  102. SEGACT,IMODEL
  103. IF (FORMOD(1).EQ.'POREUX') THEN
  104. N1 = N1 + 1
  105. KMODEL(N1) = IMODEL
  106. ELSE
  107. SEGDES,IMODEL
  108. ENDIF
  109. ENDDO
  110. IF (N1.NE.NSOUS) SEGADJ,MMODEL
  111. IPMODL = MMODEL
  112. NSOUS = N1
  113. IF (NSOUS.LE.0) THEN
  114. MOTERR(1:8) = 'MMODEL '
  115. INTERR(1) = MODORI
  116. CALL ERREUR(356)
  117. GOTO 9991
  118. ENDIF
  119.  
  120. *
  121. * Reduction du champ au modele precedemment reduit
  122. *
  123. MCHELM = MCHORI
  124. SEGACT,MCHELM
  125. IF (TITCHE(1:8).NE.'CARACTER') THEN
  126. SEGDES,MCHELM
  127. MOTERR(1:16) = 'CARACTERISTIQUES'
  128. CALL ERREUR(291)
  129. GOTO 9991
  130. ENDIF
  131. CALL REDUAF(MCHORI,IPMODL,IPCHE1,0,IRET,KERRE)
  132. SEGDES,MCHELM
  133. IF (IRET.NE.1) THEN
  134. CALL ERREUR(KERRE)
  135. GOTO 9991
  136. ENDIF
  137. *
  138. * Verification du lieu support du MCHAML de materiau
  139. *
  140. ISUP=0
  141. CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUP,IRETMA)
  142. IF (ISUP.GT.1) GO TO 9991
  143. *
  144. * Activation du MMODEL
  145. *
  146. MMODEL=IPMODL
  147. SEGACT MMODEL
  148. NSOUS=KMODEL(/1)
  149. *
  150. * ON FABRIQUE LES MATRICES UNIQUEMENT POUR LES ZONES
  151. * DE MILIEU POREUX.
  152. *
  153. NRIGEL=NSOUS
  154. *
  155. * Initialisation du chapeau de l'objet RIGIDITE
  156. *
  157. SEGINI MRIGID
  158. ICHOLE=0
  159. IMGEO1=0
  160. IMGEO2=0
  161. IFORIG=IFOUR
  162. MTYMAT='PERMEABI'
  163. *
  164. * BOUCLE SUR LES SOUS ZONES DU MODELE
  165. *
  166. ISORI=0
  167. DO 500 ISOUS=1,NSOUS
  168. *
  169. * On recupere l'information generale
  170. *
  171. IMODEL=KMODEL(ISOUS)
  172. SEGACT IMODEL
  173.  
  174. IF(FORMOD(1).NE.'POREUX') THEN
  175. CALL ERREUR(19)
  176. GO TO 9999
  177. ENDIF
  178. *
  179. * Traitement du modele
  180. *
  181. MELE=NEFMOD
  182. IPMAIL=IMAMOD
  183. CONM =CONMOD
  184.  
  185. *
  186. CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD)
  187. IF (IRTD.EQ.0) GOTO 9999
  188. *
  189. * Nature du materiau
  190. *
  191. CMATE = CMATEE
  192. MATE = IMATEE
  193. INAT = INATUU
  194. *
  195. * Information sur l'element fini
  196. *
  197. IF (INFMOD(/1).LT.2+INTTYP) THEN
  198. CALL ELQUOI(MELE,0,INTTYP,IPINF,IMODEL)
  199. IF (IERR.NE.0) GO TO 9999
  200. INFO=IPINF
  201. MFR =INFELL(13)
  202. IELE =INFELL(14)
  203. IPORE=INFELL(8)
  204. MINTE=INFELL(11)
  205. segsup info
  206. else
  207. MFR =INFELE(13)
  208. IELE =INFELE(14)
  209. IPORE=INFELE(8)
  210. MINTE=infmod(5)
  211. endif
  212. IPMINT=MINTE
  213. *
  214. * Si necessaire PARTITIONNEMENT du segment XMATRI
  215. *
  216. IPT1=IPMAIL
  217. SEGACT,IPT1
  218. NBNN1 =IPT1.NUM(/1)
  219. NBELE1=IPT1.NUM(/2)
  220. *
  221. LASYM=0
  222. IF(MFR.EQ.33) THEN
  223. IDECAP=1
  224. ELSE IF(MFR.EQ.57) THEN
  225. IDECAP=2
  226. LASYM=2
  227. ELSE IF(MFR.EQ.59) THEN
  228. IDECAP=3
  229. LASYM=2
  230. ENDIF
  231. LR1=NBNNE(IELE)
  232. LRE=LR1*IDECAP
  233. *
  234. LTRK=OOOVAL(1,4)
  235. IF (LTRK.EQ.0) LTRK=OOOVAL(1,1)
  236. * Ajout a la taille en mots de la matrice des infos du segment
  237. LSEG=LRE*LRE*NBELE1 + 16
  238. NBLPRT=(LSEG-1)/LTRK+1
  239. NBLMAX=(NBELE1-1)/NBLPRT+1
  240. NBLPRT=(NBELE1-1)/NBLMAX+1
  241. * write(ioimp,*) ' PERMAB nblprt nblmax ',NBLPRT,NBLMAX,NBELE1
  242. MELEME=IPT1
  243.  
  244. * BOUCLE DE PARTITIONNEMENT DU SEGMENT XMATRI
  245.  
  246. DO 5000 IPRT = 1,NBLPRT
  247. ISORI= ISORI+1
  248. IF (ISORI.GT.IRIGEL(/2)) THEN
  249. NRIGEL=ISORI
  250. SEGADJ,MRIGID
  251. ENDIF
  252. IF (NBLPRT.GT.1) THEN
  253. JPRT=(IPRT-1)*NBLMAX
  254. SEGACT,IPT1
  255. NBSOUS=0
  256. NBREF=0
  257. NBNN=NBNN1
  258. NBELEM=MIN(NBLMAX,NBELE1-JPRT)
  259. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  260. SEGINI,MELEME
  261. ITYPEL=IPT1.ITYPEL
  262. DO I=1,NBELEM
  263. IB=I+JPRT
  264. DO J=1,NBNN
  265. NUM(J,I)=IPT1.NUM(J,IB)
  266. ENDDO
  267. ICOLOR(I)=IPT1.ICOLOR(I)
  268. ENDDO
  269. ENDIF
  270. IPMAIL=MELEME
  271. * Fin du traitement particulier en cas de PARTITIONNEMENT du XMATRI
  272. * Quelques initialisations suite au partionnement
  273. IPDES = 0
  274. *
  275. NMATR = 0
  276. NMATF = 0
  277. IVAMAT = 0
  278. NCARA = 0
  279. NCARF = 0
  280. IVACAR = 0
  281.  
  282. * Activation du MELEME support des rigidites
  283. MELEME=IPMAIL
  284. SEGACT,MELEME
  285. NBNN =NUM(/1)
  286. NBELEM=NUM(/2)
  287.  
  288. NLIGRP = LRE
  289. NLIGRD = LRE
  290. SEGINI DESCR
  291. if(lnomid(1).ne.0) then
  292. nomid=lnomid(1)
  293. segact nomid
  294. modepl=nomid
  295. ndepl=lesobl(/2)
  296. ndum=lesfac(/2)
  297. lsupdp=.false.
  298. else
  299. lsupdp=.true.
  300. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  301. endif
  302. if(lnomid(2).ne.0) then
  303. nomid=lnomid(2)
  304. segact nomid
  305. moforc=nomid
  306. nforc=lesobl(/2)
  307. lsupfo=.false.
  308. else
  309. lsupfo=.true.
  310. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  311. endif
  312. *
  313. ID=1
  314. NOMID=MODEPL
  315. SEGACT NOMID
  316. NCP=LESOBL(/2)
  317. NOMID=MOFORC
  318. SEGACT NOMID
  319. *
  320. IF (MFR.EQ.33) THEN
  321.  
  322. DO 4005 IB=1,NBSOM(IELE)
  323. NOMID=MODEPL
  324. LISINC(ID)=LESOBL(NCP)
  325. NOMID=MOFORC
  326. LISDUA(ID)=LESOBL(NCP)
  327. NOELEP(ID)=IBSOM(NSPOS(IELE)+IB-1)
  328. NOELED(ID)=IBSOM(NSPOS(IELE)+IB-1)
  329. ID=ID+1
  330. 4005 CONTINUE
  331. *
  332. IF (MELE.GE.108.AND.MELE.LE.110) THEN
  333. *
  334. LR1=(3*LRE-IPORE)/2
  335. DO 4008 INOEUD=LR1+1,LRE
  336. NOMID=MODEPL
  337. LISINC(ID)=LESOBL(NCP)
  338. NOMID=MOFORC
  339. LISDUA(ID)=LESOBL(NCP)
  340. NOELEP(ID)=INOEUD
  341. NOELED(ID)=INOEUD
  342. ID=ID+1
  343. 4008 CONTINUE
  344. END IF
  345. *
  346. DO 4006 IB=1,LR1
  347. DO 4007 INSOM=1,NBSOM(IELE)
  348. IF(IB.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 4006
  349. 4007 CONTINUE
  350. NOMID=MODEPL
  351. LISINC(ID)=LESOBL(NCP)
  352. NOMID=MOFORC
  353. LISDUA(ID)=LESOBL(NCP)
  354. NOELEP(ID)=IB
  355. NOELED(ID)=IB
  356. ID=ID+1
  357. 4006 CONTINUE
  358. *
  359. ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  360.  
  361. DO 4205 IPR=1,IDECAP
  362. NCPDEC=NCP-IDECAP+IPR
  363. *
  364. DO 4105 IB=1,NBSOM(IELE)
  365. NOMID=MODEPL
  366. LISINC(ID)=LESOBL(NCPDEC)
  367. NOMID=MOFORC
  368. LISDUA(ID)=LESOBL(NCPDEC)
  369. NOELEP(ID)=IBSOM(NSPOS(IELE)+IB-1)
  370. NOELED(ID)=IBSOM(NSPOS(IELE)+IB-1)
  371. ID=ID+1
  372. 4105 CONTINUE
  373. *
  374. IF (MELE.GE.185.AND.MELE.LE.190) THEN
  375. *
  376. LR1=(3*NBNNE(IELE)-IPORE)/2
  377. DO 4108 INOEUD=LR1+1,NBNNE(IELE)
  378. NOMID=MODEPL
  379. LISINC(ID)=LESOBL(NCPDEC)
  380. NOMID=MOFORC
  381. LISDUA(ID)=LESOBL(NCPDEC)
  382. NOELEP(ID)=INOEUD
  383. NOELED(ID)=INOEUD
  384. ID=ID+1
  385. 4108 CONTINUE
  386. END IF
  387. * FIN NEW
  388. *
  389. DO 4106 IB=1,LR1
  390. DO 4107 INSOM=1,NBSOM(IELE)
  391. IF(IB.EQ.IBSOM(NSPOS(IELE)+INSOM-1)) GO TO 4106
  392. 4107 CONTINUE
  393. NOMID=MODEPL
  394. LISINC(ID)=LESOBL(NCPDEC)
  395. NOMID=MOFORC
  396. LISDUA(ID)=LESOBL(NCPDEC)
  397. NOELEP(ID)=IB
  398. NOELED(ID)=IB
  399. ID=ID+1
  400. 4106 CONTINUE
  401.  
  402. 4205 CONTINUE
  403. *
  404. ENDIF
  405.  
  406. NOMID =MOFORC
  407. if(lsupfo)SEGSUP NOMID
  408. NOMID =MODEPL
  409. if(lsupdp)SEGSUP NOMID
  410. IPDES=DESCR
  411. SEGDES DESCR
  412. *
  413. * Initialisation de MINTE
  414. *
  415. SEGACT MINTE
  416. NBPGAU=POIGAU(/1)
  417. *
  418.  
  419. CCCCCC LVAL=(LRE*(LRE+1))/2
  420. NELRIG=NBELEM
  421. SEGINI xMATRI
  422. *
  423. * Verification de la presence des composantes pour le materiau
  424. *
  425. NBROBL=0
  426. NBRFAC=0
  427. * cas isotrope
  428. IF (MATE.EQ.1) THEN
  429. *
  430. IF (MELE.GE.79.AND.MELE.LE.83) THEN
  431. NBROBL=2
  432. SEGINI NOMID
  433. LESOBL(1)='PERM'
  434. LESOBL(2)='VISC'
  435. ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  436. NBROBL=4
  437. SEGINI NOMID
  438. LESOBL(1)='PERT'
  439. LESOBL(2)='PERH'
  440. LESOBL(3)='PERB'
  441. LESOBL(4)='VISC'
  442. ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  443. NBROBL=4
  444. SEGINI NOMID
  445. LESOBL(1)='PK11'
  446. LESOBL(2)='PK12'
  447. LESOBL(3)='PK21'
  448. LESOBL(4)='PK22'
  449. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  450. NBROBL=9
  451. SEGINI NOMID
  452. LESOBL(1)='PK11'
  453. LESOBL(2)='PK12'
  454. LESOBL(3)='PK13'
  455. LESOBL(4)='PK21'
  456. LESOBL(5)='PK22'
  457. LESOBL(6)='PK23'
  458. LESOBL(7)='PK31'
  459. LESOBL(8)='PK32'
  460. LESOBL(9)='PK33'
  461. ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN
  462. NBROBL=12
  463. SEGINI NOMID
  464. LESOBL(1)='PT11'
  465. LESOBL(2)='PH11'
  466. LESOBL(3)='PB11'
  467. LESOBL(4)='PT12'
  468. LESOBL(5)='PH12'
  469. LESOBL(6)='PB12'
  470. LESOBL(7)='PT21'
  471. LESOBL(8)='PH21'
  472. LESOBL(9)='PB21'
  473. LESOBL(10)='PT22'
  474. LESOBL(11)='PH22'
  475. LESOBL(12)='PB22'
  476. ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  477. NBROBL=27
  478. SEGINI NOMID
  479. LESOBL(1)='PT11'
  480. LESOBL(2)='PH11'
  481. LESOBL(3)='PB11'
  482. LESOBL(4)='PT12'
  483. LESOBL(5)='PH12'
  484. LESOBL(6)='PB12'
  485. LESOBL(7)='PT13'
  486. LESOBL(8)='PH13'
  487. LESOBL(9)='PB13'
  488. LESOBL(10)='PT21'
  489. LESOBL(11)='PH21'
  490. LESOBL(12)='PB21'
  491. LESOBL(13)='PT22'
  492. LESOBL(14)='PH22'
  493. LESOBL(15)='PB22'
  494. LESOBL(16)='PT23'
  495. LESOBL(17)='PH23'
  496. LESOBL(18)='PB23'
  497. LESOBL(19)='PT31'
  498. LESOBL(20)='PH31'
  499. LESOBL(21)='PB31'
  500. LESOBL(22)='PT32'
  501. LESOBL(23)='PH32'
  502. LESOBL(24)='PB32'
  503. LESOBL(25)='PT33'
  504. LESOBL(26)='PH33'
  505. LESOBL(27)='PB33'
  506. ENDIF
  507. * cas orthotrope
  508. ELSE IF (MATE.EQ.2) THEN
  509. IF (IDIM.EQ.3) THEN
  510. NBROBL=10
  511. SEGINI NOMID
  512. LESOBL(1)='PER1'
  513. LESOBL(2)='PER2'
  514. LESOBL(3)='PER3'
  515. LESOBL(4)='VISC'
  516. LESOBL(5)='V1X '
  517. LESOBL(6)='V1Y '
  518. LESOBL(7)='V1Z '
  519. LESOBL(8)='V2X '
  520. LESOBL(9)='V2Y '
  521. LESOBL(10)='V2Z '
  522. ELSE IF(IDIM.EQ.2) THEN
  523. IF (IFOUR.LE.0) THEN
  524. NBROBL=5
  525. SEGINI NOMID
  526. LESOBL(1)='PER1'
  527. LESOBL(2)='PER2'
  528. LESOBL(3)='VISC'
  529. LESOBL(4)='V1X '
  530. LESOBL(5)='V1Y '
  531. ELSE IF (IFOUR.EQ.1) THEN
  532. NBROBL=6
  533. SEGINI NOMID
  534. LESOBL(1)='PER1'
  535. LESOBL(2)='PER2'
  536. LESOBL(3)='PER3'
  537. LESOBL(4)='VISC'
  538. LESOBL(5)='V1X '
  539. LESOBL(6)='V1Y '
  540. ENDIF
  541. ENDIF
  542. * cas anisotrope
  543. ELSE IF (MATE.EQ.3)THEN
  544. IF(IDIM.EQ.3)THEN
  545. NBROBL=13
  546. SEGINI NOMID
  547. LESOBL(1)='PER1'
  548. LESOBL(2)='PER2'
  549. LESOBL(3)='PER3'
  550. LESOBL(4)='PE12'
  551. LESOBL(5)='PE13'
  552. LESOBL(6)='PE23'
  553. LESOBL(7)='VISC'
  554. LESOBL(8)='V1X '
  555. LESOBL(9)='V1Y '
  556. LESOBL(10)='V1Z '
  557. LESOBL(11)='V2X '
  558. LESOBL(12)='V2Y '
  559. LESOBL(13)='V2Z '
  560. ELSE IF (IDIM.EQ.2) THEN
  561. IF (IFOUR.LE.0) THEN
  562. NBROBL=6
  563. SEGINI NOMID
  564. LESOBL(1)='PER1'
  565. LESOBL(2)='PER2'
  566. LESOBL(3)='PE12'
  567. LESOBL(4)='VISC'
  568. LESOBL(5)='V1X '
  569. LESOBL(6)='V1Y '
  570. ELSE IF (IFOUR.EQ.1) THEN
  571. NBROBL=7
  572. SEGINI NOMID
  573. LESOBL(1)='PER1'
  574. LESOBL(2)='PER2'
  575. LESOBL(3)='PE12'
  576. LESOBL(4)='PER3'
  577. LESOBL(5)='VISC'
  578. LESOBL(6)='V1X '
  579. LESOBL(7)='V1Y '
  580. ENDIF
  581. ENDIF
  582. * cas unidirectionnel
  583. ELSE IF (MATE.EQ.4) THEN
  584. IF (IDIM.EQ.3) THEN
  585. NBROBL=8
  586. SEGINI NOMID
  587. LESOBL(1)='PERM'
  588. LESOBL(2)='VISC'
  589. LESOBL(3)='V1X '
  590. LESOBL(4)='V1Y '
  591. LESOBL(5)='V1Z '
  592. LESOBL(6)='V2X '
  593. LESOBL(7)='V2Y '
  594. LESOBL(8)='V2Z '
  595. ELSE
  596. NBROBL=4
  597. SEGINI NOMID
  598. LESOBL(1)='PERM'
  599. LESOBL(2)='VISC'
  600. LESOBL(3)='V1X '
  601. LESOBL(4)='V1Y '
  602. ENDIF
  603. ENDIF
  604. *
  605. NMATR=NBROBL
  606. NMATF=NBRFAC
  607. NMATT = NMATR+NMATF
  608. MOMATR=NOMID
  609. *
  610. NBTYPE=1
  611. SEGINI NOTYPE
  612. MOTYPE=NOTYPE
  613. TYPE(1)='REAL*8'
  614. *
  615. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  616. SEGSUP NOTYPE
  617. IF (IERR.NE.0) GOTO 9992
  618. IF (ISUP.EQ.1) THEN
  619. CALL VALCHE(IVAMAT,NMATR,IPMINT,IPPORE,MOMATR,MELE)
  620. ENDIF
  621. C
  622. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
  623. C
  624. NBROBL=0
  625. NBRFAC=0
  626. MOCARA=0
  627. IVECT=0
  628. *
  629. * EPAISSEUR DANS LE CAS DES CONTRAINTES PLANES
  630. *
  631. IF(IFOUR.EQ.-2.AND.((MELE.GE.79.AND.MELE.LE.83)
  632. & .OR.(MELE.GE.173.AND.MELE.LE.182)))THEN
  633. *
  634. NBROBL=0
  635. NBRFAC=1
  636. SEGINI NOMID
  637. MOCARA=NOMID
  638. LESFAC(1)='DIM3'
  639. *
  640. NBTYPE=1
  641. SEGINI NOTYPE
  642. TYPE(1)='REAL*8'
  643. ENDIF
  644. *
  645. NCARA=NBROBL
  646. NCARF=NBRFAC
  647. NCARR=NCARA+NCARF
  648. *
  649. IF (MOCARA.NE.0) THEN
  650. MOTYPE=NOTYPE
  651. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  652. $ IVACAR)
  653. SEGSUP NOTYPE
  654. IF (IERR.NE.0) GOTO 9992
  655. *
  656. IF (ISUP.EQ.1) THEN
  657. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  658. ENDIF
  659. ENDIF
  660. *
  661. *_____________________________________________________________________
  662. *
  663. * NUMERO DES ETIQUETTES :
  664. * ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  665. * DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  666. * 5 CONTINUE
  667. * ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  668. * 44 CONTINUE
  669. * ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  670. *_____________________________________________________________________
  671. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  672. 1 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  673. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  674. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,79,79,
  675. 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  676. 5 99,99,99,99,99,99,99,80,80,80),MELE
  677. *
  678. IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173
  679. IF(MELE.GE.185.AND.MELE.LE.190) GO TO 185
  680. *
  681. 99 CONTINUE
  682. SEGSUP xMATRI
  683. MOTERR(1:4)=NOMTP(MELE)
  684. MOTERR(5:12)='PERMEABI'
  685. CALL ERREUR(86)
  686. GOTO 9990
  687. *_______________________________________________________________________
  688. *
  689. * MILIEU POREUX
  690. *_______________________________________________________________________
  691. *
  692. 79 CONTINUE
  693. *
  694. * Pour ces elements NBBB : Nb de noeuds
  695. * NBNO : Nb de fonctions de forme
  696. *
  697. DIM3=1.D0
  698. NBNO=IPORE
  699. NBBB=NBNN
  700. NSTN=1
  701. LRN=NBNO-NBBB
  702. NSTB=2
  703. IF(IFOUR.GT.0) NSTB=3
  704. *
  705. * CAS NON ISOTROPES
  706. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  707. * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  708. *
  709. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  710. CALL RESHPT(1,NBNO,IELE,MELE,0,MINT,IRT1)
  711. MINTE2=MINT
  712. SEGACT MINTE2
  713. SEGINI WRK4
  714. ENDIF
  715. *
  716. SEGINI WRK1,WRK2,WRK3
  717. I195=0
  718. I259=0
  719. I367=0
  720. DO 3079 IB=1,NBELEM
  721. *
  722. * On cherche les coordonnees des noeuds de l'element IB
  723. *
  724. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  725. *
  726. * calcul des axes locaux dans les cas non isotropes
  727. *
  728. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  729. NBSH=MINTE2.SHPTOT(/2)
  730. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  731. if (nbsh.eq.-1) then
  732. call erreur(525)
  733. return
  734. endif
  735. ENDIF
  736. *
  737. CALL ZERO (REL,LRE,LRE)
  738. *
  739. * boucle sur les points de Gauss
  740. *
  741. ISDJC=0
  742. DO 4079 IGAU=1,NBPGAU
  743.  
  744. * PRINT *, ' POINT DE GAUSS ',IGAU
  745. C
  746. C RECUPERATION DE L'EPAISSEUR
  747. C
  748. IF (IFOUR.EQ.-2)THEN
  749. MPTVAL=IVACAR
  750. IF (IVACAR.NE.0) THEN
  751. MELVAL=IVAL(1)
  752. IF (MELVAL.NE.0) THEN
  753. IGMN=MIN(IGAU,VELCHE(/1))
  754. IBMN=MIN(IB,VELCHE(/2))
  755. DIM3=VELCHE(IGMN,IBMN)
  756. ELSE
  757. DIM3=1.D0
  758. ENDIF
  759. ENDIF
  760. ENDIF
  761. *
  762. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  763. & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,2)
  764. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  765. IF(DJAC.EQ.0.) I259 =IB
  766. DJAC=ABS(DJAC)*POIGAU(IGAU)
  767.  
  768. * PRINT *,' MATRICE B LIGNE PAR LIGNE '
  769. * DO 3367 IPZ = 1,NSTB
  770. ** PRINT *,' LIGNE ',IPZ
  771. * WRITE(6,3368) (BGENE(IPZ,JPZ), JPZ=1,LRE)
  772. *3368 FORMAT(8(1X,1PE10.3)/)
  773. *3367 CONTINUE
  774.  
  775. EREF=1.D0
  776. MPTVAL=IVAMAT
  777. *
  778. * le cas isotrope
  779. *
  780. IF (MATE.EQ.1) THEN
  781. MELVAL=IVAL(1)
  782. IGMN=MIN(IGAU,VELCHE(/1))
  783. IBMN=MIN(IB ,VELCHE(/2))
  784. XK =VELCHE(IGMN,IBMN)
  785. *
  786. MELVAL=IVAL(2)
  787. IGMN=MIN(IGAU,VELCHE(/1))
  788. IBMN=MIN(IB ,VELCHE(/2))
  789. XMU =VELCHE(IGMN,IBMN)
  790. IF(XMU.EQ.0.D0) THEN
  791. I367=IB
  792. GO TO 4079
  793. ENDIF
  794. COMJAC=DJAC*EREF*EREF*XK/XMU
  795. DO 4279 I=1,LRN
  796. DO 4279 J=1,I
  797. DO 4279 K=1,NSTB
  798. REL(I,J)=REL(I,J)+COMJAC*BGENE(K,I)*BGENE(K,J)
  799. 4279 CONTINUE
  800. *
  801. * les cas non isotropes
  802. *
  803. ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  804. *
  805. DO 4379 IM=1,NMATT
  806. IF (IVAL(IM).NE.0) THEN
  807. MELVAL=IVAL(IM)
  808. IBMN=MIN(IB ,VELCHE(/2))
  809. IGMN=MIN(IGAU,VELCHE(/1))
  810. VALMAT(IM)=VELCHE(IGMN,IBMN)
  811. ELSE
  812. VALMAT(IM)=0.D0
  813. ENDIF
  814. 4379 CONTINUE
  815. *
  816. CALL PERMAO(WRK4,IFOUR,MATE,EREF,KERRE)
  817. IF(KERRE.EQ.1) GO TO 99
  818. IF(KERRE.EQ.2) THEN
  819. I367=IB
  820. GO TO 4079
  821. ENDIF
  822. *
  823. CALL BDBST(BGENE,DJAC,PMAT,LRE,NSTB,REL)
  824. *
  825. * les cas non prevus
  826. *
  827. ELSE
  828. GO TO 99
  829. ENDIF
  830. *
  831. 4079 CONTINUE
  832. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  833. * SEGINI XMATRI
  834. * IMATTT(IB)=XMATRI
  835. *
  836. * Remplissage de XMATRI
  837. *
  838. CALL REMPMT(REL,LRE,RE(1,1,ib))
  839. * SEGDES XMATRI
  840. 3079 CONTINUE
  841. *
  842. SEGSUP WRK1,WRK2,WRK3
  843. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  844. SEGDES MINTE2
  845. SEGSUP WRK4
  846. ENDIF
  847. *
  848. IF(I195.NE.0) THEN
  849. INTERR(1)=I195
  850. CALL ERREUR(195)
  851. GOTO 9990
  852. ELSE IF(I259.NE.0) THEN
  853. INTERR(1)=I259
  854. CALL ERREUR(259)
  855. GOTO 9990
  856. ELSE IF(I367.NE.0) THEN
  857. INTERR(1)=I367
  858. CALL ERREUR(367)
  859. GOTO 9990
  860. ENDIF
  861. *
  862. SEGDES xMATRI
  863. *
  864. GOTO 610
  865. *_______________________________________________________________________
  866. *
  867. * JOINTS EN FORMULATION MILIEUX POREUX
  868. *_______________________________________________________________________
  869. *
  870. 80 CONTINUE
  871. *
  872. * Pour ces elements NBBB : Nb de noeuds
  873. * NBNO : Nb de fonctions de forme
  874. *
  875. NBNO=IPORE
  876. NBBB=NBNN
  877. NSTN=1
  878. LPP=(NBNO-NBBB)*3/2
  879. LRN=LPP
  880. NSTB=2
  881. IF(IFOUR.EQ.2) NSTB=3
  882.  
  883. * PRINT *,' NBNO=', NBNO
  884. * PRINT *,' NBBB=', NBBB
  885. * PRINT *,' NSTN=', NSTN
  886. * PRINT *,' LRN =', LRN
  887. * PRINT *,' LRE =', LRE
  888. * PRINT *,' NSTB =', NSTB
  889. *
  890. SEGINI WRK1,WRK2,WRK3,WRK5
  891. I195=0
  892. I259=0
  893. I367=0
  894. DO 3080 IB=1,NBELEM
  895. *
  896. * On cherche les coordonnees des noeuds de l'element IB
  897. *
  898. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  899. *
  900. * calcul des axes locaux
  901. *
  902. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  903. *
  904. CALL ZERO (REL,LRE,LRE)
  905. *
  906. CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  907. *
  908. * boucle sur les points de Gauss
  909. *
  910. ISDJC=0
  911. DO 4080 IGAU=1,NBPGAU
  912. *
  913. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,XE,XEL,
  914. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,3)
  915. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  916. IF(DJAC.EQ.0.) I259 =IB
  917. DJAC=ABS(DJAC)*POIGAU(IGAU)
  918. *
  919. EREF=1.D0
  920. MPTVAL=IVAMAT
  921. *
  922. * le cas isotrope (le seul)
  923. *
  924. MELVAL=IVAL(1)
  925. IGMN=MIN(IGAU,VELCHE(/1))
  926. IBMN=MIN(IB ,VELCHE(/2))
  927. XKT =VELCHE(IGMN,IBMN)
  928. *
  929. MELVAL=IVAL(2)
  930. IGMN=MIN(IGAU,VELCHE(/1))
  931. IBMN=MIN(IB ,VELCHE(/2))
  932. XKNH =VELCHE(IGMN,IBMN)
  933. *
  934. MELVAL=IVAL(3)
  935. IGMN=MIN(IGAU,VELCHE(/1))
  936. IBMN=MIN(IB ,VELCHE(/2))
  937. XKNB =VELCHE(IGMN,IBMN)
  938. *
  939. MELVAL=IVAL(4)
  940. IGMN=MIN(IGAU,VELCHE(/1))
  941. IBMN=MIN(IB ,VELCHE(/2))
  942. XMU =VELCHE(IGMN,IBMN)
  943. IF(XMU.EQ.0.D0) THEN
  944. I367=IB
  945. GO TO 4080
  946. ENDIF
  947. COMJAT=DJAC*EREF*EREF*XKT/XMU
  948. COMJNH=DJAC*EREF*EREF*XKNH/XMU
  949. COMJNB=DJAC*EREF*EREF*XKNB/XMU
  950. DO 4280 I=1,LRN
  951. DO 4280 J=1,I
  952. REL(I,J)=REL(I,J)+COMJAT*BGENE(1,I)*BGENE(1,J)
  953. . *XNTT(I)*XNTT(J)
  954. . +COMJNH*XGENE(1,I)*XGENE(1,J)*XNTH(I,J)
  955. . +COMJNB*XGENE(1,I)*XGENE(1,J)*XNTB(I,J)
  956. IF(IFOUR.EQ.2)THEN
  957. REL(I,J)=REL(I,J)+COMJAT*BGENE(2,I)*BGENE(2,J)
  958. . *XNTT(I)*XNTT(J)
  959. ENDIF
  960. 4280 CONTINUE
  961. *
  962. 4080 CONTINUE
  963. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  964. * SEGINI XMATRI
  965. * IMATTT(IB)=XMATRI
  966. *
  967. * Remplissage de XMATRI
  968. *
  969. CALL REMPMT(REL,LRE,RE(1,1,ib))
  970. * SEGDES XMATRI
  971. 3080 CONTINUE
  972. *
  973. SEGSUP WRK1,WRK2,WRK3,WRK5
  974. *
  975. IF(I195.NE.0) THEN
  976. INTERR(1)=I195
  977. CALL ERREUR(195)
  978. GOTO 9990
  979. ELSE IF(I259.NE.0) THEN
  980. INTERR(1)=I259
  981. CALL ERREUR(259)
  982. GOTO 9990
  983. ELSE IF(I367.NE.0) THEN
  984. INTERR(1)=I367
  985. CALL ERREUR(367)
  986. GOTO 9990
  987. ENDIF
  988. *
  989. SEGDES xMATRI
  990. *
  991. GOTO 610
  992. *_______________________________________________________________________
  993. *
  994. * MILIEU POREUX - SUITE
  995. *_______________________________________________________________________
  996. *
  997. 173 CONTINUE
  998. *
  999. * Pour ces elements NBBB : Nb de noeuds
  1000. * NBNO : Nb de fonctions de forme
  1001. *
  1002. DIM3=1.D0
  1003. NBNO=IPORE
  1004. NBBB=NBNN
  1005. NSTN=IDECAP
  1006. LPP=NBNO-NBBB
  1007. LRN=IDECAP*LPP
  1008. NSTBE=2
  1009. IF(IFOUR.GT.0) NSTBE=3
  1010. NSTB=NSTBE*IDECAP
  1011.  
  1012. * PRINT *,'NSTBE=',NSTBE
  1013. * PRINT *,'NSTB=',NSTB
  1014. * PRINT *,'IDECAP=',IDECAP
  1015. * PRINT *,'LRE =',LRE
  1016.  
  1017. *
  1018. * CAS NON ISOTROPES
  1019. * NON PREVU
  1020. *
  1021. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  1022. CALL ERREUR(251)
  1023. GO TO 9990
  1024. ENDIF
  1025. *
  1026. NSTPK= NSTB
  1027. SEGINI WRK1,WRK2,WRK3,WRK6
  1028. I195=0
  1029. I259=0
  1030. I367=0
  1031. DO 3173 IB=1,NBELEM
  1032.  
  1033. * PRINT *,'ELEMENT ' , IB
  1034. *
  1035. * On cherche les coordonnees des noeuds de l'element IB
  1036. *
  1037. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1038. *
  1039. CALL ZERO (REL,LRE,LRE)
  1040. *
  1041. * boucle sur les points de Gauss
  1042. *
  1043. ISDJC=0
  1044. DO 4173 IGAU=1,NBPGAU
  1045.  
  1046. * PRINT *, ' POINT DE GAUSS ',IGAU
  1047.  
  1048.  
  1049. C
  1050. C RECUPERATION DE L'EPAISSEUR
  1051. C
  1052. IF (IFOUR.EQ.-2)THEN
  1053. MPTVAL=IVACAR
  1054. IF (IVACAR.NE.0) THEN
  1055. MELVAL=IVAL(1)
  1056. IF (MELVAL.NE.0) THEN
  1057. IGMN=MIN(IGAU,VELCHE(/1))
  1058. IBMN=MIN(IB,VELCHE(/2))
  1059. DIM3=VELCHE(IGMN,IBMN)
  1060. ELSE
  1061. DIM3=1.D0
  1062. ENDIF
  1063. ENDIF
  1064. ENDIF
  1065. *
  1066. LHOO=NSTB
  1067. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  1068. & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOO,2)
  1069. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1070. IF(DJAC.EQ.0.) I259 =IB
  1071. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1072.  
  1073. * PRINT *,' MATRICE B LIGNE PAR LIGNE '
  1074. * DO 1367 IPZ = 1,NSTB
  1075. * PRINT *,' LIGNE ',IPZ
  1076. * WRITE(6,1368) (BGENE(IPZ,JPZ), JPZ=1,LRE)
  1077. *1368 FORMAT(8(1X,1PE10.3)/)
  1078. *1367 CONTINUE
  1079.  
  1080. *
  1081. EREF=1.D0
  1082. MPTVAL=IVAMAT
  1083. *
  1084. * le cas isotrope
  1085. *
  1086. IF (MATE.EQ.1) THEN
  1087.  
  1088. ICO=1
  1089. DO 1731 ICD = 1,IDECAP
  1090. ICDA =(ICD -1) * NSTBE
  1091. DO 1732 JCD = 1,IDECAP
  1092. JCDA =(JCD -1) * NSTBE
  1093. MELVAL=IVAL(ICO)
  1094. IGMN=MIN(IGAU,VELCHE(/1))
  1095. IBMN=MIN(IB ,VELCHE(/2))
  1096. DO 1733 KCD = 1,NSTBE
  1097. PKK(ICDA+KCD,JCDA+KCD) =VELCHE(IGMN,IBMN)
  1098. 1733 CONTINUE
  1099. ICO=ICO+1
  1100. 1732 CONTINUE
  1101. 1731 CONTINUE
  1102. *
  1103.  
  1104. * PRINT *,' MATRICE PKK'
  1105. * IF (IDECAP.EQ.2) THEN
  1106. * WRITE (6,1342) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  1107. *1342 FORMAT(4(1X,1PE12.5)/)
  1108. *
  1109. * ELSE IF (IDECAP.EQ.3) THEN
  1110. * WRITE (6,1343) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  1111. *1343 FORMAT(6(1X,1PE12.5)/)
  1112. * ENDIF
  1113.  
  1114. COMJAC=DJAC*EREF*EREF
  1115. CALL BDBSTS(BGENE,COMJAC,PKK,LRE,NSTB,REL)
  1116. *
  1117. * les cas non prevus
  1118. *
  1119. ELSE
  1120. GO TO 99
  1121. ENDIF
  1122. *
  1123. 4173 CONTINUE
  1124. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1125. * SEGINI XMATRI
  1126. * IMATTT(IB)=XMATRI
  1127. *
  1128. * Remplissage de XMATRI
  1129. *
  1130. CALL REMPMS(REL,LRE,RE(1,1,ib))
  1131. * SEGDES XMATRI
  1132. 3173 CONTINUE
  1133. *
  1134. SEGSUP WRK1,WRK2,WRK3,WRK6
  1135. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  1136. SEGDES MINTE2
  1137. SEGSUP WRK4
  1138. ENDIF
  1139. *
  1140. IF(I195.NE.0) THEN
  1141. INTERR(1)=I195
  1142. CALL ERREUR(195)
  1143. GOTO 9990
  1144. ELSE IF(I259.NE.0) THEN
  1145. INTERR(1)=I259
  1146. CALL ERREUR(259)
  1147. GOTO 9990
  1148. ELSE IF(I367.NE.0) THEN
  1149. INTERR(1)=I367
  1150. CALL ERREUR(367)
  1151. GOTO 9990
  1152. ENDIF
  1153. *
  1154. SEGDES xMATRI
  1155. *
  1156. GOTO 610
  1157. *_______________________________________________________________________
  1158. *
  1159. * JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  1160. *_______________________________________________________________________
  1161. *
  1162. 185 CONTINUE
  1163. *
  1164. * Pour ces elements NBBB : Nb de noeuds
  1165. * NBNO : Nb de fonctions de forme
  1166. *
  1167. NBNO=IPORE
  1168. NBBB=NBNN
  1169. NSTN=IDECAP
  1170. LPP=(NBNO-NBBB)*3/2
  1171. LRN=IDECAP*LPP
  1172. NSTBE=2
  1173. IF(IFOUR.EQ.2) NSTBE=3
  1174. NSTB=NSTBE*IDECAP
  1175. NSTPKE=3
  1176. NSTPK=NSTPKE*IDECAP
  1177.  
  1178. * PRINT *,' NBNO=', NBNO
  1179. * PRINT *,' NBBB=', NBBB
  1180. * PRINT *,' NSTN=', NSTN
  1181. * PRINT *,' LPP =', LPP
  1182. * PRINT *,' LRN =', LRN
  1183. * PRINT *,' LRE =', LRE
  1184. * PRINT *,' NSTBE=', NSTBE
  1185. * PRINT *,' NSTB =', NSTB
  1186. * PRINT *,' NSTPKE =', NSTPKE
  1187. * PRINT *,' NSTPK =', NSTPK
  1188. *
  1189. SEGINI WRK1,WRK2,WRK3,WRK5,WRK6
  1190. I195=0
  1191. I259=0
  1192. I367=0
  1193. DO 3185 IB=1,NBELEM
  1194. *
  1195. * On cherche les coordonnees des noeuds de l'element IB
  1196. *
  1197. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1198. *
  1199. * calcul des axes locaux
  1200. *
  1201. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1202. *
  1203. CALL ZERO (REL,LRE,LRE)
  1204. *
  1205. CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1206. *
  1207. * boucle sur les points de Gauss
  1208. *
  1209. ISDJC=0
  1210. DO 4185 IGAU=1,NBPGAU
  1211. *
  1212. LHOO=NSTB
  1213. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOO,NSTN,XE,XEL,
  1214. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,3)
  1215. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1216. IF(DJAC.EQ.0.) I259 =IB
  1217. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1218. *
  1219. EREF=1.D0
  1220. MPTVAL=IVAMAT
  1221. *
  1222. * le cas isotrope (le seul)
  1223. *
  1224. IF(MATE.EQ.1) THEN
  1225.  
  1226. FAC = DJAC*EREF*EREF
  1227. IE=0
  1228. DO 2185 IPR=1,IDECAP
  1229. IPR1 = (IPR-1) * NSTPKE
  1230. DO 2185 JPR=1,IDECAP
  1231. JPR1 = (JPR-1) * NSTPKE
  1232. DO 2186 I=1,NSTPKE
  1233. II = I + IPR1
  1234. JJ = I + JPR1
  1235. IE=IE+1
  1236. MELVAL=IVAL(IE)
  1237. IGMN=MIN(IGAU,VELCHE(/1))
  1238. IBMN=MIN(IB ,VELCHE(/2))
  1239. PKK(II,JJ)=VELCHE(IGMN,IBMN)*FAC
  1240. 2186 CONTINUE
  1241. 2185 CONTINUE
  1242.  
  1243. *
  1244. DO 8985 IPR=1,IDECAP
  1245. IPR1 = (IPR-1)*NSTPKE
  1246. IPR2 = 2*IPR
  1247. IPPDEC=(IPR-1)*LPP
  1248. IRRDEC=(IPR-1)*NBBB
  1249. DO 8985 JPR=1,IDECAP
  1250. JPR1 = (JPR-1)*NSTPKE
  1251. JPR2 = 2*JPR
  1252. JPPDEC=(JPR-1)*LPP
  1253. JRRDEC=(JPR-1)*NBBB
  1254. *
  1255. COMJAT=PKK(IPR1+1,JPR1+1)
  1256. COMJNH=PKK(IPR1+2,JPR1+2)
  1257. COMJNB=PKK(IPR1+3,JPR1+3)
  1258. *
  1259. IF(IFOUR.LE.0) THEN
  1260. DO 4285 I=1,LPP
  1261. II =I+IPPDEC
  1262. IR =I+IRRDEC
  1263. DO 4285 J=1,LPP
  1264. JJ =J+JPPDEC
  1265. JR =J+JRRDEC
  1266. REL(IR,JR)=REL(IR,JR)
  1267. . +COMJAT*BGENE(IPR,II)*BGENE(JPR,JJ)
  1268. . *XNTT(I)*XNTT(J)
  1269. . +COMJNH*XGENE(IPR,II)*XGENE(JPR,JJ)*XNTH(I,J)
  1270. . +COMJNB*XGENE(IPR,II)*XGENE(JPR,JJ)*XNTB(I,J)
  1271. 4285 CONTINUE
  1272. *
  1273. ELSE
  1274. DO 4385 I=1,LPP
  1275. II =I+IPPDEC
  1276. DO 4385 J=1,LPP
  1277. JJ =J+JPPDEC
  1278. REL(IR,JR)=REL(IR,JR)
  1279. . +COMJAT*XNTT(I)*XNTT(J)*
  1280. . (BGENE(IPR2-1,II)*BGENE(JPR2-1,JJ)
  1281. . + BGENE(IPR2,II)*BGENE(JPR2,JJ))
  1282. . +COMJNH*XGENE(IPR,II)*XGENE(JPR,JJ)*XNTH(I,J)
  1283. . +COMJNB*XGENE(IPR,II)*XGENE(JPR,JJ)*XNTB(I,J)
  1284. 4385 CONTINUE
  1285. ENDIF
  1286.  
  1287. 8985 CONTINUE
  1288. *
  1289. ELSE
  1290. GO TO 9990
  1291. ENDIF
  1292.  
  1293. *
  1294. 4185 CONTINUE
  1295. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1296. * SEGINI XMATRI
  1297. * IMATTT(IB)=XMATRI
  1298. *
  1299. * Remplissage de XMATRI
  1300. *
  1301. CALL REMPMS(REL,LRE,RE(1,1,ib))
  1302. * SEGDES XMATRI
  1303. 3185 CONTINUE
  1304. *
  1305. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK6
  1306. *
  1307. IF(I195.NE.0) THEN
  1308. INTERR(1)=I195
  1309. CALL ERREUR(195)
  1310. GOTO 9990
  1311. ELSE IF(I259.NE.0) THEN
  1312. INTERR(1)=I259
  1313. CALL ERREUR(259)
  1314. GOTO 9990
  1315. ELSE IF(I367.NE.0) THEN
  1316. INTERR(1)=I367
  1317. CALL ERREUR(367)
  1318. GOTO 9990
  1319. ENDIF
  1320. *
  1321. SEGDES xMATRI
  1322. *
  1323. GOTO 610
  1324. *
  1325. * Desactivation des segment propres a la geometrie ISOUS
  1326. *
  1327. 610 CONTINUE
  1328. *
  1329. SEGDES MELEME
  1330. SEGDES MINTE
  1331. *
  1332. IF (ISUP.EQ.1) THEN
  1333. CALL DTMVAL(IVAMAT,3)
  1334. ELSE
  1335. CALL DTMVAL(IVAMAT,1)
  1336. ENDIF
  1337. *
  1338. NOMID=MOMATR
  1339. SEGSUP NOMID
  1340. IF (lsupdp) THEN
  1341. NOMID=MODEPL
  1342. SEGSUP,NOMID
  1343. ENDIF
  1344. IF (lsupfo) THEN
  1345. NOMID=MOFORC
  1346. SEGSUP,NOMID
  1347. ENDIF
  1348. *
  1349. COERIG(ISORI) = 1.D0
  1350. IRIGEL(1,ISORI)=IPMAIL
  1351. IRIGEL(2,ISORI)=0
  1352. IRIGEL(3,ISORI)=IPDES
  1353. IRIGEL(4,ISORI)=xMATRI
  1354. IRIGEL(5,ISORI)=NHRM
  1355. IRIGEL(6,ISORI)=0
  1356. IRIGEL(7,ISORI)=LASYM
  1357. IRIGEL(8,ISORI)=0
  1358.  
  1359.  
  1360. * Fin de la boucle de PARTITIONNEMENT du segment XMATRI
  1361. 5000 CONTINUE
  1362.  
  1363. SEGDES IMODEL
  1364.  
  1365. 500 CONTINUE
  1366. IF(ISORI.NE.NRIGEL) GO TO 9999
  1367. SEGDES MRIGID
  1368. C SEGSUP MMODEL
  1369. IRET = 1
  1370. IPRIGI = MRIGID
  1371. RETURN
  1372. *
  1373. * Erreur dans une sous zone desactivation et retour
  1374. *
  1375. 9990 CONTINUE
  1376. IF (ISUP.EQ.1) THEN
  1377. CALL DTMVAL(IVAMAT,3)
  1378. ELSE
  1379. CALL DTMVAL(IVAMAT,1)
  1380. ENDIF
  1381. *
  1382. 9992 CONTINUE
  1383.  
  1384. SEGSUP DESCR
  1385. SEGSUP xMATRI
  1386. SEGDES MELEME
  1387. SEGDES MINTE
  1388. *
  1389. NOMID=MOMATR
  1390. SEGSUP NOMID
  1391. 9999 CONTINUE
  1392. SEGSUP MRIGID
  1393. IRET = 0
  1394. IPRIGI = 0
  1395.  
  1396. 9991 CONTINUE
  1397.  
  1398. MMODEL = IPMODL
  1399. DO isous = 1, NSOUS
  1400. IMODEL = KMODEL(isous)
  1401. SEGDES,IMODEL
  1402. ENDDO
  1403. C SEGSUP,MMODEL
  1404.  
  1405. RETURN
  1406. END
  1407.  
  1408.  
  1409.  
  1410.  
  1411.  
  1412.  
  1413.  
  1414.  
  1415.  
  1416.  
  1417.  
  1418.  
  1419.  
  1420.  
  1421.  
  1422.  

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