Télécharger fsurma.eso

Retour à la liste

Numérotation des lignes :

fsurma
  1. C FSURMA SOURCE MB234859 25/09/08 21:15:31 12358
  2.  
  3. SUBROUTINE FSURMA(IPMODL,IPCHPS,IPVECT,JPMAIL,IPCARA, IPFTP)
  4.  
  5. C_______________________________________________________________________
  6. C
  7. C CALCULE LES FORCES SURFACIQUES APPLIQUEES SUR DES MASSIFS
  8. C
  9. C ENTREES :
  10. C ---------
  11. C
  12. C IPMODL OBJET MODELE SUR LEQUEL S APPLIQUE LA FORCE
  13. C IPCHPS CHPOINT CONTENANT LES VALEURS DES FORCES AUX NOEUDS
  14. C DE LA FACE D UN MASSIF, SINON 0 (ET IPVECT NON NUL)
  15. C IPVECT VECTEUR REPRESENTANT LA FORCE (=0 SI IPCHPS NON NUL)
  16. C JPMAIL POINTEUR SUR LE MAILLAGE SI ON A LU UN VECTEUR IPVECT
  17. C SINON 0 (IPCHPS NON NUL)
  18. C IPCARA MCHAML CONTENANT LES CARACTERISTIQUES UTILES
  19. C
  20. C SORTIES :
  21. C ----------
  22. C
  23. C IPFTP = CHPOINT DES FORCES NODALES EQUIVALENTES
  24. C 0 EN CAS D'ERREUR (IERR peut alors etre non nulle)
  25. C
  26. C_______________________________________________________________________
  27.  
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC CCHAMP
  34.  
  35. -INC SMCHAML
  36. -INC SMCHPOI
  37. -INC SMCOORD
  38. -INC SMELEME
  39. -INC SMINTE
  40. -INC SMMODEL
  41.  
  42. -INC TMPTVAL
  43.  
  44. SEGMENT NOTYPE
  45. CHARACTER*16 TYPE(NBTYPE)
  46. ENDSEGMENT
  47.  
  48. DIMENSION VEC(3),IPT(3)
  49. CHARACTER*(LOCOMP) mfors(3)
  50. CHARACTER*4 MOSTRI,MOAPPU,MOGEOM
  51. CHARACTER*8 MOT
  52. CHARACTER*(NCONCH) CONM
  53. PARAMETER (NINF=3)
  54. DIMENSION INFOS(NINF)
  55.  
  56. PARAMETER (INTYPC = 3)
  57.  
  58. LOGICAL ltelq,lsupfo
  59.  
  60. DATA MOAPPU /'APPU'/, MOSTRI /'STRI'/, MOGEOM /'GEOM'/
  61. DATA MOT/'FORCES'/
  62.  
  63. C= LEFMAS Liste des numeros d'elements finis faces de MASSIFs
  64. C= NEFMAS Longueur de cette liste
  65. PARAMETER ( NEFMAS = 6 )
  66. DIMENSION LEFMAS(NEFMAS)
  67. C ============
  68. C Elements MASSIFs SEG2 SEG3 TRI3 QUA4 TRI6 QUA8
  69. DATA LEFMAS / 2, 3, 31, 32, 33, 34 /
  70. *
  71. * 0) QUELQUES INITIALISATIONS
  72. *
  73. IPFTP = 0
  74. MFR = 0
  75. NHRM = NIFOUR
  76. C= Composantes du CHPOINT IPCHPS a retenir (si besoin)
  77. IF (IFOMOD.EQ.2) THEN
  78. nfors = 3
  79. mfors(1) = 'FX '
  80. mfors(2) = 'FY '
  81. mfors(3) = 'FZ '
  82. ELSE IF (IFOMOD.EQ.-1) THEN
  83. nfors = 2
  84. mfors(1) = 'FX '
  85. mfors(2) = 'FY '
  86. mfors(3) = ' '
  87. ELSE IF (IFOMOD.EQ.0) THEN
  88. nfors = 2
  89. mfors(1) = 'FR '
  90. mfors(2) = 'FZ '
  91. mfors(3) = ' '
  92. ELSE IF (IFOMOD.EQ.1) THEN
  93. nfors = 3
  94. mfors(1) = 'FR '
  95. mfors(2) = 'FZ '
  96. mfors(3) = 'FT '
  97. ELSE
  98. CALL ERREUR(21)
  99. RETURN
  100. ENDIF
  101. C Cas des modes de calculs en DEFORMATIONS GENERALISEES
  102. IF (IFOUR.EQ.-3) THEN
  103. NDPGE = 3
  104. ELSE IF (IFOUR.EQ.11) THEN
  105. NDPGE = 2
  106. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR.
  107. & IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  108. NDPGE = 1
  109. ELSE
  110. NDPGE = 0
  111. ENDIF
  112. *
  113. * ON RECUPERE LES COORDONNEES DU VECTEUR FORCE CONSTANT SI DONNE
  114. * TEST SI LE VECTEUR N'EST PAS NUL
  115. *
  116. IF (IPVECT.NE.0) THEN
  117. IREF = (IPVECT-1)*(IDIM+1)
  118. VEC(1) = XCOOR(IREF+1)
  119. VEC(2) = XCOOR(IREF+2)
  120. VECN = VEC(1)**2 + VEC(2)**2
  121. IF (IDIM.EQ.3) THEN
  122. VEC(3) = XCOOR(IREF+3)
  123. VECN = VECN + VEC(3)**2
  124. ENDIF
  125. C* VECN = SQRT(VECN)
  126. IF (VECN.LE.0.D0) THEN
  127. CALL ERREUR(277)
  128. RETURN
  129. ENDIF
  130. ELSE
  131. VEC(1) = 0.D0
  132. VEC(2) = 0.D0
  133. VEC(3) = 0.D0
  134. ENDIF
  135. C
  136. C ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS DU CHPOINT DE
  137. C FORCES IPCHPS S'IL EST FOURNI SINON ON SE SERVIRA DE JPMAIL
  138. C CE MAILLAGE SERA POINTE PAR LA VARIABLE IGEOM DANS LA SUITE
  139. C
  140. IF (JPMAIL.EQ.0) THEN
  141. IGEOM = 0
  142. ltelq = .false.
  143. MCHPOI = IPCHPS
  144. DO i = 1,IPCHP(/1)
  145. MSOUPO = IPCHP(i)
  146. NC = NOCOMP(/2)
  147. DO j = 1, NC
  148. CALL PLACE(mfors,nfors,imo,NOCOMP(j))
  149. IF (imo.NE.0) THEN
  150. IF (IGEOM.EQ.0) THEN
  151. IGEOM = IGEOC
  152. ELSE
  153. IPP2 = IGEOC
  154. CALL FUSE(IGEOM,IPP2,IPPT,ltelq)
  155. IF (IERR.NE.0) RETURN
  156. IGEOM = IPPT
  157. ENDIF
  158. GOTO 10
  159. ENDIF
  160. ENDDO
  161. 10 CONTINUE
  162. ENDDO
  163. IF (IGEOM.EQ.0) THEN
  164. CALL ERREUR(21)
  165. RETURN
  166. ENDIF
  167. ELSE
  168. IGEOM = JPMAIL
  169. ENDIF
  170. C
  171. C PRE-TRAITEMENT DES DONNEES :
  172. C - PETIT MODELE UTILE ASSOCIE A LA SURFACE ELEMENTAIRE TRAITEE
  173. C LE IMODEL EST MODIFIE PAR AJUSTEMENT DES QUE NECESSAIRE
  174. C
  175. N1 = 1
  176. SEGINI,MMODE1
  177. IPMOD1 = MMODE1
  178. NFOR = 0
  179. NMAT = 0
  180. MN3 = 1
  181. NOBMOD = 0
  182. SEGINI,IMODE1
  183. IMODE1.CMATEE = 'ISOTROPE'
  184. MMODE1.KMODEL(1) = IMODE1
  185. C
  186. C PRE-TRAITEMENT DU CHAMP DE CARACTERISTIQUES SI NECESSAIRE
  187. C - VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  188. C - DEFINITION DE SEGMENTS UTILES
  189. C
  190. ISUPCA = 0
  191. MOCARA = 0
  192. MOTYPC = 0
  193. NCARA = 0
  194. NCARF = 0
  195.  
  196. NBTYPE = 1
  197. SEGINI,NOTYPE
  198. TYPE(1) = 'REAL*8'
  199. MOTYPC = NOTYPE
  200. C
  201. IF (IFOUR.EQ.-2) THEN
  202. IF (IPCARA.NE.0) THEN
  203. C
  204. CALL QUESUP(IPMODL,IPCARA,INTYPC,1,ISUPCA,iret)
  205. IF (IERR.NE.0 .OR. ISUPCA.GT.1) GOTO 900
  206. C
  207. NBROBL = 0
  208. NBRFAC = 1
  209. SEGINI,NOMID
  210. LESFAC(1) = 'DIM3'
  211. MOCARA = NOMID
  212. C
  213. NCARA = NBROBL
  214. NCARF = NBRFAC
  215. ENDIF
  216. ENDIF
  217. C
  218. NCARR = NCARA + NCARF
  219. C
  220. C------------------------------------------- BOUCLE sur les SOUS-MODELES
  221. C
  222. MMODEL = IPMODL
  223. NSOUS = KMODEL(/1)
  224. IRRT = 0
  225. C
  226. DO 100 ISOUS = 1, NSOUS
  227. C
  228. C ... ON RECUPERE L INFORMATION GENERALE
  229. C
  230. IMODEL = KMODEL(ISOUS)
  231. C
  232. C TRAITEMENT DU SOUS-MODELE
  233. C
  234. IPMAIL= IMAMOD
  235. MELM = NEFMOD
  236. CONM = CONMOD
  237. C
  238. IF (MELM.EQ.22) GOTO 101
  239. C
  240. IVACAR = 0
  241. IVAFOR = 0
  242. lsupfo = .FALSE.
  243. IPTINT = 0
  244. C
  245. C ... ON RECUPERE L'"ENVELOPPE" DU MAILLAGE MASSIF DU SOUS-MODELE
  246. C
  247. CALL ECROBJ('MAILLAGE',IPMAIL)
  248. IF (IDIM.EQ.3) THEN
  249. CALL ENVELO
  250. ELSE IF (IDIM.EQ.2) THEN
  251. CALL PRCONT
  252. c* ELSE IF (IDIM.EQ.1) THEN
  253. ELSE
  254. CALL PREX1D
  255. ENDIF
  256. IF (IERR.NE.0) GOTO 101
  257. CALL LIROBJ('MAILLAGE',ienvel,1,iret)
  258. IF (IERR.NE.0) GOTO 101
  259. C
  260. C ... SI le CHPOINT de force IPCHPS a ete donne, on cherche la partie de
  261. C l'"enveloppe" s'appuyant strictement sur le support du CHPOINT.
  262. C ... SINON on cherche l'intersection entre l'enveloppe et JPMAIL=IGEOM.
  263. C
  264. IF (JPMAIL.EQ.0) THEN
  265. CALL ECROBJ('MAILLAGE',IGEOM)
  266. CALL ECRCHA(MOSTRI)
  267. CALL ECRCHA(MOAPPU)
  268. CALL ECROBJ('MAILLAGE',ienvel)
  269. CALL EXTREL(irr,0,iret)
  270. ELSE
  271. CALL INTERB(ienvel,IGEOM,irr,IPT3)
  272. ENDIF
  273. C
  274. C ... ON N'A PAS TROUVE D'ELEMENTS COMMUNS A IGEOM ET A IPMAIL
  275. C (IPMAIL = "ENVELOPPE" DU MAILLAGE DU SOUS-MODELE IMODEL)
  276. C
  277. IF (irr.GT.0) GOTO 101
  278. C
  279. C ... On recupere les elements communs a IGEOM et IPMAIL -> IPT3 !
  280. C
  281. IF (JPMAIL.EQ.0) THEN
  282. CALL LIROBJ('MAILLAGE',IPT3,1,iret)
  283. CALL ACTOBJ('MAILLAGE',IPT3,1)
  284. IF (IERR.NE.0) GOTO 101
  285. ENDIF
  286. C
  287. C RECHERCHE DES NOMS DE COMPOSANTES
  288. C
  289. IF (lnomid(2).NE.0) THEN
  290. MOFORC = lnomid(2)
  291. ELSE
  292. lsupfo = .TRUE.
  293. CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFORF)
  294. endif
  295. nomid=MOFORC
  296. NFORC = lesobl(/2)
  297. NFORF = 0
  298. NCOMP = NFORC - NDPGE
  299. C
  300. C Mise a jour de IMODE1 avec les donnees necessaires de IMODEL
  301. C
  302. NFOR = FORMOD(/2)
  303. NMAT = MATMOD(/2)
  304. MN3 = INFMOD(/1)
  305. SEGADJ,IMODE1
  306. IMODE1.CONMOD = CONM
  307. DO i = 1, NFOR
  308. IMODE1.FORMOD(i) = FORMOD(i)
  309. ENDDO
  310. DO i = 1, NMAT
  311. IMODE1.MATMOD(i) = MATMOD(i)
  312. ENDDO
  313. DO i = 1, MN3
  314. IMODE1.INFMOD(i) = INFMOD(i)
  315. ENDDO
  316. C
  317. C ON DETERMINE LA FORMULATION ASSOCIEE A L OBJET
  318. C GEOMETRIQUE ELEMENTAIRE DE SURFACE
  319. C
  320. MJB = IPT3.LISOUS(/1)
  321. IPT2 = IPT3
  322. C
  323. C BOUCLE SUR LES SOUS-ZONES DE LA PARTIE COMMUNE
  324. C
  325. DO 110 IB = 1,MAX(1,MJB)
  326. IRRT = IRRT + 1
  327. IF (MJB.NE.0) IPT2 = IPT3.LISOUS(IB)
  328. IPOGEO = IPT2
  329. NBEL = IPT2.NUM(/2)
  330. NBNN = IPT2.NUM(/1)
  331. LETYP = IPT2.ITYPEL
  332. *
  333. * PETIT TEST SUR LE TYPE
  334. *
  335. IF (LETYP.EQ.1 .AND. IDIM.NE.1) THEN
  336. CALL ERREUR(16)
  337. GOTO 102
  338. ENDIF
  339. *
  340. CALL TYPFAC(MELM,NBNN,MELE)
  341. C
  342. C ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR FSUR POUR
  343. C LES ELEMENTS DE FORMULATION MELM
  344. C
  345. IF (MELE.EQ.0) THEN
  346. MOTERR(1:8) = NOMTP(MELM)
  347. CALL ERREUR(193)
  348. GOTO 102
  349. ENDIF
  350. * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  351. imo = 0
  352. CALL PLACE2(LEFMAS,NEFMAS,imo,MELE)
  353. IF (imo.EQ.0) THEN
  354. MOTERR(1:4) = NOMTP(MELE)
  355. MOTERR(5:12)='FSURMA '
  356. CALL ERREUR(86)
  357. GOTO 102
  358. ENDIF
  359. C
  360. C ON CREE L OBJET MODEL ASSOCIE A LA SURFACE ELEMENTAIRE
  361. C
  362. IMODE1.IMAMOD=IPOGEO
  363. IMODE1.NEFMOD=MELE
  364. C
  365. C INFORMATION SUR L'ELEMENT FINI
  366. C
  367. CALL PRQUOI(IMODE1)
  368. IF (IERR.NE.0) GOTO 102
  369. IPTINT=IMODE1.INFELE(11)
  370. MFR =IMODE1.INFELE(13)
  371. IPPORE=0
  372. IF (MFR.EQ.33) IPPORE=NBNN
  373. C
  374. MINTE=IPTINT
  375. *
  376. * ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML
  377. *
  378. IPCHMS = 0
  379. IPT(1) = 0
  380. IPT(2) = 0
  381. IPT(3) = 0
  382. IF (IPCHPS.NE.0) THEN
  383. c* IF (IPVECT.EQ.0) THEN <- Test equivalent
  384. CALL CHAME1(0,IPMOD1,IPCHPS,' ',IPCHMS,1)
  385. IF (IERR.NE.0) GOTO 102
  386. MCHEL1 = IPCHMS
  387. * On ne doit avoir qu'une zone !
  388. IF (MCHEL1.ICHAML(/1).NE.1) THEN
  389. WRITE(IOIMP,*) 'Contacter le support (FSURMA 402)'
  390. CALL ERREUR(21)
  391. GOTO 102
  392. ENDIF
  393. MCHAM1 = MCHEL1.ICHAML(1)
  394. DO 15 i = 1, MCHAM1.NOMCHE(/2)
  395. CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i))
  396. IF (imo.NE.0) THEN
  397. IPT(imo) = MCHAM1.IELVAL(i)
  398. c* segment active et desactive dans FSMA.D (ci-dessous)
  399. c* MELVA1 = IPT(imo)
  400. c* SEGACT,MELVA1
  401. ENDIF
  402. 15 CONTINUE
  403. ENDIF
  404. C
  405. C INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  406. C
  407. N1=1
  408. L1=6
  409. N3=6
  410. SEGINI MCHELM
  411. TITCHE='FORCES'
  412. IFOCHE=IFOUR
  413. IPCHEL=MCHELM
  414. C
  415. IMACHE(1)=IPOGEO
  416. INFCHE(1,1)=0
  417. INFCHE(1,2)=0
  418. INFCHE(1,3)=NHRM
  419. INFCHE(1,4)=IPTINT
  420. INFCHE(1,5)=0
  421. INFCHE(1,6)=INTYPC
  422. C
  423. C RECHERCHE DE LA TAILLE DES MELVALS
  424. C
  425. N1PTEL=NBNN
  426. N1EL =NBEL
  427. N2PTEL=0
  428. N2EL =0
  429. C
  430. C CREATION DU MCHAML DE LA SOUS ZONE
  431. C
  432. N2 = NCOMP
  433. SEGINI,MCHAML
  434. ICHAML(1)=MCHAML
  435. NSR = 1
  436. NCOSOR = NCOMP
  437. SEGINI,MPTVAL
  438. IVAFOR=MPTVAL
  439. NOMID=MOFORC
  440. DO ICOMP=1,NCOMP
  441. NOMCHE(ICOMP)=LESOBL(ICOMP)
  442. TYPCHE(ICOMP)='REAL*8'
  443. SEGINI,MELVAL
  444. IELVAL(ICOMP)=MELVAL
  445. IVAL(ICOMP)=MELVAL
  446. ENDDO
  447. *
  448. *____________________________________________________________________
  449. *
  450. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  451. *____________________________________________________________________
  452. *
  453. IF (MOCARA.NE.0) THEN
  454. *
  455. * CREATION DU TABLEAU INFOS
  456. *
  457. CALL IDENT (IPMAIL,CONM,IPCARA,0,INFOS,IRTD)
  458. IF (IRTD.EQ.0) THEN
  459. SEGSUP MCHELM
  460. RETURN
  461. ENDIF
  462. *
  463. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPC,0,
  464. & INFOS,3,IVACAR)
  465. IF (IERR.NE.0) GOTO 9100
  466. *
  467. IF (ISUPCA.EQ.1) THEN
  468. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  469. ENDIF
  470. *
  471. ENDIF
  472. C
  473. C CALCUL DES FORCES NODALES EQUIVALENTES
  474. C BRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  475. C
  476. C CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS
  477. C FACES ASSOCIEES SEG2 OU SEG3
  478. C
  479. IF (MELE.EQ.2 .OR. MELE.EQ.3) THEN
  480. C
  481. CALL FSMA2D(IPT,IPOGEO,IPTINT,IPVECT,VEC,IVAFOR,IVACAR)
  482. C
  483. C CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS
  484. C FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8
  485. C
  486. ELSE IF (MELE.EQ.31 .OR. MELE.EQ.32 .OR. MELE.EQ.33 .OR.
  487. & MELE.EQ.34) THEN
  488. C
  489. CALL FSMA3D(IPT,IPOGEO,IPTINT,IPVECT,VEC,IVAFOR)
  490. C
  491. ELSE
  492. C
  493. C ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  494. C
  495. GOTO 9100
  496. ENDIF
  497. C
  498. C ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  499. C ET ON ADDITIONNE LES CHAM/POIN ELEMENTAIRES
  500. C
  501. CALL CHAMPO(IPCHEL,0,IPCHPO,IRET)
  502. C* CALL DTCHAM(IPCHEL)
  503. IF (IRET.EQ.0) THEN
  504. GOTO 9100
  505. ENDIF
  506. IF (IRRT.GT.1) THEN
  507. CALL ADCHPO(IPCHPO,IPFTP,IPPT,1.D0,1.D0)
  508. **** CALL ECRCHA(MOGEOM)
  509. CALL DTCHPO(IPCHPO)
  510. **** CALL ECRCHA(MOGEOM)
  511. CALL DTCHPO(IPFTP)
  512. IF (IPPT.EQ.0) THEN
  513. GOTO 9100
  514. ENDIF
  515. IPFTP=IPPT
  516. ELSE
  517. IPFTP=IPCHPO
  518. ENDIF
  519.  
  520. 9100 CONTINUE
  521. c* CALL DTMVAL(IVAFOR,3)
  522. IF (MOCARA.NE.0) THEN
  523. IF (ISUPCA.EQ.1) THEN
  524. CALL DTMVAL(IVACAR,3)
  525. ELSE
  526. CALL DTMVAL(IVACAR,1)
  527. ENDIF
  528. ENDIF
  529.  
  530. 110 CONTINUE
  531.  
  532. 102 CONTINUE
  533. nomid = MOFORC
  534. IF (lsupfo) SEGSUP,nomid
  535. 101 CONTINUE
  536. IF (IERR.NE.0) GOTO 900
  537.  
  538. 100 CONTINUE
  539. *--------------------------------- FIN de la BOUCLE sur les SOUS-MODELES
  540.  
  541. IF (IRRT.EQ.0) THEN
  542. IPFTP = 0
  543. CALL ERREUR(395)
  544. c GOTO 900
  545. ENDIF
  546. C
  547. C GESTION FINALE DES SEGMENTS
  548. C
  549. 900 CONTINUE
  550. NOMID = MOCARA
  551. IF (MOCARA.NE.0) SEGSUP,NOMID
  552. NOTYPE = MOTYPC
  553. SEGSUP,NOTYPE
  554.  
  555. SEGSUP,IMODE1,MMODE1
  556.  
  557. c RETURN
  558. END
  559.  
  560.  
  561.  
  562.  

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