Télécharger piocap.eso

Retour à la liste

Numérotation des lignes :

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

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