Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes :

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

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