Télécharger fsurco.eso

Retour à la liste

Numérotation des lignes :

  1. C FSURCO SOURCE AM 16/04/12 21:15:49 8903
  2.  
  3. SUBROUTINE FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPTFP)
  4.  
  5. *_____________________________________________________________________
  6. *
  7. * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES
  8. *
  9. * ENTREES :
  10. * ---------
  11. *
  12. * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION
  13. * IPCHE1 CHPOINT CONTENANT LES VALEURS DES FORCES AUX NOEUDS
  14. * IPVECT VECTEUR INDIQUANT LA DIRECTION DANS LAQUELLE
  15. * S APPLIQUE LA FORCE SURFACIQUE
  16. *
  17. * SORTIES :
  18. * ---------
  19. *
  20. * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES
  21. *
  22. *_____________________________________________________________________
  23. *
  24. IMPLICIT INTEGER(I-N)
  25. IMPLICIT REAL*8(A-H,O-Z)
  26. *
  27. -INC CCOPTIO
  28. -INC CCHAMP
  29. *
  30. -INC SMCOORD
  31. -INC SMELEME
  32. -INC SMMODEL
  33. -INC SMCHAML
  34. -INC SMCHPOI
  35. -INC SMINTE
  36. *
  37. SEGMENT NOTYPE
  38. CHARACTER*16 TYPE(NBTYPE)
  39. ENDSEGMENT
  40. *
  41. SEGMENT MPTVAL
  42. INTEGER IPOS(NS) ,NSOF(NS)
  43. INTEGER IVAL(NCOSOU)
  44. CHARACTER*16 TYVAL(NCOSOU)
  45. ENDSEGMENT
  46. *
  47. PARAMETER (NINF=3)
  48. INTEGER INFOS(NINF)
  49.  
  50. DIMENSION V(3),ipt(3)
  51. CHARACTER*4 mfors(3)
  52. CHARACTER*(NCONCH) CONM
  53.  
  54. C= LEFCOQ Liste des numeros d'elements finis COQUEs
  55. C= NEFCOQ Longueur de cette liste
  56. PARAMETER ( NEFCOQ = 8 )
  57. DIMENSION LEFCOQ(NEFCOQ)
  58. C ============
  59. C Elements COQUEs COQ2 COQ3 COQ6 COQ4 COQ8 DKT POI1 DST
  60. DATA LEFCOQ / 44, 27, 56, 49, 41, 28, 45, 93 /
  61.  
  62. LOGICAL ltelq, lsupfo
  63. *
  64. * 0) QUELQUES INITIALISATIONS
  65. *
  66. IPTFP = 0
  67. NHRM = NIFOUR
  68. C= Composantes du CHPOINT IPCHPS a retenir (si besoin)
  69. IF (IFOMOD.EQ.2) THEN
  70. nfors = 3
  71. mfors(1) = 'FX '
  72. mfors(2) = 'FY '
  73. mfors(3) = 'FZ '
  74. ELSE IF (IFOMOD.EQ.-1) THEN
  75. nfors = 2
  76. mfors(1) = 'FX '
  77. mfors(2) = 'FY '
  78. mfors(3) = ' '
  79. ELSE IF (IFOMOD.EQ.0) THEN
  80. nfors = 2
  81. mfors(1) = 'FR '
  82. mfors(2) = 'FZ '
  83. mfors(3) = ' '
  84. ELSE IF (IFOMOD.EQ.1) THEN
  85. nfors = 3
  86. mfors(1) = 'FR '
  87. mfors(2) = 'FZ '
  88. mfors(3) = 'FT '
  89. ELSE
  90. CALL ERREUR(21)
  91. RETURN
  92. ENDIF
  93. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  94. IF (IFOUR.EQ.-3) THEN
  95. NDPGE = 3
  96. ELSE
  97. NDPGE = 0
  98. ENDIF
  99. *
  100. IPCHMS = 0
  101. IPCHMZ = 0
  102. *
  103. * 1) ON RECUPERE LES COORDONNEES DU VECTEUR CONSTANT (SI DONNE)
  104. *
  105. V(1) = 0.D0
  106. V(2) = 0.D0
  107. V(3) = 0.D0
  108. IF (IPVECT.NE.0) THEN
  109. IREF=(IPVECT-1)*(IDIM+1)
  110. V(1)=XCOOR(IREF+1)
  111. V(2)=XCOOR(IREF+2)
  112. VN = V(1)**2 + V(2)**2
  113. IF (IDIM.GE.3) THEN
  114. V(3)=XCOOR(IREF+3)
  115. VN=VN+V(3)**2
  116. ENDIF
  117. c* VN=SQRT(VN)
  118. IF (VN.LE.0.) THEN
  119. CALL ERREUR(277)
  120. RETURN
  121. ENDIF
  122. ENDIF
  123. *
  124. * 2) VERIFICATIONS DU CHAMP DE CARACTERISTIQUES SI FOURNI
  125. *
  126. IF (IPCARA.NE.0) THEN
  127. CALL QUESUP(IPMODL,IPCARA,3,0,ISUPCA,iret)
  128. IF (ISUPCA.GT.1) RETURN
  129. ENDIF
  130. *
  131. * 3) ANALYSE DU CHPOINT DE FORCES SURFACIQUES SI DONNE
  132. * IFLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE IPMODI
  133. * ( 1 = DESTRUCTION DU MMODEL IPMODI CREE )
  134. *
  135. IF (IPCHPS.NE.0) THEN
  136. *
  137. IFLAG = 1
  138. *
  139. * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT
  140. * CORRESPONDANT AUX SEULES COMPOSANTES RECHERCHEES (mfors)
  141. *
  142. IPGEOM = 0
  143. *
  144. MCHPOI=IPCHPS
  145. SEGACT,MCHPOI
  146. NSOUPO=IPCHP(/1)
  147. ltelq=.FALSE.
  148. DO I = 1, NSOUPO
  149. MSOUPO=IPCHP(I)
  150. SEGACT,MSOUPO
  151. NC = NOCOMP(/2)
  152. DO j = 1, NC
  153. CALL PLACE(mfors,nfors,imo,NOCOMP(j))
  154. IF (imo.NE.0) THEN
  155. IF (IPGEOM.EQ.0) THEN
  156. IPGEOM = IGEOC
  157. ELSE
  158. IPP2 = IGEOC
  159. CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  160. IF (IERR.NE.0) RETURN
  161. IPGEOM = IPPT
  162. ENDIF
  163. GOTO 10
  164. ENDIF
  165. ENDDO
  166. 10 CONTINUE
  167. SEGDES,MSOUPO
  168. ENDDO
  169. SEGDES,MCHPOI
  170.  
  171. IF (IPGEOM.EQ.0) THEN
  172. CALL ERREUR(21)
  173. RETURN
  174. ENDIF
  175. *
  176. * ON CREE UN MODELE S'ACCROCHANT AU CHPOINT
  177. *
  178. MMODEL = IPMODL
  179. SEGACT,MMODEL
  180. NSOUS = MMODEL.KMODEL(/1)
  181. *
  182. N1 = NSOUS
  183. SEGINI,MMODE1=MMODEL
  184. IPMODI = MMODE1
  185. *
  186. * BOUCLE SUR LES SOUS ZONES GEOMETRIQUES ELEMENTAIRES
  187. *
  188. N1 = 0
  189. lzero = 0
  190. *
  191. DO 11 ISOUS = 1, NSOUS
  192. *
  193. IMODEL=KMODEL(ISOUS)
  194. SEGACT,IMODEL
  195. ITGEOM=IMAMOD
  196. SEGDES,IMODEL
  197. *
  198. CALL ECROBJ('MAILLAGE',IPGEOM)
  199. CALL ECRCHA('STRI')
  200. CALL ECRCHA('APPU')
  201. CALL ECROBJ('MAILLAGE',ITGEOM)
  202. CALL EXTREL(irr,0,ibnor)
  203. *
  204. * LE CHPOINT ET LA SOUS-ZONE N'ONT PAS D'ELEMENT EN COMMUN
  205. *
  206. IF (irr.GT.0) GOTO 11
  207. *
  208. * DEFINITION DU SOUS-MODELE ASSOCIE A L'INTERSECTION
  209. CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  210. IF (IERR.NE.0) GOTO 9990
  211. *
  212. N1 = N1 + 1
  213. *
  214. * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  215. *
  216. SEGINI,IMODE1=IMODEL
  217. IMODE1.IMAMOD=IPOGEO
  218. CALL INOMID(IMODE1,' ',iret,lzero,lzero,lzero,lzero)
  219. CALL PRQUOI(IMODE1)
  220. SEGDES,IMODE1
  221. MMODE1.KMODEL(N1) = IMODE1
  222. *
  223. 11 CONTINUE
  224.  
  225. SEGDES,MMODEL
  226. *
  227. * LE MODELE ET LE CHPOINT SONT INCOMPATIBLES
  228. *
  229. IF (N1.EQ.0) THEN
  230. MOTERR(1:8)='MAILLAGE'
  231. MOTERR(9:16)='CHPOINT'
  232. CALL ERREUR(135)
  233. IFLAG = 0
  234. SEGSUP,MMODE1
  235. GOTO 9990
  236. ENDIF
  237. *
  238. IF (N1.NE.NSOUS) THEN
  239. SEGADJ,MMODE1
  240. ENDIF
  241. *
  242. * ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML AUX NOEUDS
  243. *
  244. CALL CHAME1(0,IPMODI,IPCHPS,' ',IPCHMS,1)
  245. IF (IERR.NE.0) GOTO 9990
  246.  
  247. MCHEL1=IPCHMS
  248. SEGACT,MCHEL1
  249. *
  250. ELSE
  251.  
  252. IFLAG = 0
  253. IPMODI = IPMODL
  254.  
  255. ENDIF
  256. *
  257. * ACTIVATION DU MODELE
  258. *
  259. MMODEL = IPMODI
  260. SEGACT,MMODEL
  261. NSOUS = KMODEL(/1)
  262. *
  263. * INITIALISATION DU MCHAML ELEMENTAIRE DES FORCES NODALES
  264. *
  265. N1 = NSOUS
  266. L1 = 6
  267. N3 = 6
  268. SEGINI,MCHELM
  269. IPCHMZ = MCHELM
  270. TITCHE = 'FORCES'
  271. IFOCHE = IFOUR
  272. *
  273. DO 100 ISOUS = 1, NSOUS
  274. *
  275. * ON RECUPERE L INFORMATION GENERALE
  276. *
  277. IMODEL=KMODEL(ISOUS)
  278. SEGACT,IMODEL
  279. *
  280. MOCARA = 0
  281. IVACAR = 0
  282. MOFORC = 0
  283. IVAFOR = 0
  284. *
  285. * TRAITEMENT DU MODEL
  286. *
  287. IPMAIL=IMAMOD
  288. CONM =CONMOD
  289. MELE =NEFMOD
  290.  
  291. imo = 0
  292. CALL PLACE2(LEFCOQ,NEFCOQ,imo,MELE)
  293. *
  294. * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  295. IF (imo.EQ.0) THEN
  296. MOTERR(1:4) = NOMTP(MELE)
  297. MOTERR(5:12)='FSURCO '
  298. CALL ERREUR(86)
  299. ipchmz=0
  300. ipchms=0
  301. GOTO 9900
  302. ENDIF
  303.  
  304. IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  305. IF (IPCARA.EQ.0) THEN
  306. C* Revoir l'erreur
  307. MOTERR(1:4) = NOMTP(MELE)
  308. MOTERR(5:12)='FSURCO '
  309. CALL ERREUR(86)
  310. ipchmz=0
  311. ipchms=0
  312. GOTO 9900
  313. ENDIF
  314. ENDIF
  315. *
  316. * INFORMATION SUR L ELEMENT FINI
  317. *
  318. MFR =INFELE(13)
  319. IPTINT=INFMOD(5)
  320. IPTNOE=INFMOD(8)
  321. MINTE =IPTINT
  322. IF (IPTINT.NE.0) SEGACT,MINTE
  323. IPPORE=0
  324. IF (MFR.EQ.33) IPPORE=NBNN
  325. *
  326. * CREATION DU TABLEAU INFOS
  327. *
  328. CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret)
  329. IF (iret.EQ.0) GOTO 9900
  330. *
  331. IPT(1) = 0
  332. IPT(2) = 0
  333. IPT(3) = 0
  334. IF (IPCHMS.NE.0) THEN
  335. MCHAM1 = MCHEL1.ICHAML(ISOUS)
  336. SEGACT,MCHAM1
  337. DO i = 1, MCHAM1.NOMCHE(/2)
  338. CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i))
  339. if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i)
  340. ENDDO
  341. SEGDES,MCHAM1
  342. ENDIF
  343. *
  344. IMACHE(ISOUS)=IPMAIL
  345. CONCHE(ISOUS)=CONM
  346. INFCHE(ISOUS,1)=0
  347. INFCHE(ISOUS,2)=0
  348. INFCHE(ISOUS,3)=NHRM
  349. INFCHE(ISOUS,4)=IPTINT
  350. INFCHE(ISOUS,5)=0
  351. INFCHE(1,6)=0
  352. *
  353. MELEME=IPMAIL
  354. SEGACT,MELEME
  355. NBNN =NUM(/1)
  356. NBELEM=NUM(/2)
  357. *
  358. * RECHERCHE DES NOMS DE COMPOSANTES
  359. *
  360. IF (lnomid(2).ne.0) then
  361. lsupfo = .false.
  362. MOFORC = lnomid(2)
  363. else
  364. lsupfo = .true.
  365. CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC)
  366. endif
  367. nomid=MOFORC
  368. SEGACT,nomid
  369. nfor = lesobl(/2)
  370. nfac = 0
  371. NCOMP = NFOR - NDPGE
  372.  
  373. N2 = NCOMP
  374. SEGINI,MCHAML
  375. ICHAML(ISOUS) = MCHAML
  376. NS=1
  377. NCOSOU=NCOMP
  378. SEGINI,MPTVAL
  379. IVAFOR=MPTVAL
  380. *
  381. N1EL = NBELEM
  382. IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  383. & MELE.EQ.93) THEN
  384. N1PTEL = 3
  385. ELSE IF (MELE.EQ.44) THEN
  386. N1PTEL = 2
  387. ELSE IF (MELE.EQ.49 .OR. MELE.EQ.41 .OR. MELE.EQ.56) THEN
  388. N1PTEL=NBNN
  389. ENDIF
  390. N2PTEL=0
  391. N2EL =0
  392. *
  393. DO 4 ICOMP = 1, NCOMP
  394. NOMCHE(ICOMP) = LESOBL(ICOMP)
  395. TYPCHE(ICOMP)='REAL*8'
  396. SEGINI,MELVAL
  397. IELVAL(ICOMP)=MELVAL
  398. IVAL(ICOMP)=MELVAL
  399. 4 CONTINUE
  400. *_______________________________________________________________________
  401. *
  402. * CALCUL DES FORCES NODALES EQUIVALENTES
  403. * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  404. *_______________________________________________________________________
  405. *
  406. * ELEMENTS COQ3 , DKT OU DKTC
  407. * ---------------------------
  408. IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  409. & MELE.EQ.93) THEN
  410. *
  411. CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR)
  412. *
  413. * ELEMENT COQ2
  414. * ------------
  415. ELSE IF (MELE.EQ.44) THEN
  416. *
  417. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  418. *
  419. IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN
  420. *
  421. NBROBL=0
  422. NBRFAC=1
  423. SEGINI,NOMID
  424. MOCARA=NOMID
  425. LESFAC(1)='DIM3'
  426. *
  427. NBTYPE=1
  428. SEGINI,NOTYPE
  429. MOTYPE=NOTYPE
  430. TYPE(1)='REAL*8'
  431. *
  432. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,0,
  433. & INFOS,3,IVACAR)
  434. SEGSUP,NOTYPE
  435. IF (IERR.NE.0) GOTO 9990
  436. *
  437. IF (ISUPCA.EQ.1) THEN
  438. NCARA=NBROBL
  439. NCARF=NBRFAC
  440. NCARR=NCARA+NCARF
  441. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  442. ENDIF
  443. *
  444. ENDIF
  445.  
  446. CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR)
  447. *
  448. * ELEMENTS COQ4
  449. * -------------
  450. *
  451. ELSE IF (MELE.EQ.49) THEN
  452. *
  453. CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
  454. *
  455. * ELEMENTS COQ6 OU COQ8
  456. * ---------------------
  457. *
  458. ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  459. *____________________________________________________________________
  460. *
  461. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6
  462. *____________________________________________________________________
  463. *
  464. NBROBL=1
  465. NBRFAC=0
  466. SEGINI,NOMID
  467. MOCARA=NOMID
  468. LESOBL(1)='EPAI'
  469. *
  470. NBTYPE=1
  471. SEGINI,NOTYPE
  472. MOTYPE=NOTYPE
  473. TYPE(1)='REAL*8'
  474. *
  475. *
  476. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
  477. SEGSUP,NOTYPE
  478. IF (IERR.NE.0) GOTO 9990
  479. *
  480. IF (ISUPCA.EQ.1) THEN
  481. NCARA=NBROBL
  482. NCARF=NBRFAC
  483. NCARR=NCARA+NCARF
  484. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  485. ENDIF
  486. *
  487. CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR)
  488. *
  489. ENDIF
  490. *
  491. DO ICOMP = 1, NCOMP
  492. MELVAL=IELVAL(ICOMP)
  493. SEGDES,MELVAL
  494. ENDDO
  495. *
  496. IF (IPTINT.NE.0) SEGDES,MINTE
  497. SEGDES,MELEME
  498. SEGDES,IMODEL
  499. *
  500. IF (MOCARA.NE.0) THEN
  501. NOMID = MOCARA
  502. SEGSUP,NOMID
  503. IF (ISUPCA.EQ.1) THEN
  504. CALL DTMVAL(IVACAR,3)
  505. ELSE
  506. CALL DTMVAL(IVACAR,1)
  507. ENDIF
  508. ENDIF
  509. *
  510. IF (MOFORC.NE.0) THEN
  511. nomid=MOFORC
  512. SEGDES,nomid
  513. IF (lsupfo) SEGSUP,nomid
  514. CALL DTMVAL(IVAFOR,1)
  515. ENDIF
  516. *
  517. 100 CONTINUE
  518.  
  519. *
  520. * ON TRANSFORME LE MCHAML EN CHPOINT
  521. *
  522. CALL CHAMPO(IPCHMZ,0,IPTFP,iret)
  523. IF (iret.EQ.0) GOTO 9990
  524. *
  525. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  526. *
  527. 9900 CONTINUE
  528. 9990 CONTINUE
  529. SEGDES,MMODEL
  530. *
  531. IF (IFLAG.EQ.1) CALL DTMODL(IPMODI)
  532. IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ)
  533. IF (IPCHMS.NE.0) CALL DTCHAM(IPCHMS)
  534. *
  535. RETURN
  536. END
  537.  
  538.  
  539.  
  540.  
  541.  
  542.  

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