Télécharger fsurco.eso

Retour à la liste

Numérotation des lignes :

  1. C FSURCO SOURCE CB215821 19/08/20 21:17:54 10287
  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. NSOUPO=IPCHP(/1)
  146. ltelq=.FALSE.
  147. DO I = 1, NSOUPO
  148. MSOUPO=IPCHP(I)
  149. NC = NOCOMP(/2)
  150. DO j = 1, NC
  151. CALL PLACE(mfors,nfors,imo,NOCOMP(j))
  152. IF (imo.NE.0) THEN
  153. IF (IPGEOM.EQ.0) THEN
  154. IPGEOM = IGEOC
  155. ELSE
  156. IPP2 = IGEOC
  157. CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  158. IF (IERR.NE.0) RETURN
  159. IPGEOM = IPPT
  160. ENDIF
  161. GOTO 10
  162. ENDIF
  163. ENDDO
  164. 10 CONTINUE
  165. ENDDO
  166.  
  167. IF (IPGEOM.EQ.0) THEN
  168. CALL ERREUR(21)
  169. RETURN
  170. ENDIF
  171. *
  172. * ON CREE UN MODELE S'ACCROCHANT AU CHPOINT
  173. *
  174. MMODEL = IPMODL
  175. NSOUS = MMODEL.KMODEL(/1)
  176. *
  177. N1 = NSOUS
  178. SEGINI,MMODE1=MMODEL
  179. IPMODI = MMODE1
  180. *
  181. * BOUCLE SUR LES SOUS ZONES GEOMETRIQUES ELEMENTAIRES
  182. *
  183. N1 = 0
  184. lzero = 0
  185. *
  186. DO 11 ISOUS = 1, NSOUS
  187. *
  188. IMODEL=KMODEL(ISOUS)
  189. ITGEOM=IMAMOD
  190. *
  191. CALL ECROBJ('MAILLAGE',IPGEOM)
  192. CALL ECRCHA('STRI')
  193. CALL ECRCHA('APPU')
  194. CALL ECROBJ('MAILLAGE',ITGEOM)
  195. CALL EXTREL(irr,0,ibnor)
  196. *
  197. * LE CHPOINT ET LA SOUS-ZONE N'ONT PAS D'ELEMENT EN COMMUN
  198. *
  199. IF (irr.GT.0) GOTO 11
  200. *
  201. * DEFINITION DU SOUS-MODELE ASSOCIE A L'INTERSECTION
  202. CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  203. CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  204. IF (IERR.NE.0) GOTO 9990
  205. *
  206. N1 = N1 + 1
  207. *
  208. * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  209. *
  210. SEGINI,IMODE1=IMODEL
  211. IMODE1.IMAMOD=IPOGEO
  212. CALL INOMID(IMODE1,' ',iret,lzero,lzero,lzero,lzero)
  213. CALL PRQUOI(IMODE1)
  214. MMODE1.KMODEL(N1) = IMODE1
  215. *
  216. 11 CONTINUE
  217. *
  218. * LE MODELE ET LE CHPOINT SONT INCOMPATIBLES
  219. *
  220. IF (N1.EQ.0) THEN
  221. MOTERR(1:8)='MAILLAGE'
  222. MOTERR(9:16)='CHPOINT'
  223. CALL ERREUR(135)
  224. IFLAG = 0
  225. SEGSUP,MMODE1
  226. GOTO 9990
  227. ENDIF
  228. *
  229. IF (N1.NE.NSOUS) THEN
  230. SEGADJ,MMODE1
  231. ENDIF
  232. *
  233. * ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML AUX NOEUDS
  234. *
  235. CALL CHAME1(0,IPMODI,IPCHPS,' ',IPCHMS,1)
  236. IF (IERR.NE.0) GOTO 9990
  237.  
  238. MCHEL1=IPCHMS
  239. *
  240. ELSE
  241. IFLAG = 0
  242. IPMODI = IPMODL
  243.  
  244. ENDIF
  245. *
  246. * ACTIVATION DU MODELE
  247. *
  248. MMODEL = IPMODI
  249. NSOUS = KMODEL(/1)
  250. *
  251. * INITIALISATION DU MCHAML ELEMENTAIRE DES FORCES NODALES
  252. *
  253. N1 = NSOUS
  254. L1 = 6
  255. N3 = 6
  256. SEGINI,MCHELM
  257. IPCHMZ = MCHELM
  258. TITCHE = 'FORCES'
  259. IFOCHE = IFOUR
  260. *
  261. DO 100 ISOUS = 1, NSOUS
  262. *
  263. * ON RECUPERE L INFORMATION GENERALE
  264. *
  265. IMODEL=KMODEL(ISOUS)
  266. *
  267. MOCARA = 0
  268. IVACAR = 0
  269. MOFORC = 0
  270. IVAFOR = 0
  271. *
  272. * TRAITEMENT DU MODEL
  273. *
  274. IPMAIL=IMAMOD
  275. CONM =CONMOD
  276. MELE =NEFMOD
  277.  
  278. imo = 0
  279. CALL PLACE2(LEFCOQ,NEFCOQ,imo,MELE)
  280. *
  281. * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  282. IF (imo.EQ.0) THEN
  283. MOTERR(1:4) = NOMTP(MELE)
  284. MOTERR(5:12)='FSURCO '
  285. CALL ERREUR(86)
  286. ipchmz=0
  287. ipchms=0
  288. GOTO 9900
  289. ENDIF
  290.  
  291. IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  292. IF (IPCARA.EQ.0) THEN
  293. C* Revoir l'erreur
  294. MOTERR(1:4) = NOMTP(MELE)
  295. MOTERR(5:12)='FSURCO '
  296. CALL ERREUR(86)
  297. ipchmz=0
  298. ipchms=0
  299. GOTO 9900
  300. ENDIF
  301. ENDIF
  302. *
  303. * INFORMATION SUR L ELEMENT FINI
  304. *
  305. MFR =INFELE(13)
  306. IPTINT=INFMOD(5)
  307. IPTNOE=INFMOD(8)
  308. MINTE =IPTINT
  309. IPPORE=0
  310. IF (MFR.EQ.33) IPPORE=NBNN
  311. *
  312. * CREATION DU TABLEAU INFOS
  313. *
  314. CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret)
  315. IF (iret.EQ.0) GOTO 9900
  316. *
  317. IPT(1) = 0
  318. IPT(2) = 0
  319. IPT(3) = 0
  320. IF (IPCHMS.NE.0) THEN
  321. MCHAM1 = MCHEL1.ICHAML(ISOUS)
  322. DO i = 1, MCHAM1.NOMCHE(/2)
  323. CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i))
  324. if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i)
  325. ENDDO
  326. ENDIF
  327. *
  328. IMACHE(ISOUS)=IPMAIL
  329. CONCHE(ISOUS)=CONM
  330. INFCHE(ISOUS,1)=0
  331. INFCHE(ISOUS,2)=0
  332. INFCHE(ISOUS,3)=NHRM
  333. INFCHE(ISOUS,4)=IPTINT
  334. INFCHE(ISOUS,5)=0
  335. INFCHE(1,6)=0
  336. *
  337. MELEME=IPMAIL
  338. NBNN =NUM(/1)
  339. NBELEM=NUM(/2)
  340. *
  341. * RECHERCHE DES NOMS DE COMPOSANTES
  342. *
  343. IF (lnomid(2).ne.0) then
  344. lsupfo = .false.
  345. MOFORC = lnomid(2)
  346. else
  347. lsupfo = .true.
  348. CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC)
  349. endif
  350. nomid=MOFORC
  351. nfor = lesobl(/2)
  352. nfac = 0
  353. NCOMP = NFOR - NDPGE
  354.  
  355. N2 = NCOMP
  356. SEGINI,MCHAML
  357. ICHAML(ISOUS) = MCHAML
  358. NS=1
  359. NCOSOU=NCOMP
  360. SEGINI,MPTVAL
  361. IVAFOR=MPTVAL
  362. *
  363. N1EL = NBELEM
  364. IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  365. & MELE.EQ.93) THEN
  366. N1PTEL = 3
  367. ELSE IF (MELE.EQ.44) THEN
  368. N1PTEL = 2
  369. ELSE IF (MELE.EQ.49 .OR. MELE.EQ.41 .OR. MELE.EQ.56) THEN
  370. N1PTEL=NBNN
  371. ENDIF
  372. N2PTEL=0
  373. N2EL =0
  374. *
  375. DO 4 ICOMP = 1, NCOMP
  376. NOMCHE(ICOMP) = LESOBL(ICOMP)
  377. TYPCHE(ICOMP)='REAL*8'
  378. SEGINI,MELVAL
  379. IELVAL(ICOMP)=MELVAL
  380. IVAL(ICOMP)=MELVAL
  381. 4 CONTINUE
  382. *_______________________________________________________________________
  383. *
  384. * CALCUL DES FORCES NODALES EQUIVALENTES
  385. * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  386. *_______________________________________________________________________
  387. *
  388. * ELEMENTS COQ3 , DKT OU DKTC
  389. * ---------------------------
  390. IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  391. & MELE.EQ.93) THEN
  392. *
  393. CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR)
  394. *
  395. * ELEMENT COQ2
  396. * ------------
  397. ELSE IF (MELE.EQ.44) THEN
  398. *
  399. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  400. *
  401. IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN
  402. *
  403. NBROBL=0
  404. NBRFAC=1
  405. SEGINI,NOMID
  406. MOCARA=NOMID
  407. LESFAC(1)='DIM3'
  408. *
  409. NBTYPE=1
  410. SEGINI,NOTYPE
  411. MOTYPE=NOTYPE
  412. TYPE(1)='REAL*8'
  413. *
  414. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,0,
  415. & INFOS,3,IVACAR)
  416. SEGSUP,NOTYPE
  417. IF (IERR.NE.0) GOTO 9990
  418. *
  419. IF (ISUPCA.EQ.1) THEN
  420. NCARA=NBROBL
  421. NCARF=NBRFAC
  422. NCARR=NCARA+NCARF
  423. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  424. ENDIF
  425. *
  426. ENDIF
  427.  
  428. CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR)
  429. *
  430. * ELEMENTS COQ4
  431. * -------------
  432. *
  433. ELSE IF (MELE.EQ.49) THEN
  434. *
  435. CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
  436. *
  437. * ELEMENTS COQ6 OU COQ8
  438. * ---------------------
  439. *
  440. ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  441. *____________________________________________________________________
  442. *
  443. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6
  444. *____________________________________________________________________
  445. *
  446. NBROBL=1
  447. NBRFAC=0
  448. SEGINI,NOMID
  449. MOCARA=NOMID
  450. LESOBL(1)='EPAI'
  451. *
  452. NBTYPE=1
  453. SEGINI,NOTYPE
  454. MOTYPE=NOTYPE
  455. TYPE(1)='REAL*8'
  456. *
  457. *
  458. CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
  459. SEGSUP,NOTYPE
  460. IF (IERR.NE.0) GOTO 9990
  461. *
  462. IF (ISUPCA.EQ.1) THEN
  463. NCARA=NBROBL
  464. NCARF=NBRFAC
  465. NCARR=NCARA+NCARF
  466. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  467. ENDIF
  468. *
  469. CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR)
  470. *
  471. ENDIF
  472. *
  473. *
  474. IF (MOCARA.NE.0) THEN
  475. NOMID = MOCARA
  476. SEGSUP,NOMID
  477. IF (ISUPCA.EQ.1) THEN
  478. CALL DTMVAL(IVACAR,3)
  479. ELSE
  480. CALL DTMVAL(IVACAR,1)
  481. ENDIF
  482. ENDIF
  483. *
  484. IF (MOFORC.NE.0) THEN
  485. nomid=MOFORC
  486. IF (lsupfo) SEGSUP,nomid
  487. CALL DTMVAL(IVAFOR,1)
  488. ENDIF
  489. *
  490. 100 CONTINUE
  491.  
  492. *
  493. * ON TRANSFORME LE MCHAML EN CHPOINT
  494. *
  495. CALL CHAMPO(IPCHMZ,0,IPTFP,iret)
  496. IF (iret.EQ.0) GOTO 9990
  497. *
  498. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  499. *
  500. 9900 CONTINUE
  501. 9990 CONTINUE
  502. *
  503. IF (IFLAG .EQ.1) CALL DTMODL(IPMODI)
  504. IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ)
  505. IF (IPCHMS.NE.0) CALL DTCHAM(IPCHMS)
  506.  
  507. END
  508.  
  509.  
  510.  
  511.  

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