Télécharger piocap.eso

Retour à la liste

Numérotation des lignes :

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

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