Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes :

  1. C FPMASS SOURCE CB215821 19/07/30 21:16:31 10273
  2. SUBROUTINE FPMASS(IPCHE1,IPCHM1,IPMODL,IPTFP,JPMAIL,XP,IRET)
  3. C_____________________________________________________________________
  4. C
  5. C CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES MASSIFS
  6. C
  7. C ENTREES :
  8. C ---------
  9. C
  10. C IPCHE1 CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  11. C DE LA FACE D UN MASSIF
  12. C IPCHM1 CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. C DE LA FACE D UN MASSIF
  14. C IPMODL OBJET MODELE SUR LEQUEL S APPLIQUE LA PRESSION
  15. C
  16. C JPMAIL POINTEUR SUR LE MAILLAGE SI ON A LU UN FLOTTANT ET
  17. C UN MAILLAGE, SINON 0
  18. C
  19. C XP LA VALEUR DE LA PRESSION SI ON L'A LUE
  20. C
  21. C SORTIES :
  22. C ----------
  23. C
  24. C IPTFP = CHPOINT DES FORCES NODALES EQUIVALENTES
  25. C IRET = 1 OU 0 SUIVANT SUCCES OU NON
  26. C
  27. C REVISION JACQUELINE BROCHARD SEPTEMBRE 86
  28. C MISE A JOUR P VERPEAUX MAI 88
  29. C
  30. C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 17 09 90
  31. C_______________________________________________________________________
  32. C
  33. IMPLICIT INTEGER(I-N)
  34. IMPLICIT REAL*8(A-H,O-Z)
  35. INTEGER ISUP
  36. C
  37. -INC CCOPTIO
  38. -INC CCHAMP
  39. -INC SMCOORD
  40. -INC SMELEME
  41. -INC SMMODEL
  42. -INC SMCHAML
  43. -INC SMCHPOI
  44. -INC SMINTE
  45. -INC CCREEL
  46. C
  47. SEGMENT INFO
  48. INTEGER INFELL(JG)
  49. ENDSEGMENT
  50. C
  51. SEGMENT NOTYPE
  52. CHARACTER*16 TYPE(NBTYPE)
  53. ENDSEGMENT
  54. C
  55. SEGMENT MPTVAL
  56. INTEGER IPOS(NS) ,NSOF(NS)
  57. INTEGER IVAL(NCOSOU)
  58. CHARACTER*16 TYVAL(NCOSOU)
  59. ENDSEGMENT
  60. C
  61. segment netn(xcoor(/1)/(idim+1)+1)
  62. segment ietn(letn)
  63. C
  64.  
  65. DIMENSION V(3),F(3)
  66. CHARACTER*4 MOSTRI,MOAPPU,MOGEOM
  67. CHARACTER*(NCONCH) CONM
  68. PARAMETER (NINF=3)
  69. INTEGER INFOS(NINF)
  70. LOGICAL LSUPFO,ltelq
  71. CHARACTER*8 MOFO
  72. C
  73. DATA MOAPPU/'APPU'/,MOSTRI/'STRI'/
  74. DATA MOGEOM/'GEOM'/
  75. C
  76. ISUP = 0
  77. IRET = 0
  78. IGEOM = 0
  79. C
  80. IND=0
  81. IPCHE2=0
  82. NHRM=NIFOUR
  83. IPTVPR=0
  84. C
  85. C CAS OU UN CHPOP EST FOURNI
  86. C ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  87. C
  88. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  89. MCHPOI=IPCHE1
  90. DO 50 I=1,IPCHP(/1)
  91. MSOUPO=IPCHP(I)
  92. IF (I.GT.1) THEN
  93. ltelq=.false.
  94. CALL FUSE(IGEOM,IGEOC,IPPT,ltelq)
  95. IGEOM=IPPT
  96. ELSE
  97. IGEOM=IGEOC
  98. ENDIF
  99. 50 CONTINUE
  100. IF (IERR.NE.0) RETURN
  101. ENDIF
  102. C
  103. C CAS OU UN CHAMELEM EST FOURNI
  104. C ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  105. C
  106. IF(IPCHM1.NE.0) THEN
  107. MCHEL2 = IPCHM1
  108. DO 60 I=1,MCHEL2.IMACHE(/1)
  109. IMTMP=MCHEL2.IMACHE(I)
  110. IF (I.GT.1) THEN
  111. ltelq=.false.
  112. CALL FUSE(IGEOM,IMTMP,IPPT,ltelq)
  113. IGEOM=IPPT
  114. ELSE
  115. IGEOM=IMTMP
  116. ENDIF
  117. 60 CONTINUE
  118. IF (IERR.NE.0) RETURN
  119. ENDIF
  120. C
  121. C ACTIVATION DU MODEL
  122. C
  123. MMODEL=IPMODL
  124. NSOUS=KMODEL(/1)
  125.  
  126. idimp1=IDIM+1
  127. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  128. IF (IFOUR.EQ.-3) THEN
  129. NDPGE=3
  130. ELSE IF (IFOUR.EQ.11) THEN
  131. NDPGE=2
  132. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR.
  133. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  134. NDPGE=1
  135. ELSE
  136. NDPGE=0
  137. ENDIF
  138.  
  139. IRRT=0
  140. DO 100 ISOUS=1,NSOUS
  141. C
  142. C ON RECUPERE L INFORMATION GENERALE
  143. C
  144. IMODEL=KMODEL(ISOUS)
  145. IPMAIL=IMAMOD
  146. CONM =CONMOD
  147. C
  148. C TRAITEMENT DU MODEL
  149. C
  150. MOCARA = 0
  151. IVACAR = 0
  152. IVAFOR = 0
  153. C
  154. MELM=NEFMOD
  155. C write(*,*) ISOUS,'/',NSOUS,' : ',IMODEL,'NEFMOD=',MELM
  156. if ((melm . eq . 22).OR.(melm . eq . 259)) then
  157. C ... Ici sous modele de multiplicateur de lagrange on
  158. C incrémente le compteur et on passe à la zone suivante ...
  159. IRRT=IRRT+1
  160. go to 100
  161. endif
  162. C
  163. C ON RECUPERE LES ELTS DE L ENVELOPPE DU MASSIF APPUYES
  164. C STRICTEMENT SUR LE CHPOINT DE PRESSIONS OU appartenant au
  165. C MAILLAGE DONNE
  166. C
  167. CALL ECROBJ('MAILLAGE',IPMAIL)
  168. IF (IDIM.EQ.2) THEN
  169. CALL PRCONT
  170. ELSE IF (IDIM.EQ.3) THEN
  171. CALL ENVELO
  172. ELSE IF (IDIM.EQ.1) THEN
  173. CALL PREX1D
  174. ENDIF
  175. IF (IERR.NE.0) RETURN
  176. CALL LIROBJ('MAILLAGE',ienvel,1,IRETOU)
  177. IF (IERR .NE. 0) RETURN
  178. CALL ACTOBJ('MAILLAGE',ienvel,1)
  179. C ... si un CHPOINT a été donné, on va chercher la partie de
  180. C l'enveloppe s'appuyant strictement sur le support du CHPOINT ...
  181. IF(JPMAIL.EQ.0) THEN
  182. CALL ECROBJ('MAILLAGE',IGEOM)
  183. CALL ECRCHA(MOSTRI)
  184. CALL ECRCHA(MOAPPU)
  185. CALL ECROBJ('MAILLAGE',ienvel)
  186. CALL EXTREL (IRR,0,IBNOR)
  187. ELSE
  188. C ... sinon, on va chercher l'intersection de l'enveloppe avec
  189. C le maillage fourni ...
  190. CALL INTERB(ienvel,jpmail,irr,IPOGEO)
  191. ENDIF
  192. C ... Ici on teste si intersection est vide, si OUI on
  193. C incrémente le compteur et on passe à la zone suivante ...
  194. IF (irr.gt.0) THEN
  195. IRRT=IRRT+1
  196. GOTO 100
  197. ENDIF
  198. IF(JPMAIL.EQ.0) THEN
  199. CALL LIROBJ('MAILLAGE',IPOGEO,1,iret)
  200. IF (IERR.NE.0) RETURN
  201. CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  202. ENDIF
  203. C
  204. C ON DETERMINE LA FORMULATION ASSOCIEE A L OBJET
  205. C GEOMETRIQUE ELEMENTAIRE DE SURFACE
  206. C
  207. IPT3=IPOGEO
  208. IPT2=IPT3
  209. IB=0
  210. C
  211. C BOUCLE SUR LES SOUS ZONES DE L ENVELOPPE
  212. C
  213. DO 110 IB=1,MAX(1,IPT3.LISOUS(/1))
  214. IF (IPT3.LISOUS(/1).NE.0) THEN
  215. IPT2=IPT3.LISOUS(IB)
  216. IPOGEO=IPT2
  217. ENDIF
  218. NBNN =IPT2.NUM(/1)
  219. LETYP=IPT2.ITYPEL
  220. IF (IPT3.LISOUS(/1).EQ.0) GOTO 112
  221. C
  222. 112 CONTINUE
  223. C
  224. C PETIT TEST SUR LE TYPE
  225. C
  226. IF(LETYP.EQ.1.AND.IDIM.NE.1) THEN
  227. CALL ERREUR(16)
  228. GOTO 9997
  229. ENDIF
  230. C
  231. CALL TYPFAC(MELM,NBNN,MELE)
  232. C write(*,*) 'TYPFAC --> MELE=',MELE
  233. IF (MELE.EQ.0) THEN
  234. C
  235. C ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR PRESSI POUR
  236. C LES ELEMENTS DE FORMULATION MELM
  237. C
  238. MOTERR(1:8)=NOMTP(MELM)
  239. CALL ERREUR(193)
  240. GOTO 9997
  241. ENDIF
  242. C
  243. C CAS OU UN CHAMP PAR POINT A ETE FOURNI
  244. C ON CREE L OBJET MODEL ASSOCIE A LA SURFACE ELEMENTAIRE
  245. C
  246. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  247. N1=1
  248. SEGINI MMODE1
  249. IPMOD1=MMODE1
  250. NFOR=FORMOD(/2)
  251. NMAT=MATMOD(/2)
  252. MN3=0
  253. NPARMO=0
  254. nobmod=0
  255. SEGINI IMODE1
  256. MMODE1.KMODEL(1)=IMODE1
  257. IMODE1.IMAMOD=IPOGEO
  258. IMODE1.NEFMOD=MELE
  259. IMODE1.CONMOD=CONMOD
  260. DO 10 I=1,NFOR
  261. IMODE1.FORMOD(I)=FORMOD(I)
  262. 10 CONTINUE
  263. DO 11 I=1,NMAT
  264. IMODE1.MATMOD(I)=MATMOD(I)
  265. 11 CONTINUE
  266. C
  267. C ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM ELEMENTAIRE
  268. C
  269. CALL CHAME1(0,IPMOD1,IPCHE1,' ',ICHELP,3)
  270. IF (IERR.NE.0) THEN
  271. CALL DTMODL(IPMOD1)
  272. RETURN
  273. ENDIF
  274. MCHEL1=ICHELP
  275. MCHAM1=MCHEL1.ICHAML(1)
  276. IPTVPR=MCHAM1.IELVAL(1)
  277. ENDIF
  278. C
  279. C INFORMATION SUR L'ELEMENT FINI
  280. C
  281. CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  282. Cbp : on aurait voulu faire CALL ELQUOI(MELE,0,3,IPINF,IMODE1),
  283. C : mais cela ne marche evidemment pas bien...
  284. IF (IERR.NE.0) THEN
  285. IF(JPMAIL.EQ.0) CALL DTCHAM(ICHELP)
  286. IF(IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  287. GOTO 9997
  288. C RETURN
  289. ENDIF
  290. INFO=IPINF
  291. IPTINT=INFELL(11)
  292. MFR =INFELL(13)
  293. C*OF En DIMEnsion 1, on force FORMULATION MASSIVE pour POI1
  294. IF (IDIM.EQ.1.AND.MELE.EQ.45) MFR=1
  295. IPPORE=0
  296. IF(MFR.EQ.33) IPPORE=NBNN
  297. C Destruction immediate du segment
  298. SEGSUP,INFO
  299. C Caracteristiques d'integration
  300. MINTE=IPTINT
  301. C
  302. C CAS OU UN CHAMP PAR ELEMENT A ETE FOURNI
  303. C -> Verification de son support
  304. C
  305. IF (IPCHM1.NE.0) THEN
  306. CALL QUESUP(0,IPCHM1,0,0,ISUP1,ISUP2)
  307. MCHEL2=IPCHM1
  308. MCHAM2 = MCHEL2.ICHAML(1)
  309. IF (ISUP2.NE.3) THEN
  310. IF (ISUP2.EQ.4) THEN
  311. CALL ERREUR(609)
  312. GOTO 9997
  313. ELSE IF (ISUP2.EQ.5) THEN
  314. IPTVPR = MCHAM2.IELVAL(1)
  315. ELSE IF (ISUP2.EQ.1.OR.ISUP2.EQ.2) THEN
  316. IVPRES = MCHAM2.IELVAL(1)
  317. CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  318. ENDIF
  319. ELSE
  320. IPTVPR = MCHAM2.IELVAL(1)
  321. ENDIF
  322. ENDIF
  323. C
  324. C INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  325. C
  326. N1=1
  327. L1=6
  328. N3=5
  329. SEGINI MCHELM
  330. TITCHE='FORCES'
  331. IFOCHE=IFOUR
  332. IPCHEL=MCHELM
  333. C
  334. IMACHE(1)=IPOGEO
  335. INFCHE(1,1)=0
  336. INFCHE(1,2)=0
  337. INFCHE(1,3)=NHRM
  338. INFCHE(1,4)=IPTINT
  339. INFCHE(1,5)=0
  340. C
  341. C RECHERCHE DE LA TAILLE DES MELVALS
  342. C
  343. MELEME=IPOGEO
  344. N1PTEL=NUM(/1)
  345. N1EL =NUM(/2)
  346. N2PTEL=0
  347. N2EL =0
  348. C
  349. C RECHERCHE DES NOM DE COMPOSANTES
  350. C
  351. if(lnomid(2).ne.0) then
  352. nomid=lnomid(2)
  353. moforc=nomid
  354. nfor=lesobl(/2)
  355. nfac=0
  356. lsupfo=.false.
  357. C write(*,*) 'nomid deja existant dans IMODEL',IMODEL
  358. else
  359. lsupfo=.true.
  360. CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  361. C write(*,*) 'appel a IDFORC pour creer nomid'
  362. endif
  363. NCOMP=NFOR-NDPGE
  364. C** IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  365. C
  366. C CREATION DU MCHAML DE LA SOUS ZONE
  367. C
  368. N2=NCOMP
  369. SEGINI MCHAML
  370. ICHAML(1)=MCHAML
  371. NS=1
  372. NCOSOU=NCOMP
  373. SEGINI MPTVAL
  374. IVAFOR=MPTVAL
  375. NOMID=MOFORC
  376.  
  377. Cbp on verifie qu on a suffisamment de composantes d'effort
  378. NFO=0
  379. IF(MELE.EQ.2.OR.MELE.EQ.3) NFO=2
  380. IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.OR.MELE.EQ.34) NFO=3
  381. IF(MELE.EQ.45) NFO=1
  382. C IF(NFO.eq.0) --> erreur + tard
  383. IF(NFO.ne.0) THEN
  384. IF(NCOMP.lt.NFO) GOTO 444
  385. DO 44 ICOMP=1,NFO
  386. MOFO=LESOBL(ICOMP)
  387. IF(MOFO(1:1).NE.'F') GOTO 444
  388. 44 CONTINUE
  389. C pas d'erreur ?
  390. GOTO 440
  391. C -erreur
  392. 444 CONTINUE
  393. WRITE(IOIMP,*) 'on attend un MODELE avec au moins',NFO,
  394. & 'composantes de FORCES !'
  395. write(IOIMP,*) 'Ici, on a :',(LESOBL(iou),iou=1,NCOMP)
  396. MOTERR(1:16)='MECANIQUE, ... '
  397. CALL ERREUR(719)
  398. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  399. GOTO 9990
  400. C -pas d'erreur
  401. 440 CONTINUE
  402. ENDIF
  403.  
  404. DO 4 ICOMP=1,NCOMP
  405. NOMCHE(ICOMP)=LESOBL(ICOMP)
  406. TYPCHE(ICOMP)='REAL*8'
  407. SEGINI MELVAL
  408. IELVAL(ICOMP)=MELVAL
  409. IVAL(ICOMP)=MELVAL
  410. 4 CONTINUE
  411. C
  412. C____________________________________________________________________
  413. C
  414. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  415. C____________________________________________________________________
  416. C
  417. IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN
  418. CALL LIROBJ('MCHAML ',IPCHE2,0,IRT3)
  419. IND=1
  420. IF (IERR.NE.0) GOTO 9990
  421. IF(IRT3 .EQ. 1) CALL ACTOBJ('MCHAML ',IPCHE2,1)
  422. IF (IPCHE2.NE.0) THEN
  423. C
  424. C Verification du lieu support du MCHAML de caracteristique
  425. C
  426. CALL QUESUP(IPMODL,IPCHE2,3,1,ISUP,IRETCA)
  427. IF (ISUP.GT.1) GOTO 9990
  428. C
  429. C CREATION DU TABLEAU INFOS
  430. C
  431. CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  432. IF (IRTD.EQ.0) THEN
  433. SEGSUP MCHELM
  434. CALL DTCHAM(IPCHE2)
  435. RETURN
  436. ENDIF
  437. C
  438. NBROBL=0
  439. NBRFAC=1
  440. SEGINI NOMID
  441. MOCARA=NOMID
  442. LESFAC(1)='DIM3'
  443. C
  444. NBTYPE=1
  445. SEGINI NOTYPE
  446. MOTYPE=NOTYPE
  447. TYPE(1)='REAL*8'
  448. C
  449. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,0,
  450. + INFOS,3,IVACAR)
  451. SEGSUP NOTYPE
  452. IF (IERR.NE.0) GOTO 9990
  453. NCARA=NBROBL
  454. NCARF=NBRFAC
  455. NCARR=NCARA+NCARF
  456. C
  457. IF (ISUP.EQ.1) THEN
  458. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  459. ENDIF
  460. C
  461. ENDIF
  462. ENDIF
  463. C
  464. C CALCUL DES FORCES NODALES EQUIVALENTES
  465. C DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  466. C
  467. IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  468. C
  469. C CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS
  470. C FACES ASSOCIEES SEG2 OU SEG3
  471. C
  472. CALL FPMA2D(IPTVPR,IPOGEO,IPTINT,IVAFOR,IVACAR,XP)
  473. C
  474. ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  475. + OR.MELE.EQ.34)THEN
  476. C
  477. C CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS
  478. C FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8
  479. C
  480. CALL FPMA3D(IPTVPR,IPOGEO,IPTINT,IVAFOR,XP)
  481. C
  482. C= Cas des elements MASSIFs UNIDIMENSIONNELs (1D)
  483. C= Face associee : POI1 (numero 45)
  484. ELSE IF (MELE.EQ.45) THEN
  485. CALL FPMA1D(IPTVPR,IPOGEO,IPTINT,IVAFOR,XP)
  486.  
  487. ELSE
  488. C
  489. C ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  490. C
  491. MOTERR(1:4)=NOMTP(MELE)
  492. MOTERR(5:12)='FPMASS'
  493. CALL ERREUR (86)
  494. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  495. GOTO 9990
  496. ENDIF
  497. C
  498. C POUR CHAQUE ELEMENT,
  499. C ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF
  500. C A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSI
  501. C
  502. C prob optimiseur il faut initialiser melva1
  503. MELVA1=IPMODL
  504. IF(IPTVPR.NE.0) THEN
  505. MELVA1=IPTVPR
  506. ENDIF
  507. MELEME=IPOGEO
  508. IPT1=IPMAIL
  509. C
  510. C pour accelerer la recherche, utilisation d'un tableau des elements touchant un noeud.
  511. segact mcoord
  512. segini netn
  513. do 1050 j=1,ipt1.num(/2)
  514. do 1050 i=1,ipt1.num(/1)
  515. netn(ipt1.num(i,j))=netn(ipt1.num(i,j))+1
  516. 1050 continue
  517. do 1060 i=2,netn(/1)
  518. netn(i)=netn(i)+netn(i-1)
  519. 1060 continue
  520. letn=netn(netn(/1))
  521. segini ietn
  522. do 1070 j=1,ipt1.num(/2)
  523. do 1070 i=1,ipt1.num(/1)
  524. ietn(netn(ipt1.num(i,j)))=j
  525. netn(ipt1.num(i,j))=netn(ipt1.num(i,j))-1
  526. 1070 continue
  527.  
  528. DO 150 IEF=1,NUM(/2)
  529. do 160 inf=1,num(/1)
  530. ip=num(inf,ief)
  531. id=netn(ip)+1
  532. if=netn(ip+1)
  533. do 165 itn=id,if
  534. iem=ietn(itn)
  535. jne=0
  536. do 166 i0=1,num(/1)
  537. do 166 i1=1,ipt1.num(/1)
  538. if (num(i0,ief).eq.ipt1.num(i1,iem)) jne=jne+1
  539. 166 continue
  540. if (jne.eq.num(/1)) goto 170
  541. 165 continue
  542. 160 continue
  543. CALL ERREUR(26)
  544. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  545. GOTO 9990
  546. 170 CONTINUE
  547. NBM=IPT1.NUM(/1)
  548. NBMA1=NUM(/1)
  549. IF (IDIM.EQ.3) THEN
  550. XG=0.D0
  551. YG=0.D0
  552. ZG=0.D0
  553. DO INM=1,NBM
  554. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  555. XG=XG+XCOOR(IREFM+1)
  556. YG=YG+XCOOR(IREFM+2)
  557. ZG=ZG+XCOOR(IREFM+3)
  558. ENDDO
  559. XG=XG/NBM
  560. YG=YG/NBM
  561. ZG=ZG/NBM
  562. XK=0.D0
  563. YK=0.D0
  564. ZK=0.D0
  565. DO INF=1,NBMA1
  566. IREFF=(NUM(INF,IEF)-1)*idimp1
  567. XK=XK+XCOOR(IREFF+1)
  568. YK=YK+XCOOR(IREFF+2)
  569. ZK=ZK+XCOOR(IREFF+3)
  570. ENDDO
  571. XK=XK/NBMA1
  572. YK=YK/NBMA1
  573. ZK=ZK/NBMA1
  574. V(1)=XG-XK
  575. V(2)=YG-YK
  576. V(3)=ZG-ZK
  577. VN=SQRT(V(1)**2+V(2)**2+V(3)**2)
  578. V(1)=V(1)/VN
  579. V(2)=V(2)/VN
  580. V(3)=V(3)/VN
  581. ELSE IF (IDIM.EQ.2) THEN
  582. XG=0.D0
  583. YG=0.D0
  584. DO INM=1,NBM
  585. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  586. XG=XG+XCOOR(IREFM+1)
  587. YG=YG+XCOOR(IREFM+2)
  588. ENDDO
  589. XG=XG/NBM
  590. YG=YG/NBM
  591. XK=0.D0
  592. YK=0.D0
  593. DO INF=1,NBMA1
  594. IREFF=(NUM(INF,IEF)-1)*idimp1
  595. XK=XK+XCOOR(IREFF+1)
  596. YK=YK+XCOOR(IREFF+2)
  597. ENDDO
  598. XK=XK/NBMA1
  599. YK=YK/NBMA1
  600. V(1)=XG-XK
  601. V(2)=YG-YK
  602. VN=SQRT(V(1)**2+V(2)**2)
  603. V(1)=V(1)/VN
  604. V(2)=V(2)/VN
  605. ELSE IF (IDIM.EQ.1) THEN
  606. XG=0.D0
  607. DO INM=1,NBM
  608. IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  609. XG=XG+XCOOR(IREFM+1)
  610. ENDDO
  611. XG=XG/NBM
  612. XK=0.D0
  613. DO INF=1,NBMA1
  614. IREFF=(NUM(INF,IEF)-1)*idimp1
  615. XK=XK+XCOOR(IREFF+1)
  616. ENDDO
  617. XK=XK/NBMA1
  618. V(1)=XG-XK
  619. VN=ABS(V(1))
  620. V(1)=V(1)/VN
  621. ENDIF
  622. C
  623. C ET ON ORIENTE LES FORCES NODALES APPLIQUEES SUR L ELEMENT
  624. C EN COMPARANT LES DIRECTIONS DE LA RESULTANTE DES FORCES ET DU VECTEUR
  625. C PUIS ON MULTIPLIE PAR LE SIGNE DE LA PRESSION
  626. C
  627. F(1)=0.D0
  628. F(2)=0.D0
  629. F(3)=0.D0
  630. MPTVAL=IVAFOR
  631. DO 200 INF=1,N1PTEL
  632. DO 201 J=1,IDIM
  633. MELVAL=IVAL(J)
  634. F(J)=F(J)+VELCHE(INF,IEF)
  635. 201 CONTINUE
  636. 200 CONTINUE
  637. FN2=0.D0
  638. TEST=0.D0
  639. DO 210 J=1,IDIM
  640. FN2=FN2 + F(J)**2
  641. TEST=TEST+ V(J)*F(J)
  642. 210 CONTINUE
  643. FN=SQRT(FN2)
  644. C
  645. C ERREUR IMPOSSIBLE D ORIENTER LES FORCES DE PRESSION
  646. C
  647. IF (ABS(TEST).LE.0.001D0*FN .AND.
  648. & FN.NE.0.D0) THEN
  649. CALL ERREUR(192)
  650. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  651. GOTO 9990
  652. ENDIF
  653. XFLOT=1.D0
  654. IF (TEST.LT.0.D0) XFLOT=-1.D0
  655. IF(IPTVPR.NE.0) THEN
  656. SP = SIGN(1.D0,MELVA1.VELCHE(1,IEF))
  657. ELSE
  658. SP = SIGN(1.D0,XP)
  659. ENDIF
  660. MPTVAL=IVAFOR
  661. DO 220 INF=1,N1PTEL
  662. DO 220 ICOMP=1,NCOMP
  663. MELVAL=IVAL(ICOMP)
  664. VELCHE(INF,IEF)=VELCHE(INF,IEF)*XFLOT*SP
  665. 220 CONTINUE
  666. 150 CONTINUE
  667. segsup netn,ietn
  668. C
  669. C ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  670. C ET ON ADDITIONNE LES CHAM/POIN ELEMENTAIRES
  671. C
  672. CALL CHAMPO(IPCHEL,0,IPCHPO,IPPT)
  673. CALL DTCHAM(IPCHEL)
  674. IF (IPPT.EQ.0) THEN
  675. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL (IPMOD1)
  676. GOTO 9990
  677. ENDIF
  678. IF ((ISOUS-IRRT).GT.1.OR.IB.GT.1) THEN
  679. CALL ADCHPO(IPCHPO,IPTFP,IPPT,1D0,1D0)
  680. C CALL ECRCHA(MOGEOM)
  681. CALL DTCHPO(IPCHPO)
  682. C CALL ECRCHA(MOGEOM)
  683. CALL DTCHPO(IPTFP)
  684. IF (IPPT.EQ.0) THEN
  685. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  686. GOTO 9990
  687. ENDIF
  688. IPTFP=IPPT
  689. ELSE
  690. IPTFP=IPCHPO
  691. ENDIF
  692. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  693. 110 CONTINUE
  694. NOMID=MOFORC
  695. if(lsupfo)SEGSUP NOMID
  696. IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTCHAM(ICHELP)
  697. C
  698. IF(ISUP.EQ.1.AND.IPCHE2.NE.0)THEN
  699. CALL DTMVAL(IVACAR,3)
  700. ELSE
  701. CALL DTMVAL(IVACAR,1)
  702. ENDIF
  703. NOMID=MOCARA
  704. IF (MOCARA.NE.0) SEGSUP NOMID
  705. C
  706. MPTVAL=IVAFOR
  707. SEGSUP MPTVAL
  708. C
  709. 100 CONTINUE
  710. IF(IRRT.EQ.KMODEL(/1)) THEN
  711. CALL ERREUR(395)
  712. ELSE
  713. IRET = 1
  714. ENDIF
  715. RETURN
  716. C
  717. 9990 CONTINUE
  718. C
  719. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  720. C
  721. CALL DTMVAL(IVAFOR,3)
  722. C
  723. IF(ISUP.EQ.1.AND.IPCHE2.NE.0)THEN
  724. CALL DTMVAL(IVACAR,3)
  725. ELSE
  726. CALL DTMVAL(IVACAR,1)
  727. ENDIF
  728. NOMID=MOCARA
  729. IF (MOCARA.NE.0) SEGSUP NOMID
  730. C
  731. SEGSUP MCHAML
  732. SEGSUP MCHELM
  733. C
  734. NOMID=MOFORC
  735. if(lsupfo)SEGSUP NOMID
  736.  
  737. 9997 CONTINUE
  738.  
  739. IRET = 0
  740.  
  741. END
  742.  
  743.  
  744.  

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