Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes :

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

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