Télécharger fsurma.eso

Retour à la liste

Numérotation des lignes :

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

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