Télécharger piocap.eso

Retour à la liste

Numérotation des lignes :

  1. C PIOCAP SOURCE PV 17/10/03 21:16:24 9581
  2. SUBROUTINE PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,
  3. & IM,IPCHE2,IRET)
  4. C_______________________________________________________________________
  5. C
  6. C
  7. C Entr{es:
  8. C ________
  9. C
  10. C IPMODL Pointeur sur un MMODEL
  11. C IPCHE1 Pointeur sur un MCHAML de contraintes de KIRCHHOFF
  12. C OU DE DEFORMATIONS
  13. C IPCHP1 Pointeur sur le CHAMPOINT d{placements entre
  14. C configuration de depart et arrivee
  15. C IM Flag ,= 0 KIRCHHOFF------> CAUCHY
  16. C = 1 CAUCHY-------> KIRCHHOFF
  17. C attention si derivee de jauman on fait RTENS RART avec R matrice
  18. C de rotation
  19. C Sorties:
  20. C ________
  21. C
  22. C IPCHE2 Pointeur sur un MCHAML de CONTRAINTES
  23. C OU DE DEFORMATIONS
  24. C IRET 1 ou 0 suivant succes ou pas
  25. C
  26. C
  27. C PASSAGE AUX NOUVEAUX CHAMELEMS PAR P.DOWLATYARI LE 12/4/91
  28. C_______________________________________________________________________
  29. C
  30. IMPLICIT INTEGER(I-N)
  31. IMPLICIT REAL*8(A-H,O-Z)
  32. *
  33. -INC CCOPTIO
  34. -INC CCHAMP
  35. -INC SMCHAML
  36. -INC SMCHPOI
  37. -INC SMELEME
  38. -INC SMCOORD
  39. -INC SMMODEL
  40. -INC SMINTE
  41. -INC SMLREEL
  42. C
  43. SEGMENT MWRK1
  44. REAL*8 XE(3,NBNN) ,XE1(3,NBNN) ,XE2(3,NBNN)
  45. ENDSEGMENT
  46. *
  47. SEGMENT MWRK2
  48. REAL*8 SHPWRK(6,NBNN)
  49. ENDSEGMENT
  50. *
  51. SEGMENT MWRK3
  52. REAL*8 STRESS(NBPTEL,NSTRS),STRES1(NBPTEL,NSTRS)
  53. ENDSEGMENT
  54. *
  55. SEGMENT MWRK4
  56. REAL*8 XEL(3,3), BPSS (3,3), XDDL(18), XDDLOC(18)
  57. ENDSEGMENT
  58. *
  59. SEGMENT MWRK5
  60. REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
  61. REAL*8 TENS(9),tentra(9),xddls2(lre)
  62. ENDSEGMENT
  63. *
  64. SEGMENT NOTYPE
  65. CHARACTER*16 TYPE(NBTYPE)
  66. ENDSEGMENT
  67. *
  68. SEGMENT MPTVAL
  69. INTEGER IPOS(NS) ,NSOF(NS)
  70. INTEGER IVAL(NCOSOU)
  71. CHARACTER*16 TYVAL(NCOSOU)
  72. ENDSEGMENT
  73. *
  74. *as xfem 2010_01_13
  75. SEGMENT MRACC
  76. INTEGER TLREEL(NBNN)
  77. ENDSEGMENT
  78.  
  79. SEGMENT TABA
  80. REAL*8 TABA1(IDIM,NBNN),TABA2(IDIM,NBNN)
  81. ENDSEGMENT
  82. *fin as xfem 2010_01_13
  83.  
  84. CHARACTER*(NCONCH) CONM
  85. PARAMETER ( NINF=3 )
  86. INTEGER INFOS(NINF)
  87. *as xfem 2010_01_22
  88. DIMENSION UDPGE(3)
  89. LOGICAL ldpge,lsupdp,lsupno,lsupdp0
  90. C
  91. NHRM=NIFOUR
  92. IRET=0
  93. IMESS=0
  94. *
  95. * Verification du lieu support du MCHAML
  96. *
  97. call reduaf(ipche1,ipmodl,ipch,0,iretou,kerr)
  98. if (iretou.ne.1) call erreur(kerr)
  99. if (ierr.ne.0) return
  100. ipche1=ipch
  101. CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP,IRET2)
  102. IF (ISUP.GT.1) RETURN
  103. c
  104. *as xfem 2010_01_13
  105. * Calcul du niveau d'enrichissement du modèle :
  106. IF (ichax1.ne.0) then
  107. ipchp2=0
  108. MCHAM1=ICHAX1
  109. SEGACT MCHAM1
  110. nbenr1=MCHAM1.IELVAL(/1)
  111. if (nbenr1.gt.1) then
  112. SEGDES,MCHAM1
  113. write(ioimp,*) 'XFEM : on ne sait pas traiter les grandes ',
  114. & 'transformations avec un niveau denrichissement >1'
  115. CALL ERREUR(21)
  116. return
  117. endif
  118. * Calcul des déplacements vrais :
  119. call XPOST1(IPCHP1,IPMODL,IPCHP2)
  120. ENDIF
  121. *fin as xfem 2010_01_13
  122. *
  123. * CONTRAINTES (KCAS=1) OU DEFORMATIONS (KCAS=2) ?
  124. *
  125. MCHELM=IPCHE1
  126. SEGACT MCHELM
  127. IF (TITCHE.EQ.'CONTRAINTES') THEN
  128. KCAS=1
  129. ELSE IF(TITCHE.EQ.'DEFORMATIONS') THEN
  130. KCAS=2
  131. ELSE
  132. MOTERR(1:8)='CONTRAIN'
  133. MOTERR(9:16)='DEFORMAT'
  134. CALL ERREUR(109)
  135. SEGDES MCHELM
  136. RETURN
  137. ENDIF
  138. SEGDES MCHELM
  139. C
  140. C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT
  141. C____________________________________________________________________
  142. C
  143. CALL CHAME1(0,IPMODL,IPCHP1,' ',IPCHE3,1)
  144. *as xfem 2010_01_13
  145. if(ichax1.ne.0) then
  146. * IPCHP1 : Deplacement enrichi : config initiale -> config finale
  147. * Deplacement enrichi : config de reference -> config finale
  148. CALL CHAME1(0,IPMODL,IPCHP0,' ',IPCHE0,1)
  149. * Deplacement vrai : config initiale -> config finale
  150. CALL CHAME1(0,IPMODL,IPCHP2,' ',IPCHE4,1)
  151. endif
  152. *fin as xfem 2010_01_13
  153. C
  154. C ACTIVATION DU MODELE
  155. C
  156. MMODEL=IPMODL
  157. SEGACT MMODEL
  158. NSOUS=KMODEL(/1)
  159. N1=NSOUS
  160. C
  161. C ON NE TIENT PAS COMPTE D'UN EVENTUEL MODELE CHARGEMENT
  162. C
  163. DO III = 1,NSOUS
  164. IMODEL = KMODEL(III)
  165. SEGACT IMODEL
  166. IF (FORMOD(1).EQ.'CHARGEMENT') N1=N1-1
  167. SEGDES IMODEL
  168. END DO
  169. C
  170. C CREATION DU MCHELM
  171. C
  172. IF (KCAS.EQ.1) L1=11
  173. IF (KCAS.EQ.2) L1=12
  174. N3=6
  175. SEGINI MCHELM
  176. IF(KCAS.EQ.1) TITCHE='CONTRAINTES'
  177. IF(KCAS.EQ.2) TITCHE='DEFORMATIONS'
  178. IFOCHE=IFOUR
  179. IPCHE2=MCHELM
  180. C____________________________________________________________________
  181. C
  182. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  183. C____________________________________________________________________
  184. C
  185. ISOUS=0
  186. DO 500 ISOU=1,NSOUS
  187. C
  188. C INITIALISATION
  189. C
  190. MWRK1=0
  191. MWRK2=0
  192. MWRK3=0
  193. MWRK4=0
  194. IVADEP=0
  195. NDEP=0
  196. IVAST1=0
  197. IVASTR=0
  198. NSTR=0
  199. MODEPV=0
  200. MODEPL=0
  201. MOSTRS=0
  202. C
  203. C ON RECUPERE L INFORMATION GENERALE
  204. C
  205. IMODEL=KMODEL(ISOU)
  206. SEGACT IMODEL
  207. IF (FORMOD(1).EQ.'CHARGEMENT') GOTO 500
  208. IPMAIL = imodel.IMAMOD
  209. CONM = imodel.CONMOD
  210. IIPDPG = imodel.IPDPGE
  211. IIPDPG = IPTPOI(IIPDPG)
  212. C
  213. C TRAITEMENT DU MODELE
  214. C
  215. C On n'utilise pas PICA avec un des modeles interdits (OTTOSEN, UO2) ou
  216. C le modele utilisateur UMAT (cas contrainte deja de Cauchy)
  217. C Cette partie de l'operateur est a ameliorer (juste copie du CHAMP !!!)
  218. IPICA = 1
  219. IF ( INATUU.EQ.108 .OR. INATUU.EQ.42 .OR. INATUU.EQ.-1 ) THEN
  220. IPICA = 0
  221. ENDIF
  222.  
  223. MELE=NEFMOD
  224. MELEME=IMAMOD
  225. ideri=ideriv
  226. C____________________________________________________________________
  227. C
  228. C INFORMATION SUR L'ELEMENT FINI
  229. C____________________________________________________________________
  230. C
  231. * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  232. * IF (IERR.NE.0) THEN
  233. * SEGDES IMODEL,MMODEL
  234. * SEGSUP MCHELM
  235. * CALL DTCHAM(IPCHE3)
  236. * RETURN
  237. * ENDIF
  238. * INFO=IPINF
  239. MFR =INFELE(13)
  240. IPORE=INFELE(8)
  241. NBG =INFELE(6)
  242. NBGS =INFELE(4)
  243. NSTRS=INFELE(16)
  244. LRE =INFELE(9)
  245. LW =INFELE(7)
  246. LHOOK=INFELE(10)
  247. LHOO2=LHOOK*LHOOK
  248. NDDL =INFELE(15)
  249. * MINTE=INFELE(11)
  250. if (infmod(/1).lt.7) goto 500
  251. minte=infmod(7)
  252. if (minte.eq.0) goto 500
  253. IPMINT=MINTE
  254. MINTE1=INFMOD(8)
  255. ISOUS=ISOUS+1
  256. IMACHE(ISOUS)=IPMAIL
  257. CONCHE(ISOUS)=CONMOD
  258. * SEGSUP INFO
  259. C
  260. C CREATION DU TABLEAU INFOS
  261. C
  262. INFOS(1)=0
  263. INFOS(2)=0
  264. INFOS(3)=NIFOUR
  265. C
  266. INFCHE(ISOUS,1)=0
  267. INFCHE(ISOUS,2)=0
  268. INFCHE(ISOUS,3)=NHRM
  269. INFCHE(ISOUS,4)=MINTE
  270. INFCHE(ISOUS,5)=0
  271. INFCHE(ISOUS,6)=5
  272. C
  273. C INITIALISATION DE MINTE
  274. C
  275. SEGACT MINTE
  276. NBPGAU=POIGAU(/1)
  277. C
  278. C Cas des modes de calculs en DEFORMATIONS GENERALISEES
  279. CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  280. C
  281. C ACTIVATION DU MELEME
  282. C
  283. SEGACT MELEME
  284. NBNN =NUM(/1)
  285. NBELEM=NUM(/2)
  286. *as xfem 2010_01_13
  287. if (MFR.eq.63) then
  288. NBSH=INFELE(8)
  289. else
  290. NBSH=NBNN
  291. endif
  292. *fin as xfem 2010_01_13
  293. IPPORE=0
  294. IF(MFR.EQ.33) IPPORE=NBNN
  295. C____________________________________________________________________
  296. C
  297. C RECHERCHE DES NOMS DE COMPOSANTES
  298. C____________________________________________________________________
  299. C
  300. lsupno=.false.
  301. IF(KCAS.EQ.1) THEN
  302. if(lnomid(4).ne.0) then
  303. nomid=lnomid(4)
  304. segact nomid
  305. mostrs=nomid
  306. nstr=lesobl(/2)
  307. nfac=lesfac(/2)
  308. else
  309. lsupno=.true.
  310. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  311. endif
  312. ENDIF
  313. IF(KCAS.EQ.2) THEN
  314. if(lnomid(5).ne.0) then
  315. nomid=lnomid(5)
  316. segact nomid
  317. nstr=lesobl(/2)
  318. mostrs=nomid
  319. nfac=lesfac(/2)
  320. else
  321. lsupno=.true.
  322. CALL IDDEFO(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  323. endif
  324. ENDIF
  325. C
  326. if(lnomid(1).ne.0) then
  327. nomid=lnomid(1)
  328. segact nomid
  329. modepl=nomid
  330. ndep=lesobl(/2)
  331. nfac=lesfac(/2)
  332. lsupdp=.false.
  333. else
  334. lsupdp=.true.
  335. CALL IDPRIM(IMODEL,0,MODEPL,NDEP,NFAC)
  336. endif
  337.  
  338. if (ideri.eq.4) then
  339. IF (LNOMID(3).NE.0) then
  340. MOGRAD=LNOMID(3)
  341. NOMID=MOGRAD
  342. SEGACT,NOMID
  343. NGRA=LESOBL(/2)
  344. segdes,nomid
  345. ELSE
  346. CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,NFAC)
  347. ENDIF
  348. LADIM=0
  349. IF (NGRA.EQ.4) LADIM=2
  350. IF (NGRA.EQ.9) LADIM=3
  351. IF (LADIM.EQ.0) THEN
  352. CALL ERREUR(26)
  353. RETURN
  354. ENDIF
  355. endif
  356.  
  357. *as xfem 2010_01_13
  358. * On récupère les noms des composantes du cas massif, pour les depl. vrais
  359. lsupdp0=.false.
  360. IF (ichax1.ne.0) then
  361. MFRTMP=1
  362. call idprim(IMODEL,MFRTMP,MODEPV,NDEPV,NFACV)
  363. * as 2010_01_22
  364. lsupdp0=.true.
  365. ENDIF
  366. *fin as xfem 2010_01_13
  367.  
  368. C Recherche des DDL du noeud support des def. planes generalisees
  369. IF (ldpge) THEN
  370. IF (IIPDPG.LE.0) THEN
  371. CALL ERREUR(925)
  372. ELSE
  373. CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  374. ENDIF
  375. IF (IERR.NE.0) RETURN
  376. ENDIF
  377. C____________________________________________________________________
  378. C
  379. C VERIFICATION DE LEUR PRESENCE
  380. C____________________________________________________________________
  381. C
  382. NBTYPE=1
  383. SEGINI NOTYPE
  384. MOTYPE=NOTYPE
  385. TYPE(1)='REAL*8'
  386. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
  387. *as xfem 2010_01_13
  388. if (ichax1.ne.0) then
  389. call KOMCHA(IPCHE0,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP0)
  390. call KOMCHA(IPCHE4,IPMAIL,CONM,MODEPV,MOTYPE,1,INFOS,3,IVADEPV)
  391. endif
  392. *fin as xfem 2010_01_13
  393. IF (IERR.NE.0)THEN
  394. SEGSUP NOTYPE
  395. GOTO 9990
  396. ENDIF
  397. C*Z MPTVAL=IVADEP
  398. C*Z NDDD=IVAL(/1)
  399. C*Z IF (ldpge) NDDD=NDEP-ndpge
  400. C
  401. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVAST1)
  402. SEGSUP NOTYPE
  403. IF (IERR.NE.0) GOTO 9990
  404. IF (ISUP.EQ.1) THEN
  405. CALL VALCHE(IVAST1,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  406. ENDIF
  407. C
  408. C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  409. C
  410. N1PTEL=NBGS
  411. N1EL=NBELEM
  412. NBPTEL=N1PTEL
  413. NEL=N1EL
  414. C
  415. C CREATION DU MCHAML DE LA SOUS ZONE
  416. C
  417. N2=NSTRS
  418. SEGINI MCHAML
  419. ICHAML(ISOUS)=MCHAML
  420. NS=1
  421. NCOSOU=NSTRS
  422. SEGINI MPTVAL
  423. IVASTR=MPTVAL
  424. NOMID=MOSTRS
  425. SEGACT NOMID
  426. DO 100 ICOMP=1,NSTRS
  427. NOMCHE(ICOMP)=LESOBL(ICOMP)
  428. TYPCHE(ICOMP)='REAL*8'
  429. N2PTEL=0
  430. N2EL=0
  431. SEGINI MELVAL
  432. IELVAL(ICOMP)=MELVAL
  433. IVAL(ICOMP)=MELVAL
  434. 100 CONTINUE
  435. SEGDES NOMID
  436. C
  437. *as xfem 2010_01_13
  438. IF(MFR.EQ.1.or.MFR.EQ.63)THEN
  439. SEGINI,MWRK1,MWRK2
  440. ELSE IF(MFR.EQ.3)THEN
  441. SEGINI,MWRK1,MWRK2,MWRK4
  442. ENDIF
  443. SEGINI,MWRK3
  444. C
  445. C ---------------------------------------------------
  446. C TRANSFORMATION DES TENSEURS SI ELEMENTS MASSIFS sauf shb8
  447. C ---------------------------------------------------
  448. IF((MFR.EQ.1.or.MFR.EQ.63).and.mele.ne.260)THEN
  449.  
  450. *as xfem 2010_01_13
  451. IF(MFR.EQ.63) then
  452. SEGINI,MRACC
  453. SEGINI,TABA
  454. SEGACT,MCHAM1
  455. ENDIF
  456. *fin as xfem 2010_01_13
  457. if(ideri.eq.4) then
  458. segini mwrk5
  459. endif
  460.  
  461. C* Mode en DEFO.GENE (DEBUT)
  462. IF (ldpge) THEN
  463. c* revoir le signe pour IM = 1 (CAPI) ????
  464. rsig = 1.D0 - 2.D0*IM
  465. IF (IDIM.EQ.2) THEN
  466. C* equivalent a IF (IFOUR.EQ.-3) THEN
  467. XE2(3,1) = rsig * UDPGE(1)
  468. c* Finir avec les rotations RX et RY ?
  469. ELSE
  470. C* ELSE IF (IDIM.EQ.1) THEN
  471. IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.14) THEN
  472. XE2(2,1) = rsig * UDPGE(1)
  473. ELSE IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10) THEN
  474. XE2(3,1) = rsig * UDPGE(1)
  475. ELSE
  476. c* ELSE IF (IFOUR.EQ.11) THEN
  477. XE2(2,1) = rsig * UDPGE(1)
  478. XE2(3,1) = rsig * UDPGE(2)
  479. ENDIF
  480. ENDIF
  481. ENDIF
  482. C* Mode en DEFO.GENE (FIN)
  483. C
  484. C BOUCLE SUR LES ELEMENTS
  485. C
  486. DO 200 IB=1,NBELEM
  487.  
  488. *as xfem 2010_01_13
  489. * Cacul du niveau d'enrichissement de l'élément :
  490. nbenrj=0
  491. if (ichax1.ne.0) then
  492. if (nbenr1.ne.0) then
  493. MELVA1=MCHAM1.IELVAL(1)
  494. SEGACT MELVA1
  495. do i=1,NBNN
  496. mlree1=MELVA1.IELCHE(I,IB)
  497. tlreel(i)=mlree1
  498. if (mlree1.ne.0) then
  499. nbenrj=max(nbenrj,1)
  500. segact,mlree1
  501. endif
  502. enddo
  503. segdes MELVA1
  504. endif
  505. endif
  506. *fin as xfem 2010_01_13
  507.  
  508. C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  509. C
  510. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  511. C
  512. IF(IM.EQ.0)THEN
  513. DO 220 INO=1,NBNN
  514. DO 220 ID=1,IDIM
  515. XE1(ID,INO)=XE(ID,INO)
  516. 220 CONTINUE
  517. C
  518. *as xfem 2010_01_13
  519. if (nbenrj.eq.0) then
  520. MPTVAL=IVADEP
  521. else
  522. MPTVAL=IVADEPV
  523. endif
  524. *fin as xfem 2010_01_13
  525. DO 230 ID=1,IDIM
  526. MELVAL=IVAL(ID)
  527. IBMN=MIN(IB,VELCHE(/2))
  528. DO 230 INO=1,NBNN
  529. INMN=MIN(INO,VELCHE(/1))
  530. XE2(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  531. 230 CONTINUE
  532. C
  533. *as xfem 2010_01_13
  534. * Si élément enrichi :
  535. if (nbenrj.ne.0) then
  536. * Stockage des sauts config. initiale -> config de reference
  537. MPTVAL=IVADEP0
  538. DO ID=1,IDIM
  539. MELVAL=IVAL(ID+IDIM)
  540. IBMN=MIN(IB,VELCHE(/2))
  541. do INO=1,NBNN
  542. INMN=MIN(INO,VELCHE(/1))
  543. TABA1(ID,INO)=VELCHE(INMN,IBMN)
  544. ENDDO
  545. enddo
  546. * Stockage des sauts config. initiale -> config finale
  547. MPTVAL=IVADEP
  548. DO ID=1,IDIM
  549. MELVAL=IVAL(ID+IDIM)
  550. IBMN=MIN(IB,VELCHE(/2))
  551. do INO=1,NBNN
  552. INMN=MIN(INO,VELCHE(/1))
  553. TABA2(ID,INO)= TABA1(ID,INO) + VELCHE(INMN,IBMN)
  554. ENDDO
  555. enddo
  556. endif
  557. *fin as xfem 2010_01_13
  558. ELSE
  559. *as xfem 2010_01_13
  560. if (nbenrj.eq.0) then
  561. MPTVAL=IVADEP
  562. else
  563. MPTVAL=IVADEPV
  564. endif
  565. *fin as xfem 2010_01_13
  566. DO 210 ID=1,IDIM
  567. MELVAL=IVAL(ID)
  568. IBMN=MIN(IB,VELCHE(/2))
  569. DO 210 INO=1,NBNN
  570. INMN=MIN(INO,VELCHE(/1))
  571. XE1(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  572. 210 CONTINUE
  573. DO 215 INO=1,NBNN
  574. DO 215 ID=1,IDIM
  575. XE2(ID,INO)=XE(ID,INO)
  576. 215 CONTINUE
  577.  
  578. *as xfem 2010_01_13
  579. * Si élément enrichi :
  580. if (nbenrj.ne.0) then
  581. * Stockage des sauts config. initiale -> config de reference
  582. MPTVAL=IVADEP0
  583. do INO=1,NBNN
  584. DO ID=1,IDIM
  585. MELVAL=IVAL(ID+IDIM)
  586. IBMN=MIN(IB,VELCHE(/2))
  587. INMN=MIN(INO,VELCHE(/1))
  588. TABA2(ID,INO)=VELCHE(INMN,IBMN)
  589. ENDDO
  590. enddo
  591. * Stockage des sauts config. initiale -> config finale
  592. MPTVAL=IVADEP
  593. do INO=1,NBNN
  594. DO ID=1,IDIM
  595. MELVAL=IVAL(ID+IDIM)
  596. IBMN=MIN(IB,VELCHE(/2))
  597. INMN=MIN(INO,VELCHE(/1))
  598. TABA1(ID,INO)= TABA2(ID,INO) + VELCHE(INMN,IBMN)
  599. ENDDO
  600. enddo
  601. endif
  602. *fin as xfem 2010_01_13
  603. ENDIF
  604. C
  605. C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  606. C OU LES DEFORMATIONS
  607. C
  608. MPTVAL=IVAST1
  609. DO 240 ICOMP=1,NSTRS
  610. MELVAL=IVAL(ICOMP)
  611. IBMN=MIN(IB,VELCHE(/2))
  612. JGMN=VELCHE(/1)
  613. DO 240 IGAU=1,NBPTEL
  614. IGMN=MIN(IGAU,JGMN)
  615. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  616. 240 CONTINUE
  617. C
  618. *as xfem 2010_01_13
  619. if (nbenrj.eq.0) then
  620. if(ideri.eq.5 .or. IPICA.eq.0) then
  621. kerre=0
  622. do icomp=1,nstrs
  623. MELVAL=IVAL(ICOMP)
  624. IBMN=MIN(IB,VELCHE(/2))
  625. JGMN=VELCHE(/1)
  626. do igau=1,nbptel
  627. IGMN=MIN(IGAU,JGMN)
  628. STRESS(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  629. enddo
  630. enddo
  631. else if(ideri.eq.4) then
  632. call jaucau(NBNN,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  633. & SHPWRK,STRESS,KCAS,mwrk5,LADIM,mele,IIPDPG)
  634. kerre=IERR
  635. else
  636. CALL PIOCAF(NBNN,nbsh,IDIM,STRES1,NSTRS,NBPTEL,SHPTOT,XE1
  637. 1 ,XE2, SHPWRK,STRESS,IFOUR,KCAS,KERRE)
  638. endif
  639. else
  640. CALL PIOCAX(NBNN,IDIM,STRES1,NSTRS,NBPTEL,IPMINT,XE1,XE2,
  641. 1 TABA,MRACC,SHPWRK,STRESS,IFOUR,KCAS,KERRE)
  642. endif
  643. *fin as xfem 2010_01_13 <
  644. C
  645. IF(KERRE.NE.0) THEN
  646. CALL ERREUR(716)
  647. GO TO 9990
  648. ENDIF
  649. C
  650. C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  651. C
  652. MPTVAL=IVASTR
  653. DO 250 IGAU=1,NBPTEL
  654. DO 250 ICOMP=1,NSTRS
  655. MELVAL=IVAL(ICOMP)
  656. IBMN=MIN(IB,VELCHE(/2))
  657. VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  658. 250 CONTINUE
  659.  
  660. 200 CONTINUE
  661.  
  662. *as xfem 2010_01_27
  663. IF(MFR.EQ.63) then
  664. SEGSUP,MRACC
  665. SEGSUP,TABA
  666. SEGDES,MCHAM1
  667. ENDIF
  668. *fin as xfem 2010_01_13
  669. if(ideri.eq.4) then
  670. segsup mwrk5
  671. endif
  672. C
  673. C ---------------------------------------------------
  674. C TRANSFORMATION DES TENSEURS SI ELEMENTS DKT
  675. C ---------------------------------------------------
  676. * supprime le 08/06/12 car inutile et donne un resultat faux
  677. *
  678. ************************************************************
  679.  
  680. ELSE IF(MFR.EQ.3.and.MELE.EQ.28.and.(.false.))THEN
  681. C
  682. DO 3028 IB=1,NBELEM
  683. C
  684. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  685. C
  686. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  687. C
  688. C ON CHERCHE LES DEPLACEMENTS
  689. C
  690. IE=1
  691. DO 4028 IGAU=1,NBNN
  692. MPTVAL=IVADEP
  693. DO 4028 ICOMP=1,NDEP
  694. MELVAL=IVAL(ICOMP)
  695. IGMN=MIN(IGAU,VELCHE(/1))
  696. IBMN=MIN(IB ,VELCHE(/2))
  697. XDDL(IE)=VELCHE(IGMN,IBMN)
  698. IE=IE+1
  699. 4028 CONTINUE
  700. C
  701. CALL VPAST(XE,BPSS)
  702. C BPSS STOCKE LA MATRICE DE PASSAGE
  703. CALL VCORLC (XE,XEL,BPSS)
  704. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  705. C
  706. C
  707. C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  708. C
  709. IF(IM.EQ.0)THEN
  710. DO 320 INO=1,NBNN
  711. DO 320 ID=1,IDIM
  712. XE1(ID,INO)=XEL(ID,INO)
  713. 320 CONTINUE
  714. C
  715. IG=-6
  716. MPTVAL=IVADEP
  717. DO 330 INO=1,NBNN
  718. IE=1
  719. IG=IG+6
  720. DO 330 ID=1,IDIM
  721. MELVAL=IVAL(ID)
  722. IBMN=MIN(IB,VELCHE(/2))
  723. INMN=MIN(INO,VELCHE(/1))
  724. XE2(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  725. IE = IE + 1
  726. 330 CONTINUE
  727. C
  728. ELSE
  729. IG=-6
  730. IE = 1
  731. MPTVAL=IVADEP
  732. DO 310 INO=1,NBNN
  733. IE=1
  734. IG=IG+6
  735. DO 310 ID=1,IDIM
  736. MELVAL=IVAL(ID)
  737. IBMN=MIN(IB,VELCHE(/2))
  738. INMN=MIN(INO,VELCHE(/1))
  739. XE1(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  740. IE = IE + 1
  741. 310 CONTINUE
  742. DO 315 INO=1,NBNN
  743. DO 315 ID=1,IDIM
  744. XE2(ID,INO)=XEL(ID,INO)
  745. 315 CONTINUE
  746. ENDIF
  747. C
  748. C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  749. C
  750. MPTVAL=IVAST1
  751. DO 340 IGAU=1,NBPTEL
  752. DO 340 ICOMP=1,NSTRS
  753. MELVAL=IVAL(ICOMP)
  754. IBMN=MIN(IB,VELCHE(/2))
  755. IGMN=MIN(IGAU,VELCHE(/1))
  756. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  757. 340 CONTINUE
  758. C
  759. CALL PICAF2(NBNN,2,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  760. 1 SHPWRK,STRESS,IFOUR,1,KERRE)
  761. C
  762. IF(KERRE.NE.0) THEN
  763. CALL ERREUR(716)
  764. GO TO 9990
  765. ENDIF
  766. C
  767. C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  768. C
  769. MPTVAL=IVASTR
  770. DO 350 IGAU=1,NBPTEL
  771. DO 350 ICOMP=1,NSTRS
  772. MELVAL=IVAL(ICOMP)
  773. IBMN=MIN(IB,VELCHE(/2))
  774. VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  775. 350 CONTINUE
  776. C
  777. 3028 CONTINUE
  778. C
  779. C --------------------
  780. C AUTRES ELEMENTS
  781. C --------------------
  782.  
  783. ELSE
  784. C
  785. C
  786. C BOUCLE SUR LES ELEMENTS
  787. C
  788. DO 400 IB=1,NBELEM
  789. C
  790. C POUR LES AUTRES ELEMENTS ,ON COPIE LES CONTRAINTES
  791. C OU LES DEFORMATIONS
  792. C SANS LA TRANSFORMATION
  793. C
  794. MPTVAL=IVAST1
  795. DO 460 IGAU=1,NBPTEL
  796. DO 460 ICOMP=1,NSTRS
  797. MELVAL=IVAL(ICOMP)
  798. IBMN=MIN(IB,VELCHE(/2))
  799. IGMN=MIN(IGAU,VELCHE(/1))
  800. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  801. 460 CONTINUE
  802. C
  803. MPTVAL=IVASTR
  804. DO 470 IGAU=1,NBPTEL
  805. DO 470 ICOMP=1,NSTRS
  806. MELVAL=IVAL(ICOMP)
  807. IBMN=MIN(IB,VELCHE(/2))
  808. VELCHE(IGAU,IBMN)=STRES1(IGAU,ICOMP)
  809. 470 CONTINUE
  810. 400 CONTINUE
  811. ENDIF
  812. C
  813. C DESACTIVATION DES SEGMENTS
  814. C
  815. *as xfem 2010_01_13
  816. IF(MFR.EQ.1.or.MFR.eq.63)THEN
  817. SEGSUP,MWRK1,MWRK2
  818. ELSE IF(MFR.EQ.3)THEN
  819. SEGSUP,MWRK1,MWRK2,MWRK4
  820. ENDIF
  821. SEGSUP,MWRK3
  822. *
  823. CALL DTMVAL(IVADEP,1)
  824. *
  825. IF(ISUP.EQ.1)THEN
  826. CALL DTMVAL(IVAST1,3)
  827. ELSE
  828. CALL DTMVAL(IVAST1,1)
  829. ENDIF
  830. *
  831. CALL DTMVAL(IVASTR,1)
  832. *
  833. NOMID=MODEPL
  834. if(lsupdp)SEGSUP NOMID
  835. NOMID=MOSTRS
  836. if(lsupno)SEGSUP NOMID
  837. nomid=modepv
  838. if(lsupdp0) SEGSUP NOMID
  839. *
  840. SEGDES,IMODEL,MELEME
  841. SEGDES,MCHAML,MINTE
  842. *
  843. 500 CONTINUE
  844. SEGDES,MMODEL,MCHELM
  845. CALL DTCHAM(IPCHE3)
  846. IRET = 1
  847. *
  848. RETURN
  849. *
  850. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  851. *
  852. 9990 CONTINUE
  853. *
  854. * Gestion des messages d'erreur
  855. *
  856. IF (IMESS.NE.0) THEN
  857. INTERR(1) = IB
  858. CALL ERREUR(IMESS)
  859. ENDIF
  860. *
  861. CALL DTMVAL(IVADEP,1)
  862. *
  863. IF(ISUP.EQ.1)THEN
  864. CALL DTMVAL(IVAST1,3)
  865. ELSE
  866. CALL DTMVAL(IVAST1,1)
  867. ENDIF
  868. *
  869. CALL DTMVAL(IVASTR,3)
  870. *
  871. IF(MODEPL.NE.0)THEN
  872. NOMID=MODEPL
  873. if(lsupdp)SEGSUP NOMID
  874. ENDIF
  875. *
  876. IF(MOSTRS.NE.0)THEN
  877. NOMID=MOSTRS
  878. if(lsupno)SEGSUP NOMID
  879. ENDIF
  880. *
  881. SEGDES MELEME
  882. SEGDES IMODEL
  883. *
  884. SEGDES MMODEL
  885. SEGSUP,MCHELM
  886. *
  887. CALL DTCHAM(IPCHE3)
  888. SEGDES MINTE
  889. * write(ioimp,*) 'FIN piocap.eso si erreur'
  890. IRET = 0
  891. RETURN
  892. END
  893.  
  894.  
  895.  

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