Télécharger bsigmx.eso

Retour à la liste

Numérotation des lignes :

  1. C BSIGMX SOURCE CB215821 19/08/20 21:15:23 10287
  2. subroutine BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFOR,
  3. & IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER)
  4.  
  5. c
  6. C PROCEDURE UTILISEE DANS LE CAS D'ELEMENTS XFEM
  7. c POUR LE CALCUL DE la force interne (=B^T sigma)
  8. C
  9. C
  10. C*********************************************************
  11. C PARTIE DECLARATIVE
  12. C*********************************************************
  13.  
  14. C
  15. IMPLICIT REAL*8(A-H,O-Z)
  16. C
  17. PARAMETER (NDDLMAX=30,NBNIMAX=10)
  18. PARAMETER (NBENRMAX=5)
  19. DIMENSION MLRE(NBENRMAX+1),NCOMPCUM(NBENRMAX+1)
  20. C
  21. -INC CCOPTIO
  22. -INC SMCOORD
  23. -INC SMMODEL
  24. -INC SMCHAML
  25. -INC SMINTE
  26. -INC SMELEME
  27. -INC SMLREEL
  28. -INC CCREEL
  29. C
  30. POINTEUR MCHEX1.MCHELM,MINT1.MINTE,MINT2.MINTE
  31. C
  32. C Segment (type LISTENTI) contenant les informations sur un element
  33. SEGMENT INFO
  34. INTEGER INFELL(JG)
  35. ENDSEGMENT
  36. c
  37. SEGMENT WRK1
  38. REAL*8 XE(3,NBBB)
  39. REAL*8 XSTRS(LHOOK)
  40. REAL*8 XFORC(LRE),XFINC(LRE)
  41. ENDSEGMENT
  42. c
  43. SEGMENT WRK2
  44. REAL*8 SHPWRK(6,NBNO),BGENE(LHOOK,LRE)
  45. REAL*8 LV7WRK(NBENRMA2,2,6,NBBB)
  46. ENDSEGMENT
  47. c
  48. SEGMENT MPTVAL
  49. INTEGER IPOS(NS),NSOF(NS)
  50. INTEGER IVAL(NCOSOU)
  51. CHARACTER*16 TYVAL(NCOSOU)
  52. ENDSEGMENT
  53. C
  54. SEGMENT MRACC
  55. INTEGER TLREEL(NBENRMA2,NBI)
  56. ENDSEGMENT
  57. c
  58. * write (*,*) '############################'
  59. * write (*,*) '##### DEBUT DE BSIGMX #####'
  60. * write (*,*) '############################'
  61. IVADIM = 0
  62. C
  63. C*********************************************************
  64. c Introduction du point autour duquel se fait le mouvement
  65. c de la section en defo plane generalisee
  66. C*********************************************************
  67. ADPG=XZero
  68. BDPG=XZero
  69. CDPG=XZero
  70. C* On est en DEFO PLAN GENE :
  71. IF (IIPDPG.GT.0) THEN
  72. IREF=(IIPDPG-1)*(IDIM+1)
  73. XDPGE=XCOOR(IREF+1)
  74. YDPGE=XCOOR(IREF+2)
  75. ELSE
  76. XDPGE=XZero
  77. YDPGE=XZero
  78. ENDIF
  79. C
  80. C*********************************************************
  81. c
  82. C RECUPERATION + ACTIVATIONS + VALEURS UTILES
  83. c
  84. C*********************************************************
  85. C SEGACT MMODEL,IMODEL deja actif
  86. c
  87. C++++ Activation au cas ou ++++++++++++++++++++++++++++++
  88. SEGACT MCOORD
  89.  
  90. C++++ Recup + Activation de la geometrie ++++++++++++++++
  91. MELEME= IMAMOD
  92. c SEGACT MELEME deja actif
  93. C nbre de noeuds par element
  94. NBNN1 = NUM(/1)
  95. C nbre d elements
  96. NBEL1 = NUM(/2)
  97.  
  98. C++++ RECUP DES INFOS EF ++++++++++++++++++++++++++++++++
  99. c + OBTENUES PAR ELQUOI DANS RIGI1 PENDANT PHASE 1
  100. C segment INFO deja actif dans RIGI1
  101. c + rigi1 n appelle pas elquoi, c'est modeli qui l'a fait
  102. c mais du coup, on na pas de segment minte
  103. c (car depend de si pt de g pour rigi, pour sigma....)
  104. c c'est + simple de rappeler elquoi ici
  105. MELE = NEFMOD
  106. call elquoi(MELE,0,3,IPINF,IMODEL)
  107. INFO = IPINF
  108. c MELE = INFELL(1)
  109. c NBPGA2= INFELL(2)
  110. c NBPGAU= INFELL(3)
  111. c NBPGAU= INFELL(4)
  112. c ICARA = INFELL(5)
  113. NGAU1 = INFELL(6)
  114. c LW = INFELL(7)
  115. LRE = INFELL(9)
  116. LHOOK = INFELL(10)
  117. MINT1 = INFELL(11)
  118. segact,MINT1
  119. MINT2 = INFELL(12)
  120. if(MINT2.ne.0) segact,MINT2
  121. MFR = INFELL(13)
  122. IELE = INFELL(14)
  123. NDDL = INFELL(15)
  124. NSTRS = INFELL(16)
  125. c write(6,*)'-> EPSIX infell',(infell(iou),iou=1,16)
  126.  
  127. c REM: pour se passer du dimensionnement du nbre d'enrichissement dans
  128. c elquoi et le realiser localement , on pourrait ecrire:
  129. c LRE = NDDLMAX*NBNN1
  130. c NDDL= NDDLMAX
  131.  
  132. C sous decoupage et points de Gauss de l element geometrique de base
  133. if(MELE.EQ.263.OR.MELE.EQ.264) then
  134. NGAU2 = MINT2.POIGAU(/1)
  135. endif
  136. c write(*,*) 'dim de MINT2=6,',(MINT2.SHPTOT(/2)),(MINT2.SHPTOT(/3))
  137. c write(*,*) 'MINT2',(MINT2.QSIGAU(iou),iou=1,NGAU)
  138.  
  139. c nbre maxi de fonction de forme par noeud (fonction std comprise)
  140. c NBNI = NDDL/IDIM inutile!
  141.  
  142.  
  143. C++++ Recup des infos d enrichissement +++++++++++++++++++
  144. c recup du MCHEX1 d'enrichissement
  145. NOBMO1 = IVAMOD(/1)
  146. if(NOBMO1.ne.0) then
  147. do iobmo1=1,NOBMO1
  148. if((TYMODE(iobmo1)).eq.'MCHAML') then
  149. MCHEX1 = IVAMOD(iobmo1)
  150. segact,MCHEX1
  151. if((MCHEX1.TITCHE).eq.'ENRICHIS') then
  152. MCHAM1 = MCHEX1.ICHAML(1)
  153. segact,MCHAM1
  154. goto 1000
  155. endif
  156. endif
  157. enddo
  158. write(*,*) 'Le modele est vide (absence d enrichissement)'
  159. * return
  160. else
  161. write(*,*) 'Il n y a pas de MCHEML enrichissement dans le Modele'
  162. * return
  163. endif
  164.  
  165. 1000 continue
  166. c niveau d enrichissement(s) du modele (ddls std u exclus)
  167. c NBENR1= 0 si std, 1 si H seul, 2 si H+F1, 3 si H+F1+F2, etc...
  168. if(NOBMO1.ne.0) then
  169. NBENR1= MCHAM1.IELVAL(/1)
  170. else
  171. NBENR1= 0
  172. endif
  173. c write(*,*) 'niveau d enrichissement(s) du modele',NBENR1
  174. c
  175. C
  176. C
  177. C*********************************************************
  178. C INITIALISATIONS...
  179. C*********************************************************
  180. IRETER = 0
  181. DIM3 = 1.D0
  182. NCOSOU = 0
  183. c
  184. c preparation des tables avec:
  185.  
  186. if(NBENR1.ne.0) then
  187. do ienr=1,NBENR1
  188. c -le nombre d'inconnues de chaque sous-zone
  189. c determinee depuis le nombre de fonction de forme
  190. c ienr= 1: U+H(1+1=2), 2: U+H+F1(2+4=6), 3: U+H+F1+F2(6+4=10)
  191. nbniJ = 2 + ((ienr-1)*4)
  192. MLRE(1+ienr) = IDIM*NBNN1*nbniJ
  193. NCOSOU = NCOSOU + (IDIM*nbniJ)
  194. enddo
  195. endif
  196. C Tables + longues car 1er indice correspond au fontion de forme std
  197. MLRE(1) = IDIM*NBNN1*1
  198. NCOSOU = NCOSOU + (IDIM)
  199.  
  200. if(NBENR1.lt.(NBENRMAX+1)) then
  201. do ienr=(NBENR1+1),(NBENRMAX)
  202. MLRE(1+ienr) = 0
  203. enddo
  204. endif
  205. c
  206. c ...DU SEGMENT WRK1
  207. NBENRMA2 = NBENRMAX
  208. NBBB = NBNN1
  209. SEGINI,WRK1
  210.  
  211. c ...DU SEGMENT WRK2
  212. c NBNO = NBNI
  213. NBNO = LRE/IDIM
  214. SEGINI,WRK2
  215. C
  216. c ...DU SEGMENT MRACC
  217. NBENRMA2 = NBENRMAX
  218. NBI = NBNN1
  219. segini,MRACC
  220. C
  221. C
  222. c ...DU SEGMENT IVAFOR de type MPTVAL
  223. MPTVAL = IVAFOR
  224. * on change NS = IPOS(/1) et NCOSOU = IVAL(/1) (calculé + haut)
  225. NS = 1 + NBENR1
  226. * write(*,*) 'segadj IVAFOR aux dim',NS,NCOSOU
  227. segadj,MPTVAL
  228. c on remplit NSOF avec le nombre de composante par sous-zone
  229. c et NCOMPCUM avec le nombre de composante cumulée
  230. NCUMUL1 = 0
  231. do ienr1=0,NBENR1
  232. NCOMPCUM(1+ienr1) = NCUMUL1
  233. NSOF1 = (MLRE(1+ienr1)) / NBNN1
  234. NSOF(1+ienr1) = NSOF1
  235. NCUMUL1 = NCUMUL1 + NSOF1
  236. enddo
  237. if(NBENR1.lt.(NBENRMAX+1)) then
  238. do ienr=(NBENR1+1),(NBENRMAX)
  239. NCOMPCUM(1+ienr1) = NCUMUL1
  240. enddo
  241. endif
  242. c on recupere les dimensions (MAXI)
  243. MELVAL = IVAL(1)
  244. N1PTEL = VELCHE(/1)
  245. N1EL = VELCHE(/2)
  246. N2PTEL = IELCHE(/1)
  247. N2EL = IELCHE(/2)
  248. c write(*,*) 'MELVAL de taille maxi=',N1PTEL,N1EL,N2PTEL,N2EL
  249. c
  250.  
  251.  
  252. C*********************************************************
  253. C
  254. C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> BOUCLE SUR LES ELEMENTS
  255. C
  256. DO 2000 J=1,NBEL1
  257. c write(*,*) '========= EF',J,' /',NBEL1,'========='
  258. C
  259. C
  260. C*********************************************************
  261. C POUR CHAQUE ELEMENT, ...
  262. C*********************************************************
  263. C
  264. C++++ ON RECUPERE LES COORDONNEES DES NOEUDS DE L ELEMENT
  265. CALL DOXE(XCOOR,IDIM,NBNN1,NUM,J,XE)
  266. C
  267. c
  268. C++++ NBENRJ = niveau d enrichissement de l element ++++
  269. C =0 si EF std =1 si U+H =2 si U+H+F1 =3 si U+H+F1+F2
  270. NBENRJ=0
  271. if(NBENR1.ne.0) then
  272. do IENR=1,NBENR1
  273. MELVA1 = MCHAM1.IELVAL(IENR)
  274. segact,MELVA1
  275. do I=1,NBNN1
  276. mlree1 = MELVA1.IELCHE(I,J)
  277. C on en profite pour remplir MRACC table de raccourcis pour cet element
  278. TLREEL(IENR,I) = mlree1
  279. if(mlree1.ne.0) then
  280. NBENRJ = max(NBENRJ,IENR)
  281. C et on active la listreel
  282. segact,mlree1
  283. endif
  284. enddo
  285. enddo
  286. endif
  287. if(NBENRMA2.gt.NBENR1) then
  288. do IENR2=(NBENR1+1),NBENRMA2
  289. do I=1,NBNN1
  290. TLREEL(IENR2,I) = 0
  291. enddo
  292. enddo
  293. endif
  294. C
  295. c
  296. c++++ quelques indices pour dimensionner au plus juste
  297. c nbre total de ddl de l'élément considéré
  298. NLIGRD = MLRE(1+NBENRJ)
  299. NLIGRP = MLRE(1+NBENRJ)
  300. c nbre fonction de forme=((Ni_std+Ni_enrichi)*nbnoeud)=Ninconnues/idim
  301. NBNI = (MLRE(1+NBENRJ)) / IDIM
  302. c write(*,*) 'EF',J,' NBENRJ=',NBENRJ,
  303. c &'donc',NLIGRD,' ddls et ',NBNI,' fonctions de forme'
  304. c
  305. c
  306. c++++ Selon le niveau d enrichissement,
  307. c
  308. C + On copie cet element a la geo correspondante
  309. IPT1 = IPOS(1+NBENRJ)
  310. c si elle n existe pas, il faut la creer
  311. if(IPT1.eq.0) then
  312. NBNN =NBNN1
  313. NBELEM=1
  314. NBSOUS=0
  315. NBREF=0
  316. segini,IPT1
  317. IPT1.ITYPEL = ITYPEL
  318. IPOS(1+NBENRJ)=IPT1
  319. c si elle existe, il faut l agrandir
  320. else
  321. NBNN =NBNN1
  322. NBELEM = (IPT1.NUM(/2)) + 1
  323. NBSOUS=0
  324. NBREF=0
  325. segadj,IPT1
  326. endif
  327. J1 = NBELEM
  328. c copie en cours
  329. do I=1,NBNN1
  330. IPT1.NUM(I,NBELEM) = NUM(I,J)
  331. enddo
  332.  
  333. C + On en profite pour créer les MELVA2 si ils n existent pas
  334. MPTVAL = IVAFOR
  335. NCUMUL1 = NCOMPCUM(1+NBENRJ)
  336. NCOMP2 = NSOF(1+NBENRJ)
  337. do icomp2=1,NCOMP2
  338. MELVA2 = IVAL(NCUMUL1+icomp2)
  339. if(MELVA2.eq.0) then
  340. c N1PTEL N1EL,N2PTEL,N2EL = dim MAX : récupérés + haut
  341. segini,MELVA2
  342. IVAL(NCUMUL1+icomp2) = MELVA2
  343. endif
  344. enddo
  345.  
  346. c
  347. C++++ MISE A 0 DES FORCES ++++
  348. C
  349. CALL ZERO(XFINC,1,NLIGRP)
  350. c
  351. c
  352. c rem: il serait probablement interessant au niveau du tems cpu
  353. c d'utiliser moins de pts de Gauss lorsque l element est élastique
  354. c On pourrait par ex. utiliser MINT2 = infell(12) qui contient
  355. c le segment d'integration de l'EF std (QUA4 par ex.)
  356. * if((NBENRJ.eq.0).and.(MINT2.ne.0)) then
  357. * MINTE = MINT2
  358. * NBPGAU= NGAU2
  359. * else
  360. MINTE = MINT1
  361. NBPGAU= NGAU1
  362. * endif
  363. c
  364. NBPTEL=NBPGAU
  365. C
  366. C*********************************************************
  367. C
  368. IDIM1 = IDIM + 1
  369. C>>>>>>>>>> BOUCLE SUR LES POINTS DE GAUSS
  370. C
  371. DO 2500 KGAU=1,NBPGAU
  372. C
  373. C*********************************************************
  374. C Initialisation à 0
  375. C*********************************************************
  376.  
  377. c ZERO ne serait-il pas facultatif?
  378. CALL ZERO(SHPWRK,6,NBNO)
  379. C
  380. i6zz = 3
  381. IF (IDIM.EQ.3) i6zz = 4
  382. C
  383. c do ienr7=1,NBENRMAX
  384. do ienr7=1,NBENRJ
  385. do inod7=1,NBNN1
  386. c do i6=1,6
  387. do i6=1,i6zz
  388. LV7WRK(ienr7,1,i6,inod7) = 0.D0
  389. LV7WRK(ienr7,2,i6,inod7) = 0.D0
  390. enddo
  391. enddo
  392. enddo
  393.  
  394.  
  395. c*********************************************************
  396. c Calcul des fonction de forme std dans repere local
  397. c*********************************************************
  398.  
  399. ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccccc
  400. c (et donc sur les Ni std)
  401. DO 2510 I=1,NBNN1
  402. DO 2511 JJ=1,IDIM1
  403.  
  404. C++++ Calcul des Ni std
  405. c (rappel: 1:Ni 2:Ni,qsi 3:Ni,eta avec i=1,4)
  406. SHPWRK(JJ,I) = SHPTOT(JJ,I,KGAU)
  407. 2511 CONTINUE
  408. 2510 CONTINUE
  409. ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  410.  
  411.  
  412.  
  413. c*********************************************************
  414. c Passage des fonctions de forme std dans repere global
  415. c*********************************************************
  416.  
  417. C++++ CALCUL DES Ni,x Ni,y (i=1,4) + CALCUL DE det(J)
  418. CALL JACOBI(XE,SHPWRK,IDIM,NBNN1,DJAC)
  419. c
  420. C PRISE EN COMPTE DU POIDS D'INTEGRATION
  421. DJAC = ABS(DJAC) * POIGAU(KGAU)
  422. c
  423. C PRISE EN COMPTE DE L EPAISSEUR (cas Contrainte Planes)
  424. IF (IFOUR.EQ.-2)THEN
  425. MPTVAL=IVACAR
  426. IF (IVACAR.NE.0) THEN
  427. MELVAL=IVAL(1)
  428. IF (MELVAL.NE.0) THEN
  429. IGMN=MIN(KGAU,VELCHE(/1))
  430. IBMN=MIN(J,VELCHE(/2))
  431. DIM3=VELCHE(IGMN,IBMN)
  432. DJAC=DJAC*DIM3
  433. c ELSE
  434. c DIM3=1.D0
  435. ENDIF
  436. ENDIF
  437. ENDIF
  438. c
  439. c if(J.eq.1.and.KGAU.eq.1)
  440. c &write(*,*) 'Ni(i=1,4)=',(SHPWRK(1,iou),iou=1,NBNN1)
  441.  
  442. c*********************************************************
  443. c Si on est pas du tout enrichi on peut sauter une grosse partie
  444. c*********************************************************
  445. if(NBENRJ.eq.0) goto 2999
  446.  
  447. c*********************************************************
  448. c Calcul des level set + leurs derivees dans repere global
  449. c*********************************************************
  450.  
  451. ccccc BOUCLE SUR LES enrichissements ccccccccccccccccccc
  452. do 2520 ienr=1,NBENRJ
  453.  
  454. c MELVA1=MCHAM1.IELVAL(IENR)
  455. c segact,MELVA1
  456.  
  457. ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccc
  458. DO 2521 I=1,NBNN1
  459.  
  460. C++++ Le I eme noeud est-il ienr-enrichi?
  461. mlree1= TLREEL(IENR,I)
  462. if(mlree1.eq.0) goto 2521
  463.  
  464.  
  465. c Calcul du repere local de fissure(=PSI,PHI)
  466. c (rappel: 1,1:psi 1,2:phi 2,1 psi,x ...etc...)
  467. do 2522 inode=1,NBNN1
  468. c pour le H-enrichissement, on n a pas gardé PSI (inutile)
  469. if(ienr.ne.1) then
  470. c valeur de PSI au inode^ieme noeud
  471. xpsi1 = mlree1.PROG(inode)
  472. c qu on multiplie par la valeur de Ni^std au pt de G considéré
  473. do 2523 jj=1,IDIM1
  474. LV7WRK(ienr,1,JJ,I)= LV7WRK(ienr,1,JJ,I)
  475. & + (SHPWRK(JJ,inode)*xpsi1)
  476. 2523 continue
  477.  
  478. C IF (IDIM.EQ.3) LV7WRK(ienr,1,4,I)= LV7WRK(ienr,1,4,I)
  479. C & + (SHPWRK(4,inode)*xpsi1)
  480. c valeur de PHI au inode^ieme noeud
  481. xphi1 = mlree1.PROG(NBNN1+inode)
  482. else
  483. xphi1 = mlree1.PROG(inode)
  484. endif
  485. do 2524 jj=1,IDIM1
  486. LV7WRK(ienr,2,jj,I)= LV7WRK(ienr,2,jj,I)
  487. & + (SHPWRK(jj,inode)*xphi1)
  488. C IF (IDIM.EQ.3) LV7WRK(ienr,2,4,I)= LV7WRK(ienr,2,4,I)
  489. C & + (SHPWRK(4,inode)*xphi1)
  490. 2524 continue
  491. 2522 continue
  492.  
  493. 2521 continue
  494. ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc
  495.  
  496.  
  497. 2520 CONTINUE
  498. ccccc fin de BOUCLE SUR LES enrichissements cccccccccccccccc
  499.  
  500. c on a construit
  501. C LV7WRK(ienr, PSI/PHI, valeur/deriveeparqsi/pareta, iNOEUD)
  502.  
  503.  
  504. c*********************************************************
  505. c Ajout des fonctions de forme d enrichissement
  506. c + leurs derivees dans repere global
  507. c*********************************************************
  508. CALL SHAPX(MELE,LV7WRK,NBENRMAX,NBENRJ,TLREEL,SHPWRK,IRET)
  509.  
  510.  
  511. c retour a la partie commune aux EF enrichi et non enrichi
  512. 2999 continue
  513.  
  514. C*********************************************************
  515. C CALCUL DE B
  516. C*********************************************************
  517. c ZERO ne serait-il pas facultatif?
  518. c call ZERO(BGENE,LHOOK,NLIGRP)
  519. KB=1
  520. C boucle sur tous les Ni
  521. DO 3001 II=1,NBNI
  522.  
  523. BGENE(1,KB) = SHPWRK(2,II)
  524. BGENE(2,KB+1) = SHPWRK(3,II)
  525. BGENE(4,KB) = SHPWRK(3,II)
  526. BGENE(4,KB+1) = SHPWRK(2,II)
  527.  
  528. IF(IDIM.EQ.3) THEN
  529. BGENE(3,KB+2)=SHPWRK(4,II)
  530. BGENE(5,KB)=SHPWRK(4,II)
  531. BGENE(5,KB+2)=SHPWRK(2,II)
  532. BGENE(6,KB+1)=SHPWRK(4,II)
  533. BGENE(6,KB+2)=SHPWRK(3,II)
  534. ENDIF
  535.  
  536. KB = KB + IDIM
  537.  
  538. 3001 CONTINUE
  539. C
  540. c
  541. C*********************************************************
  542. C CALCUL DE sigma
  543. C*********************************************************
  544. MPTVAL = IVASTR
  545. DO 3200 ICOMP=1,LHOOK
  546. MELVAL = IVAL(ICOMP)
  547. IGMN = MIN(KGAU,VELCHE(/1))
  548. IBMN = MIN(J ,VELCHE(/2))
  549. XSTRS(ICOMP) = VELCHE(IGMN,IBMN)
  550. * XSTRS(ICOMP) = VELCHE(KGAU,J)
  551. 3200 CONTINUE
  552.  
  553.  
  554. C*********************************************************
  555. C CALCUL DE Fint = B^T * sigma
  556. C*********************************************************
  557. c
  558. CALL ZERO(XFORC,1,NLIGRP)
  559. CALL BSIG(BGENE,XSTRS,LHOOK,NLIGRP,DJAC,XFORC)
  560. c
  561. * rem: matrice d'efficacite presente dans bsigm1.eso non copiée ici
  562. c
  563. c cumul
  564. do ii = 1,NLIGRP
  565. XFINC(ii) = XFINC(ii) + XFORC(ii)
  566. enddo
  567. c
  568. c
  569. 2500 CONTINUE
  570. C FIN DE BOUCLE SUR LES POINTS DE GAUSS <<<<<<<<<<<<<<
  571. C
  572. C
  573. C EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  574. C ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  575. C
  576. NFOFO=NFOR
  577. IF (IIPDPG.GT.0) THEN
  578. IF (IFOUR.EQ.-3) THEN
  579. NFOFO=NFOR-3
  580. ADPG=ADPG+XFINC(NBNN1*NFOFO+1)
  581. BDPG=BDPG+XFINC(NBNN1*NFOFO+2)
  582. CDPG=CDPG+XFINC(NBNN1*NFOFO+3)
  583. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  584. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  585. NFOFO=NFOR-1
  586. ADPG=ADPG+XFINC(NBNN1*NFOFO+1)
  587. ELSE IF (IFOUR.EQ.11) THEN
  588. NFOFO=NFOR-2
  589. ADPG=ADPG+XFINC(NBNN1*NFOFO+1)
  590. BDPG=BDPG+XFINC(NBNN1*NFOFO+2)
  591. ENDIF
  592. ENDIF
  593. C
  594. C ON RANGE XFORC DANS le bon MELVAL
  595. c car plusieurs fois la meme composante dans ivafor pour créer des zones
  596. C
  597. MPTVAL = IVAFOR
  598. INITOT = 0
  599. C-->> BOUCLE SUR LES niveaux d'ENRICHISSEMENTS (0:U 1:A 2:BCDE1 3:BCDE2)
  600. DO IENR=0,NBENRJ
  601. *nbre de fonction(s) de ce niveau d'enrichissement (=1 si std ou H, =4 pour F1,2,...)
  602. if(IENR .le. 1) then
  603. NBNIENR = 1
  604. else
  605. NBNIENR = 4
  606. endif
  607. C---->> BOUCLE SUR LES fonctions de forme de ce type d'enrichissement
  608. DO INI=1,NBNIENR
  609. INITOT = INITOT + 1
  610. C------>> BOUCLE SUR LA DIMENSION
  611. DO KDIM=1,IDIM
  612. ICOMP = (INITOT-1)*IDIM + KDIM
  613. c MELVAL = IVAL(ICOMP)
  614. MELVAL = IVAL(NCUMUL1+ICOMP)
  615. C---------->> BOUCLE SUR LES NOEUDS
  616. DO I=1,NBNN1
  617. IQ = ((INITOT-1)*NBNN1*IDIM) + ((I-1)*IDIM) + KDIM
  618. * IBMN=MIN(IB ,VELCHE(/2))
  619. * VELCHE(KGAU,IBMN) = XFINC(IQ)
  620. VELCHE(I,J1) = XFINC(IQ)
  621. ENDDO
  622. ENDDO
  623. ENDDO
  624. ENDDO
  625. c
  626. c
  627. c
  628. 2000 CONTINUE
  629. C FIN DE BOUCLE SUR LES ELEMENTS <<<<<<<<<<<<<<<<<<<<<
  630. c
  631. c
  632.  
  633. C*********************************************************
  634. C SUPPRESSION ET DESACTIVATION DE SEGMENTS
  635. C*********************************************************
  636. C
  637. SEGSUP,WRK1,WRK2
  638. SEGSUP,MRACC
  639.  
  640. c
  641. c ajustement avant retour des MELVAL contenus dans IVAFOR
  642. c en focntion de la géométrie créée
  643. MPTVAL = IVAFOR
  644. do 3000 ienr1=0,NBENR1
  645. IPT1 = IPOS(1+ienr1)
  646. if(IPT1.eq.0) goto 3000
  647. N1PTEL = IPT1.NUM(/1)
  648. N1EL = IPT1.NUM(/2)
  649. N2PTEL = 1
  650. N2EL = 1
  651. NCUMUL1= NCOMPCUM(1+ienr1)
  652. NCOMP2 = NSOF(1+ienr1)
  653. c write(6,*) '=======ienr1=',ienr1,'/',NBENR1,'======'
  654. c write(6,*) 'de dim geo=',N1PTEL,N1EL
  655. c write(6,*) 'avec',NCOMP2,'composantes apres lindice',NCUMUL1
  656. do icomp2=1,NCOMP2
  657. MELVA2 = IVAL(NCUMUL1+icomp2)
  658. c write(6,*) MELVA2,'=',(MELVA2.VELCHE(iou,N1EL),iou=1,4)
  659. if(MELVA2.ne.0) segadj,MELVA2
  660. enddo
  661. 3000 continue
  662.  
  663. END
  664.  
  665.  
  666.  

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