Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes :

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

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