Télécharger piocap.eso

Retour à la liste

Numérotation des lignes :

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

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