Télécharger piocap.eso

Retour à la liste

Numérotation des lignes :

  1. C PIOCAP SOURCE PV 17/04/13 21:15:05 9393
  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=IMAMOD
  209. CONM=CONMOD
  210. IIPDPG = IPDPGE
  211. C
  212. C TRAITEMENT DU MODELE
  213. C
  214. C On n'utilise pas PICA avec un des modeles interdits (OTTOSEN, UO2) ou
  215. C le modele utilisateur UMAT (cas contrainte deja de Cauchy)
  216. C Cette partie de l'operateur est a ameliorer (juste copie du CHAMP !!!)
  217. IPICA = 1
  218. IF ( INATUU.EQ.108 .OR. INATUU.EQ.42 .OR. INATUU.EQ.-1 ) THEN
  219. IPICA = 0
  220. ENDIF
  221.  
  222. MELE=NEFMOD
  223. MELEME=IMAMOD
  224. ideri=ideriv
  225. C____________________________________________________________________
  226. C
  227. C INFORMATION SUR L'ELEMENT FINI
  228. C____________________________________________________________________
  229. C
  230. * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  231. * IF (IERR.NE.0) THEN
  232. * SEGDES IMODEL,MMODEL
  233. * SEGSUP MCHELM
  234. * CALL DTCHAM(IPCHE3)
  235. * RETURN
  236. * ENDIF
  237. * INFO=IPINF
  238. MFR =INFELE(13)
  239. IPORE=INFELE(8)
  240. NBG =INFELE(6)
  241. NBGS =INFELE(4)
  242. NSTRS=INFELE(16)
  243. LRE =INFELE(9)
  244. LW =INFELE(7)
  245. LHOOK=INFELE(10)
  246. LHOO2=LHOOK*LHOOK
  247. NDDL =INFELE(15)
  248. * MINTE=INFELE(11)
  249. if (infmod(/1).lt.7) goto 500
  250. minte=infmod(7)
  251. if (minte.eq.0) goto 500
  252. IPMINT=MINTE
  253. MINTE1=INFMOD(8)
  254. ISOUS=ISOUS+1
  255. IMACHE(ISOUS)=IPMAIL
  256. CONCHE(ISOUS)=CONMOD
  257. * SEGSUP INFO
  258. C
  259. C CREATION DU TABLEAU INFOS
  260. C
  261. INFOS(1)=0
  262. INFOS(2)=0
  263. INFOS(3)=NIFOUR
  264. C
  265. INFCHE(ISOUS,1)=0
  266. INFCHE(ISOUS,2)=0
  267. INFCHE(ISOUS,3)=NHRM
  268. INFCHE(ISOUS,4)=MINTE
  269. INFCHE(ISOUS,5)=0
  270. INFCHE(ISOUS,6)=5
  271. C
  272. C INITIALISATION DE MINTE
  273. C
  274. SEGACT MINTE
  275. NBPGAU=POIGAU(/1)
  276. C
  277. C Cas des modes de calculs en DEFORMATIONS GENERALISEES
  278. CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  279. C
  280. C ACTIVATION DU MELEME
  281. C
  282. SEGACT MELEME
  283. NBNN =NUM(/1)
  284. NBELEM=NUM(/2)
  285. *as xfem 2010_01_13
  286. if (MFR.eq.63) then
  287. NBSH=INFELE(8)
  288. else
  289. NBSH=NBNN
  290. endif
  291. *fin as xfem 2010_01_13
  292. IPPORE=0
  293. IF(MFR.EQ.33) IPPORE=NBNN
  294. C____________________________________________________________________
  295. C
  296. C RECHERCHE DES NOMS DE COMPOSANTES
  297. C____________________________________________________________________
  298. C
  299. lsupno=.false.
  300. IF(KCAS.EQ.1) THEN
  301. if(lnomid(4).ne.0) then
  302. nomid=lnomid(4)
  303. segact nomid
  304. mostrs=nomid
  305. nstr=lesobl(/2)
  306. nfac=lesfac(/2)
  307. else
  308. lsupno=.true.
  309. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  310. endif
  311. ENDIF
  312. IF(KCAS.EQ.2) THEN
  313. if(lnomid(5).ne.0) then
  314. nomid=lnomid(5)
  315. segact nomid
  316. nstr=lesobl(/2)
  317. mostrs=nomid
  318. nfac=lesfac(/2)
  319. else
  320. lsupno=.true.
  321. CALL IDDEFO(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  322. endif
  323. ENDIF
  324. C
  325. if(lnomid(1).ne.0) then
  326. nomid=lnomid(1)
  327. segact nomid
  328. modepl=nomid
  329. ndep=lesobl(/2)
  330. nfac=lesfac(/2)
  331. lsupdp=.false.
  332. else
  333. lsupdp=.true.
  334. CALL IDPRIM(IMODEL,0,MODEPL,NDEP,NFAC)
  335. endif
  336.  
  337. if (ideri.eq.4) then
  338. IF (LNOMID(3).NE.0) then
  339. MOGRAD=LNOMID(3)
  340. NOMID=MOGRAD
  341. SEGACT,NOMID
  342. NGRA=LESOBL(/2)
  343. segdes,nomid
  344. ELSE
  345. CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,NFAC)
  346. ENDIF
  347. LADIM=0
  348. IF (NGRA.EQ.4) LADIM=2
  349. IF (NGRA.EQ.9) LADIM=3
  350. IF (LADIM.EQ.0) THEN
  351. CALL ERREUR(26)
  352. RETURN
  353. ENDIF
  354. endif
  355.  
  356. *as xfem 2010_01_13
  357. * On récupère les noms des composantes du cas massif, pour les depl. vrais
  358. lsupdp0=.false.
  359. IF (ichax1.ne.0) then
  360. MFRTMP=1
  361. call idprim(IMODEL,MFRTMP,MODEPV,NDEPV,NFACV)
  362. * as 2010_01_22
  363. lsupdp0=.true.
  364. ENDIF
  365. *fin as xfem 2010_01_13
  366.  
  367. C Recherche des DDL du noeud support des def. planes generalisees
  368. IF (ldpge) THEN
  369. IF (IIPDPG.LE.0) THEN
  370. CALL ERREUR(925)
  371. ELSE
  372. CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  373. ENDIF
  374. IF (IERR.NE.0) RETURN
  375. ENDIF
  376. C____________________________________________________________________
  377. C
  378. C VERIFICATION DE LEUR PRESENCE
  379. C____________________________________________________________________
  380. C
  381. NBTYPE=1
  382. SEGINI NOTYPE
  383. MOTYPE=NOTYPE
  384. TYPE(1)='REAL*8'
  385. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
  386. *as xfem 2010_01_13
  387. if (ichax1.ne.0) then
  388. call KOMCHA(IPCHE0,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP0)
  389. call KOMCHA(IPCHE4,IPMAIL,CONM,MODEPV,MOTYPE,1,INFOS,3,IVADEPV)
  390. endif
  391. *fin as xfem 2010_01_13
  392. IF (IERR.NE.0)THEN
  393. SEGSUP NOTYPE
  394. GOTO 9990
  395. ENDIF
  396. C*Z MPTVAL=IVADEP
  397. C*Z NDDD=IVAL(/1)
  398. C*Z IF (ldpge) NDDD=NDEP-ndpge
  399. C
  400. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVAST1)
  401. SEGSUP NOTYPE
  402. IF (IERR.NE.0) GOTO 9990
  403. IF (ISUP.EQ.1) THEN
  404. CALL VALCHE(IVAST1,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  405. ENDIF
  406. C
  407. C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  408. C
  409. N1PTEL=NBGS
  410. N1EL=NBELEM
  411. NBPTEL=N1PTEL
  412. NEL=N1EL
  413. C
  414. C CREATION DU MCHAML DE LA SOUS ZONE
  415. C
  416. N2=NSTRS
  417. SEGINI MCHAML
  418. ICHAML(ISOUS)=MCHAML
  419. NS=1
  420. NCOSOU=NSTRS
  421. SEGINI MPTVAL
  422. IVASTR=MPTVAL
  423. NOMID=MOSTRS
  424. SEGACT NOMID
  425. DO 100 ICOMP=1,NSTRS
  426. NOMCHE(ICOMP)=LESOBL(ICOMP)
  427. TYPCHE(ICOMP)='REAL*8'
  428. N2PTEL=0
  429. N2EL=0
  430. SEGINI MELVAL
  431. IELVAL(ICOMP)=MELVAL
  432. IVAL(ICOMP)=MELVAL
  433. 100 CONTINUE
  434. SEGDES NOMID
  435. C
  436. *as xfem 2010_01_13
  437. IF(MFR.EQ.1.or.MFR.EQ.63)THEN
  438. SEGINI,MWRK1,MWRK2
  439. ELSE IF(MFR.EQ.3)THEN
  440. SEGINI,MWRK1,MWRK2,MWRK4
  441. ENDIF
  442. SEGINI,MWRK3
  443. C
  444. C ---------------------------------------------------
  445. C TRANSFORMATION DES TENSEURS SI ELEMENTS MASSIFS sauf shb8
  446. C ---------------------------------------------------
  447. IF((MFR.EQ.1.or.MFR.EQ.63).and.mele.ne.260)THEN
  448.  
  449. *as xfem 2010_01_13
  450. IF(MFR.EQ.63) then
  451. SEGINI,MRACC
  452. SEGINI,TABA
  453. SEGACT,MCHAM1
  454. ENDIF
  455. *fin as xfem 2010_01_13
  456. if(ideri.eq.4) then
  457. segini mwrk5
  458. endif
  459.  
  460. C* Mode en DEFO.GENE (DEBUT)
  461. IF (ldpge) THEN
  462. c* revoir le signe pour IM = 1 (CAPI) ????
  463. rsig = 1.D0 - 2.D0*IM
  464. IF (IDIM.EQ.2) THEN
  465. C* equivalent a IF (IFOUR.EQ.-3) THEN
  466. XE2(3,1) = rsig * UDPGE(1)
  467. c* Finir avec les rotations RX et RY ?
  468. ELSE
  469. C* ELSE IF (IDIM.EQ.1) THEN
  470. IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.14) THEN
  471. XE2(2,1) = rsig * UDPGE(1)
  472. ELSE IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10) THEN
  473. XE2(3,1) = rsig * UDPGE(1)
  474. ELSE
  475. c* ELSE IF (IFOUR.EQ.11) THEN
  476. XE2(2,1) = rsig * UDPGE(1)
  477. XE2(3,1) = rsig * UDPGE(2)
  478. ENDIF
  479. ENDIF
  480. ENDIF
  481. C* Mode en DEFO.GENE (FIN)
  482. C
  483. C BOUCLE SUR LES ELEMENTS
  484. C
  485. DO 200 IB=1,NBELEM
  486.  
  487. *as xfem 2010_01_13
  488. * Cacul du niveau d'enrichissement de l'élément :
  489. nbenrj=0
  490. if (ichax1.ne.0) then
  491. if (nbenr1.ne.0) then
  492. MELVA1=MCHAM1.IELVAL(1)
  493. SEGACT MELVA1
  494. do i=1,NBNN
  495. mlree1=MELVA1.IELCHE(I,IB)
  496. tlreel(i)=mlree1
  497. if (mlree1.ne.0) then
  498. nbenrj=max(nbenrj,1)
  499. segact,mlree1
  500. endif
  501. enddo
  502. segdes MELVA1
  503. endif
  504. endif
  505. *fin as xfem 2010_01_13
  506.  
  507. C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  508. C
  509. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  510. C
  511. IF(IM.EQ.0)THEN
  512. DO 220 INO=1,NBNN
  513. DO 220 ID=1,IDIM
  514. XE1(ID,INO)=XE(ID,INO)
  515. 220 CONTINUE
  516. C
  517. *as xfem 2010_01_13
  518. if (nbenrj.eq.0) then
  519. MPTVAL=IVADEP
  520. else
  521. MPTVAL=IVADEPV
  522. endif
  523. *fin as xfem 2010_01_13
  524. DO 230 ID=1,IDIM
  525. MELVAL=IVAL(ID)
  526. IBMN=MIN(IB,VELCHE(/2))
  527. DO 230 INO=1,NBNN
  528. INMN=MIN(INO,VELCHE(/1))
  529. XE2(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  530. 230 CONTINUE
  531. C
  532. *as xfem 2010_01_13
  533. * Si élément enrichi :
  534. if (nbenrj.ne.0) then
  535. * Stockage des sauts config. initiale -> config de reference
  536. MPTVAL=IVADEP0
  537. DO ID=1,IDIM
  538. MELVAL=IVAL(ID+IDIM)
  539. IBMN=MIN(IB,VELCHE(/2))
  540. do INO=1,NBNN
  541. INMN=MIN(INO,VELCHE(/1))
  542. TABA1(ID,INO)=VELCHE(INMN,IBMN)
  543. ENDDO
  544. enddo
  545. * Stockage des sauts config. initiale -> config finale
  546. MPTVAL=IVADEP
  547. DO ID=1,IDIM
  548. MELVAL=IVAL(ID+IDIM)
  549. IBMN=MIN(IB,VELCHE(/2))
  550. do INO=1,NBNN
  551. INMN=MIN(INO,VELCHE(/1))
  552. TABA2(ID,INO)= TABA1(ID,INO) + VELCHE(INMN,IBMN)
  553. ENDDO
  554. enddo
  555. endif
  556. *fin as xfem 2010_01_13
  557. ELSE
  558. *as xfem 2010_01_13
  559. if (nbenrj.eq.0) then
  560. MPTVAL=IVADEP
  561. else
  562. MPTVAL=IVADEPV
  563. endif
  564. *fin as xfem 2010_01_13
  565. DO 210 ID=1,IDIM
  566. MELVAL=IVAL(ID)
  567. IBMN=MIN(IB,VELCHE(/2))
  568. DO 210 INO=1,NBNN
  569. INMN=MIN(INO,VELCHE(/1))
  570. XE1(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  571. 210 CONTINUE
  572. DO 215 INO=1,NBNN
  573. DO 215 ID=1,IDIM
  574. XE2(ID,INO)=XE(ID,INO)
  575. 215 CONTINUE
  576.  
  577. *as xfem 2010_01_13
  578. * Si élément enrichi :
  579. if (nbenrj.ne.0) then
  580. * Stockage des sauts config. initiale -> config de reference
  581. MPTVAL=IVADEP0
  582. do INO=1,NBNN
  583. DO ID=1,IDIM
  584. MELVAL=IVAL(ID+IDIM)
  585. IBMN=MIN(IB,VELCHE(/2))
  586. INMN=MIN(INO,VELCHE(/1))
  587. TABA2(ID,INO)=VELCHE(INMN,IBMN)
  588. ENDDO
  589. enddo
  590. * Stockage des sauts config. initiale -> config finale
  591. MPTVAL=IVADEP
  592. do INO=1,NBNN
  593. DO ID=1,IDIM
  594. MELVAL=IVAL(ID+IDIM)
  595. IBMN=MIN(IB,VELCHE(/2))
  596. INMN=MIN(INO,VELCHE(/1))
  597. TABA1(ID,INO)= TABA2(ID,INO) + VELCHE(INMN,IBMN)
  598. ENDDO
  599. enddo
  600. endif
  601. *fin as xfem 2010_01_13
  602. ENDIF
  603. C
  604. C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  605. C OU LES DEFORMATIONS
  606. C
  607. MPTVAL=IVAST1
  608. DO 240 ICOMP=1,NSTRS
  609. MELVAL=IVAL(ICOMP)
  610. IBMN=MIN(IB,VELCHE(/2))
  611. JGMN=VELCHE(/1)
  612. DO 240 IGAU=1,NBPTEL
  613. IGMN=MIN(IGAU,JGMN)
  614. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  615. 240 CONTINUE
  616. C
  617. *as xfem 2010_01_13
  618. if (nbenrj.eq.0) then
  619. if(ideri.eq.5 .or. IPICA.eq.0) then
  620. kerre=0
  621. do icomp=1,nstrs
  622. MELVAL=IVAL(ICOMP)
  623. IBMN=MIN(IB,VELCHE(/2))
  624. JGMN=VELCHE(/1)
  625. do igau=1,nbptel
  626. IGMN=MIN(IGAU,JGMN)
  627. STRESS(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  628. enddo
  629. enddo
  630. else if(ideri.eq.4) then
  631. call jaucau(NBNN,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  632. & SHPWRK,STRESS,KCAS,mwrk5,LADIM,mele,IIPDPG)
  633. kerre=IERR
  634. else
  635. CALL PIOCAF(NBNN,nbsh,IDIM,STRES1,NSTRS,NBPTEL,SHPTOT,XE1
  636. 1 ,XE2, SHPWRK,STRESS,IFOUR,KCAS,KERRE)
  637. endif
  638. else
  639. CALL PIOCAX(NBNN,IDIM,STRES1,NSTRS,NBPTEL,IPMINT,XE1,XE2,
  640. 1 TABA,MRACC,SHPWRK,STRESS,IFOUR,KCAS,KERRE)
  641. endif
  642. *fin as xfem 2010_01_13 <
  643. C
  644. IF(KERRE.NE.0) THEN
  645. CALL ERREUR(716)
  646. GO TO 9990
  647. ENDIF
  648. C
  649. C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  650. C
  651. MPTVAL=IVASTR
  652. DO 250 IGAU=1,NBPTEL
  653. DO 250 ICOMP=1,NSTRS
  654. MELVAL=IVAL(ICOMP)
  655. IBMN=MIN(IB,VELCHE(/2))
  656. VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  657. 250 CONTINUE
  658.  
  659. 200 CONTINUE
  660.  
  661. *as xfem 2010_01_27
  662. IF(MFR.EQ.63) then
  663. SEGSUP,MRACC
  664. SEGSUP,TABA
  665. SEGDES,MCHAM1
  666. ENDIF
  667. *fin as xfem 2010_01_13
  668. if(ideri.eq.4) then
  669. segsup mwrk5
  670. endif
  671. C
  672. C ---------------------------------------------------
  673. C TRANSFORMATION DES TENSEURS SI ELEMENTS DKT
  674. C ---------------------------------------------------
  675. * supprime le 08/06/12 car inutile et donne un resultat faux
  676. *
  677. ************************************************************
  678.  
  679. ELSE IF(MFR.EQ.3.and.MELE.EQ.28.and.(.false.))THEN
  680. C
  681. DO 3028 IB=1,NBELEM
  682. C
  683. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  684. C
  685. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  686. C
  687. C ON CHERCHE LES DEPLACEMENTS
  688. C
  689. IE=1
  690. DO 4028 IGAU=1,NBNN
  691. MPTVAL=IVADEP
  692. DO 4028 ICOMP=1,NDEP
  693. MELVAL=IVAL(ICOMP)
  694. IGMN=MIN(IGAU,VELCHE(/1))
  695. IBMN=MIN(IB ,VELCHE(/2))
  696. XDDL(IE)=VELCHE(IGMN,IBMN)
  697. IE=IE+1
  698. 4028 CONTINUE
  699. C
  700. CALL VPAST(XE,BPSS)
  701. C BPSS STOCKE LA MATRICE DE PASSAGE
  702. CALL VCORLC (XE,XEL,BPSS)
  703. CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  704. C
  705. C
  706. C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  707. C
  708. IF(IM.EQ.0)THEN
  709. DO 320 INO=1,NBNN
  710. DO 320 ID=1,IDIM
  711. XE1(ID,INO)=XEL(ID,INO)
  712. 320 CONTINUE
  713. C
  714. IG=-6
  715. MPTVAL=IVADEP
  716. DO 330 INO=1,NBNN
  717. IE=1
  718. IG=IG+6
  719. DO 330 ID=1,IDIM
  720. MELVAL=IVAL(ID)
  721. IBMN=MIN(IB,VELCHE(/2))
  722. INMN=MIN(INO,VELCHE(/1))
  723. XE2(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  724. IE = IE + 1
  725. 330 CONTINUE
  726. C
  727. ELSE
  728. IG=-6
  729. IE = 1
  730. MPTVAL=IVADEP
  731. DO 310 INO=1,NBNN
  732. IE=1
  733. IG=IG+6
  734. DO 310 ID=1,IDIM
  735. MELVAL=IVAL(ID)
  736. IBMN=MIN(IB,VELCHE(/2))
  737. INMN=MIN(INO,VELCHE(/1))
  738. XE1(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  739. IE = IE + 1
  740. 310 CONTINUE
  741. DO 315 INO=1,NBNN
  742. DO 315 ID=1,IDIM
  743. XE2(ID,INO)=XEL(ID,INO)
  744. 315 CONTINUE
  745. ENDIF
  746. C
  747. C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  748. C
  749. MPTVAL=IVAST1
  750. DO 340 IGAU=1,NBPTEL
  751. DO 340 ICOMP=1,NSTRS
  752. MELVAL=IVAL(ICOMP)
  753. IBMN=MIN(IB,VELCHE(/2))
  754. IGMN=MIN(IGAU,VELCHE(/1))
  755. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  756. 340 CONTINUE
  757. C
  758. CALL PICAF2(NBNN,2,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  759. 1 SHPWRK,STRESS,IFOUR,1,KERRE)
  760. C
  761. IF(KERRE.NE.0) THEN
  762. CALL ERREUR(716)
  763. GO TO 9990
  764. ENDIF
  765. C
  766. C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  767. C
  768. MPTVAL=IVASTR
  769. DO 350 IGAU=1,NBPTEL
  770. DO 350 ICOMP=1,NSTRS
  771. MELVAL=IVAL(ICOMP)
  772. IBMN=MIN(IB,VELCHE(/2))
  773. VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  774. 350 CONTINUE
  775. C
  776. 3028 CONTINUE
  777. C
  778. C --------------------
  779. C AUTRES ELEMENTS
  780. C --------------------
  781.  
  782. ELSE
  783. C
  784. C
  785. C BOUCLE SUR LES ELEMENTS
  786. C
  787. DO 400 IB=1,NBELEM
  788. C
  789. C POUR LES AUTRES ELEMENTS ,ON COPIE LES CONTRAINTES
  790. C OU LES DEFORMATIONS
  791. C SANS LA TRANSFORMATION
  792. C
  793. MPTVAL=IVAST1
  794. DO 460 IGAU=1,NBPTEL
  795. DO 460 ICOMP=1,NSTRS
  796. MELVAL=IVAL(ICOMP)
  797. IBMN=MIN(IB,VELCHE(/2))
  798. IGMN=MIN(IGAU,VELCHE(/1))
  799. STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  800. 460 CONTINUE
  801. C
  802. MPTVAL=IVASTR
  803. DO 470 IGAU=1,NBPTEL
  804. DO 470 ICOMP=1,NSTRS
  805. MELVAL=IVAL(ICOMP)
  806. IBMN=MIN(IB,VELCHE(/2))
  807. VELCHE(IGAU,IBMN)=STRES1(IGAU,ICOMP)
  808. 470 CONTINUE
  809. 400 CONTINUE
  810. ENDIF
  811. C
  812. C DESACTIVATION DES SEGMENTS
  813. C
  814. *as xfem 2010_01_13
  815. IF(MFR.EQ.1.or.MFR.eq.63)THEN
  816. SEGSUP,MWRK1,MWRK2
  817. ELSE IF(MFR.EQ.3)THEN
  818. SEGSUP,MWRK1,MWRK2,MWRK4
  819. ENDIF
  820. SEGSUP,MWRK3
  821. *
  822. CALL DTMVAL(IVADEP,1)
  823. *
  824. IF(ISUP.EQ.1)THEN
  825. CALL DTMVAL(IVAST1,3)
  826. ELSE
  827. CALL DTMVAL(IVAST1,1)
  828. ENDIF
  829. *
  830. CALL DTMVAL(IVASTR,1)
  831. *
  832. NOMID=MODEPL
  833. if(lsupdp)SEGSUP NOMID
  834. NOMID=MOSTRS
  835. if(lsupno)SEGSUP NOMID
  836. nomid=modepv
  837. if(lsupdp0) SEGSUP NOMID
  838. *
  839. SEGDES,IMODEL,MELEME
  840. SEGDES,MCHAML,MINTE
  841. *
  842. 500 CONTINUE
  843. SEGDES,MMODEL,MCHELM
  844. CALL DTCHAM(IPCHE3)
  845. IRET = 1
  846. *
  847. RETURN
  848. *
  849. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  850. *
  851. 9990 CONTINUE
  852. *
  853. * Gestion des messages d'erreur
  854. *
  855. IF (IMESS.NE.0) THEN
  856. INTERR(1) = IB
  857. CALL ERREUR(IMESS)
  858. ENDIF
  859. *
  860. CALL DTMVAL(IVADEP,1)
  861. *
  862. IF(ISUP.EQ.1)THEN
  863. CALL DTMVAL(IVAST1,3)
  864. ELSE
  865. CALL DTMVAL(IVAST1,1)
  866. ENDIF
  867. *
  868. CALL DTMVAL(IVASTR,3)
  869. *
  870. IF(MODEPL.NE.0)THEN
  871. NOMID=MODEPL
  872. if(lsupdp)SEGSUP NOMID
  873. ENDIF
  874. *
  875. IF(MOSTRS.NE.0)THEN
  876. NOMID=MOSTRS
  877. if(lsupno)SEGSUP NOMID
  878. ENDIF
  879. *
  880. SEGDES MELEME
  881. SEGDES IMODEL
  882. *
  883. SEGDES MMODEL
  884. SEGSUP,MCHELM
  885. *
  886. CALL DTCHAM(IPCHE3)
  887. SEGDES MINTE
  888. * write(ioimp,*) 'FIN piocap.eso si erreur'
  889. IRET = 0
  890. RETURN
  891. END
  892.  
  893.  
  894.  
  895.  
  896.  
  897.  
  898.  
  899.  
  900.  

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