Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes :

  1. C FPCOQU SOURCE MB234859 16/10/07 21:15:08 9121
  2. SUBROUTINE FPCOQU(P,IPCHE1,IPCHM1,IPMODL,JMLU,IPTFP,IRET,ICONV)
  3. *_____________________________________________________________________
  4. *
  5. * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES
  6. *
  7. * ENTREES :
  8. * ---------
  9. *
  10. * P VALEUR DE LA PRESSION SI ELLE EST CONSTANTE
  11. * IPCHE1 CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  12. * IPCHM1 CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. * ICONV FLAG DE CONVERSION
  14. * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION
  15. * JMLU 1 SI MOT CLE NORMAL
  16. * 0 SINON IL FAUT APPELER PRORIE
  17. * 0 SI LE MOT CLE NORM A ETE INDIQUE
  18. *
  19. * SORTIES :
  20. * ---------
  21. *
  22. * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES
  23. * IRET 1 OU 0 SUIVANT SUCCES OU NON
  24. *
  25. *
  26. * REVISION JACQUELINE BROCHARD SEPTEMBRE 86
  27. *
  28. * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 09 90
  29. *
  30. *_____________________________________________________________________
  31. *
  32. IMPLICIT INTEGER(I-N)
  33. IMPLICIT REAL*8(A-H,O-Z)
  34. -INC CCOPTIO
  35. -INC CCHAMP
  36. -INC SMCOORD
  37. -INC SMELEME
  38. -INC SMMODEL
  39. -INC SMCHAML
  40. -INC SMCHPOI
  41. -INC SMINTE
  42. *
  43. logical ltelq
  44. SEGMENT NOTYPE
  45. CHARACTER*16 TYPE(NBTYPE)
  46. ENDSEGMENT
  47. *
  48. SEGMENT MPTVAL
  49. INTEGER IPOS(NS) ,NSOF(NS)
  50. INTEGER IVAL(NCOSOU)
  51. CHARACTER*16 TYVAL(NCOSOU)
  52. ENDSEGMENT
  53. *
  54. * Segment donnant le pointeur de maillage correcte au MCHAML de
  55. * caracteristique apres creation d'un MMODEL
  56. *
  57. SEGMENT JPMAIL
  58. INTEGER MAIL1 (NSOUS1)
  59. INTEGER MAIL2 (NSOUS1)
  60. ENDSEGMENT
  61. *
  62. CHARACTER*8 MOT
  63. CHARACTER*(NCONCH) CONM
  64. PARAMETER (NINF=3)
  65. INTEGER INFOS(NINF)
  66. LOGICAL lsupfo
  67. DATA MOT/'RIGIDITE'/
  68. *
  69. IRET = 0
  70. IGEOM= 0
  71.  
  72. NHRM=NIFOUR
  73. *
  74. IFLAG=0
  75. IND=0
  76. IVACAR=0
  77. IPCHE2=0
  78. JPMAIL=0
  79. *
  80. * LE FLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE
  81. * EN CAS DE CREATION ( 0 : DESTRUCTION D'UN MMODEL CREE )
  82. *
  83. IF (IPCHE1.NE.0.OR.IPCHM1.NE.0) THEN
  84. *
  85. * ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT
  86. *
  87. IF (IPCHE1.NE.0) THEN
  88. CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU)
  89. ELSE
  90. CALL ECROBJ('MCHAML ',IPCHM1)
  91. CALL ECRCHA('SCAL')
  92. CALL NOMC
  93. CALL LIROBJ('MCHAML ',IPCHE,1,IRETOU)
  94. ENDIF
  95. IF (IERR.NE.0) RETURN
  96.  
  97. IF (IPCHE1.NE.0) THEN
  98. *
  99. * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT
  100. *
  101. MCHPOI=IPCHE
  102. SEGACT MCHPOI
  103. NSOUPO=IPCHP(/1)
  104. IPGEOM = 0
  105. DO 1140 I=1,NSOUPO
  106. MSOUPO=IPCHP(I)
  107. SEGACT MSOUPO
  108. IF (IPGEOM.EQ.0) THEN
  109. IPGEOM = IGEOC
  110. ELSE
  111. IPP2 = IGEOC
  112. ltelq=.false.
  113. CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  114. IPGEOM = IPPT
  115. ENDIF
  116. SEGDES MSOUPO
  117. 1140 CONTINUE
  118. SEGDES MCHPOI
  119. ELSE
  120. *
  121. * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHAMELEM
  122. *
  123. MCHEL2=IPCHE
  124. SEGACT MCHEL2
  125. DO 1150 I=1,MCHEL2.IMACHE(/1)
  126. IMTMP=MCHEL2.IMACHE(I)
  127. IF (I.GT.1) THEN
  128. ltelq=.false.
  129. CALL FUSE (IPGEOM,IMTMP,IPPT,ltelq)
  130. IPGEOM = IPPT
  131. ELSE
  132. IPGEOM = IMTMP
  133. ENDIF
  134. 1150 CONTINUE
  135. ENDIF
  136. IF (IERR.NE.0) RETURN
  137. *
  138. N1=0
  139. SEGINI MMODEL
  140. IPMOD=MMODEL
  141. *
  142. MMODE1=IPMODL
  143. SEGACT MMODE1
  144. NSOUS1=MMODE1.KMODEL(/1)
  145. *
  146. * BOUCLE SUR LES SOUS ZONE GEOMETRIQUE ELEMENTAIRE
  147. *
  148. IRRT=0
  149. DO 50 ISOUS=1,NSOUS1
  150. IMODE1=MMODE1.KMODEL(ISOUS)
  151. SEGACT IMODE1
  152. ITGEOM=IMODE1.IMAMOD
  153. CALL ECROBJ('MAILLAGE',IPGEOM)
  154. CALL ECRCHA('STRI')
  155. CALL ECRCHA('APPU')
  156. CALL ECROBJ('MAILLAGE',ITGEOM)
  157. CALL EXTREL(IRR,0,IBNOR)
  158. IF (IRR.EQ.0) THEN
  159. *
  160. * ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE
  161. *
  162. CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  163. IF (IERR.NE.0) THEN
  164. SEGDES MMODE1
  165. SEGDES IMODE1
  166. SEGSUP MMODEL
  167. RETURN
  168. ENDIF
  169. N1=N1+1
  170. SEGADJ MMODEL
  171. *
  172. * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  173. *
  174. NFOR=IMODE1.FORMOD(/2)
  175. NMAT=IMODE1.MATMOD(/2)
  176. MN3 =IMODE1.INFMOD(/1)
  177. NPARMO=0
  178. nobmod=0
  179. SEGINI IMODEL
  180. conmod(17:24)=' '
  181. IMAMOD=IPOGEO
  182. NEFMOD=IMODE1.NEFMOD
  183. CONMOD=IMODE1.CONMOD
  184. IPDPGE=IMODE1.IPDPGE
  185. *
  186. * CREATION D'UN TABLEAU DE CORRESPONDANCE LE IMAMOD DU
  187. * MMODEL (IPMODL) ET DU IMAMOD DU NVX MMODEL QUE L'ON CREE
  188. * (UTILISE DANS LE KOMCHA POUR LE MCHAML DE CARATERISTIQUE
  189. * POUR LES COQ6 ET COQ8)
  190. *
  191. IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  192. IF (JPMAIL.EQ.0) SEGINI JPMAIL
  193. MAIL1(ISOUS)=ITGEOM
  194. MAIL2(ISOUS)=IPOGEO
  195. ENDIF
  196. DO 47 I=1,MN3
  197. INFMOD(I)=IMODE1.INFMOD(I)
  198. 47 CONTINUE
  199. CONMOD=IMODE1.CONMOD
  200. DO 48 I=1,NFOR
  201. FORMOD(I)=IMODE1.FORMOD(I)
  202. 48 CONTINUE
  203. DO 49 I=1,NMAT
  204. MATMOD(I)=IMODE1.MATMOD(I)
  205. 49 CONTINUE
  206. KMODEL(N1)=IMODEL
  207. lzero=0
  208. call inomid(imodel,' ',iret,lzero,lzero,lzero,lzero)
  209. call prquoi(imodel)
  210. SEGDES IMODEL
  211. ELSE
  212. *
  213. * LE CHPOINT OU CHAMELEM N'ADHERE PAS A CETTE ZONE
  214. *
  215. IRRT=IRRT+1
  216. ENDIF
  217. SEGDES IMODE1
  218. 50 CONTINUE
  219. SEGDES MMODE1
  220. SEGDES MMODEL
  221. *
  222. IF (NSOUPO.GT.1) THEN
  223. MELEME=IPGEOM
  224. SEGSUP MELEME
  225. ENDIF
  226. *
  227. IF (IRRT.EQ.NSOUS1) THEN
  228. *
  229. * L'OBJET MAILLAGE ET LE CHPOINT OU CHAMELEM SONT INCOMPATIBLES
  230. *
  231. MOTERR(1:8)='MAILLAGE'
  232. IF (IPCHE1.NE.0) THEN
  233. MOTERR(9:16)='CHPOINT'
  234. ELSE
  235. MOTERR(9:16)='CHAMELEM'
  236. ENDIF
  237. CALL ERREUR(135)
  238. MMODEL=IPMOD
  239. SEGSUP MMODEL
  240. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  241. RETURN
  242. ENDIF
  243. IPMODI=IPMOD
  244. ELSE
  245. IPMODI=IPMODL
  246. IFLAG=1
  247. ENDIF
  248. *
  249. *
  250. *-------EN 3D ET DANS LE CAS OU NORM N'A PAS ETE INDIQUE
  251. * ON CHARGE PRORIE DE REORIENTER LES ELEMENTS
  252. *
  253. IF (IDIM.EQ.3.AND.JMLU.EQ.0) THEN
  254. MMODE1=IPMODI
  255. SEGACT MMODE1
  256. NSOUS=MMODE1.KMODEL(/1)
  257. N1=NSOUS
  258. SEGINI MMODEL
  259. IPMOD=MMODEL
  260. NBELEM=0
  261. NBNN=0
  262. NBREF=0
  263. NBSOUS=NSOUS
  264. SEGINI MELEME
  265. DO 9 ISOUS=1,NSOUS
  266. IMODEL=MMODE1.KMODEL(ISOUS)
  267. SEGACT IMODEL
  268. LISOUS(ISOUS)=IMAMOD
  269. SEGDES IMODEL
  270. 9 CONTINUE
  271. *
  272. * MAILLAGE A REORIENTER
  273. *
  274. CALL ECROBJ('MAILLAGE',MELEME)
  275. *
  276. * ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE
  277. *
  278. CALL PRORIE
  279. *
  280. * MAILLAGE REORIENTE
  281. *
  282. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  283. IF (IERR.NE.0) THEN
  284. SEGSUP MMODEL
  285. IF (IFLAG.EQ.0) CALL DTMODL(IPMODI)
  286. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  287. RETURN
  288. ENDIF
  289. SEGACT MELEME
  290. DO 10 ISOUS=1,NSOUS
  291. IMODE1=MMODE1.KMODEL(ISOUS)
  292. SEGACT IMODE1
  293. NFOR=IMODE1.FORMOD(/2)
  294. NMAT=IMODE1.MATMOD(/2)
  295. MN3 =IMODE1.INFMOD(/1)
  296. NPARMO=0
  297. nobmod=0
  298. SEGINI IMODEL
  299. conmod(17:24)=' '
  300. KMODEL(ISOUS)=IMODEL
  301. *
  302. * IMAMOD REORIENTE
  303. *
  304. IMAMOD=LISOUS(ISOUS)
  305. NEFMOD=IMODE1.NEFMOD
  306. CONMOD=IMODE1.CONMOD
  307. IPDPGE=IMODE1.IPDPGE
  308. *
  309. * MISE A JOUR DU TABLEAU DE CORRESONDANCE DES IMAMOD
  310. *
  311. IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  312. IF (JPMAIL.EQ.0) THEN
  313. NSOUS1=NSOUS
  314. SEGINI JPMAIL
  315. ENDIF
  316. IF (IFLAG.EQ.1) MAIL1(ISOUS)=IMODE1.IMAMOD
  317. MAIL2(ISOUS)=IMAMOD
  318. ENDIF
  319. DO 3 I=1,MN3
  320. INFMOD(I)=IMODE1.INFMOD(I)
  321. 3 CONTINUE
  322. CONMOD=IMODE1.CONMOD
  323. DO 1 I=1,NFOR
  324. FORMOD(I)=IMODE1.FORMOD(I)
  325. 1 CONTINUE
  326. DO 2 I=1,NMAT
  327. MATMOD(I)=IMODE1.MATMOD(I)
  328. 2 CONTINUE
  329. SEGDES IMODEL
  330. IF (IFLAG.EQ.1) THEN
  331. SEGDES IMODE1
  332. ELSE
  333. SEGSUP IMODE1
  334. ENDIF
  335. lzer=0
  336. call inomid(imodel,' ',iret,lzer,lzer,lzer,lzer)
  337. call prquoi(imodel )
  338. SEGDES IMODEL
  339. 10 CONTINUE
  340. SEGDES MMODEL
  341. IF (IFLAG.EQ.1) THEN
  342. SEGDES MMODE1
  343. ELSE
  344. SEGSUP MMODE1
  345. ENDIF
  346. IFLAG=0
  347. ELSE
  348. IPMOD=IPMODI
  349. ENDIF
  350. *
  351. * EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS
  352. * ONT LA MEME ORIENTATION
  353. *
  354. MMODEL=IPMOD
  355. SEGACT MMODEL
  356. DO 11 ISOUS=1,KMODEL(/1)
  357. IMODEL=KMODEL(ISOUS)
  358. SEGACT IMODEL
  359. IF (ISOUS.GT.1) THEN
  360. IPTGEO=IMAMOD
  361. ltelq=.false.
  362. CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq)
  363. IGEOM=IPPT
  364. ELSE
  365. IGEOM=IMAMOD
  366. ENDIF
  367. SEGDES IMODEL
  368. 11 CONTINUE
  369. CALL ECROBJ('MAILLAGE',IGEOM)
  370. CALL VERSEN
  371. CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU)
  372. IF (IERR.NE.0) THEN
  373. IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  374. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  375. RETURN
  376. ENDIF
  377. *
  378. IF (KMODEL(/1).GT.1) THEN
  379. MELEME=IGEOM
  380. SEGSUP MELEME
  381. ENDIF
  382. SEGDES MMODEL
  383. *
  384. *
  385. * ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM
  386. *
  387. IF (IPCHE1.EQ.0.AND.IPCHM1.EQ.0) THEN
  388. CALL ZEROP(IPMOD,MOT,IPCH1)
  389. IF (IERR.NE.0) RETURN
  390. MCHEL1=IPCH1
  391. SEGACT MCHEL1
  392. NSOUS=MCHEL1.ICHAML(/1)
  393. DO 12 ISOUS=1,NSOUS
  394. MCHAM1=MCHEL1.ICHAML(ISOUS)
  395. SEGACT MCHAM1
  396. MELVA1=MCHAM1.IELVAL(1)
  397. SEGACT MELVA1*MOD
  398. N1PTEL=MELVA1.VELCHE(/1)
  399. N1EL =MELVA1.VELCHE(/2)
  400. DO 13 IGAU=1,N1PTEL
  401. DO 13 IB=1,N1EL
  402. MELVA1.VELCHE(IGAU,IB)=P
  403. 13 CONTINUE
  404. SEGDES MELVA1
  405. SEGDES MCHAM1
  406. 12 CONTINUE
  407. SEGDES MCHEL1
  408. ELSE IF (IPCHE1.NE.0) THEN
  409. *
  410. * On transforme le CHPOINT en MCHAML aux pts de Gauss pour la rigidite
  411. *
  412. CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,3)
  413. IF (IERR.NE.0) THEN
  414. IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  415. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  416. RETURN
  417. ENDIF
  418. ELSE
  419. *
  420. * On change eventuellement le support du MCHAML
  421. *
  422. CALL QUESUP(0,IPCHE,0,0,ISUP1,ISUP2)
  423. IPCH1=IPCHE
  424. ENDIF
  425. *
  426. * ACTIVATION DU MODEL
  427. *
  428. MMODEL=IPMOD
  429. SEGACT MMODEL
  430. NSOUS=KMODEL(/1)
  431. DO 100 ISOUS=1,NSOUS
  432. *
  433. * INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  434. *
  435. N1=1
  436. L1=6
  437. N3=5
  438. SEGINI MCHELM
  439. IPCHEL=MCHELM
  440. TITCHE='FORCES'
  441. IFOCHE=IFOUR
  442. *
  443. * ON RECUPERE L INFORMATION GENERALE
  444. *
  445. IMODEL=KMODEL(ISOUS)
  446. SEGACT IMODEL
  447. IPMAIL=IMAMOD
  448. CONM =CONMOD
  449. IMACHE(1)=IPMAIL
  450. *
  451. * TRAITEMENT DU MODEL
  452. *
  453. MELE=NEFMOD
  454. MELEME=IMAMOD
  455. *
  456. * INFORMATION SUR L ELEMENT FINI
  457. *
  458. * CALL ELQUOI (MELE,0,3,IPINF,IMODEL)
  459. IF (IERR.NE.0) THEN
  460. SEGDES IMODEL,MMODEL
  461. SEGSUP MCHELM
  462. IF (IFLAG.EQ.0) CALL DTMODL (IPMOD)
  463. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  464. CALL DTCHAM(IPCH1)
  465. RETURN
  466. ENDIF
  467. *
  468. * INFO=IPINF
  469. MFR =INFELE(13)
  470. * IPTINT=INFELE(11)
  471. IPTINT=infmod(5)
  472. IPTNOE=INFMOD(8)
  473. *
  474. * CREATION DU TABLEAU INFO
  475. *
  476. CALL IDENT (IPMAIL,CONM,IPCH1,0,INFOS,IRTD)
  477. IF (IRTD.EQ.0) THEN
  478. SEGDES IMODEL,MMODEL
  479. SEGSUP MCHELM
  480. IF (IFLAG.EQ.0) CALL DTMODL (IPMOD)
  481. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  482. CALL DTCHAM(IPCH1)
  483. RETURN
  484. ENDIF
  485. *
  486. INFCHE(1,1)=0
  487. INFCHE(1,2)=0
  488. INFCHE(1,3)=NHRM
  489. INFCHE(1,4)=IPTINT
  490. INFCHE(1,5)=0
  491. *
  492. SEGACT MELEME
  493. NBELEM=NUM(/2)
  494. NBNN=NUM(/1)
  495. IPPORE=0
  496. IF(MFR.EQ.33) IPPORE=NBNN
  497. *
  498. MINTE=IPTINT
  499. SEGACT,MINTE
  500. *
  501. * RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION
  502. *
  503. NCARA=0
  504. NCARF=0
  505. MOCARA=0
  506. NFOR=0
  507. MOFORC=0
  508. *
  509. NBROBL=1
  510. NBRFAC=0
  511. SEGINI NOMID
  512. MOSCAL=NOMID
  513. LESOBL(1)='SCAL'
  514. *
  515. NBTYPE=1
  516. SEGINI NOTYPE
  517. MOTYPE=NOTYPE
  518. TYPE(1)='REAL*8'
  519. *
  520. CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYPE,1,INFOS,3,IVASCA)
  521. SEGSUP NOTYPE
  522. IF (IERR.NE.0) GOTO 9990
  523. SEGDES NOMID
  524. MPTVAL=IVASCA
  525. IPTVPR=IVAL(1)
  526. *
  527. * CHANGEMENT EVENTUEL DU SUPPORT DANS LE CAS OU UN MCHAML A ETE FOURNI
  528. *
  529. IF (IPCHM1.NE.0) THEN
  530. IF (ISUP2.NE.3.AND.ISUP2.NE.5.AND.ISUP2.NE.2) THEN
  531. IF (ISUP2.EQ.4) THEN
  532. CALL ERREUR(609)
  533. GOTO 9997
  534. ELSE IF (ISUP2.EQ.1) THEN
  535. IVPRES = IPTVPR
  536. CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  537. ENDIF
  538. ENDIF
  539. ENDIF
  540. *
  541. *
  542. * RECHERCHE DES NOMS DE COMPOSANTES
  543. *
  544. if(lnomid(2).ne.0) then
  545. nomid=lnomid(2)
  546. segact nomid
  547. moforc=nomid
  548. nfor=lesobl(/2)
  549. lsupfo=.false.
  550. nfac=0
  551. else
  552. lsupfo=.true.
  553. CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC)
  554. endif
  555. NCOMP=NFOR
  556. nomid=moforc
  557. segact nomid
  558. IF(IFOUR.EQ.-3) NCOMP=NFOR-3
  559. *
  560. * CREATION DU MCHAML DE LA SOUS ZONE
  561. *
  562. IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45.OR.MELE.EQ.93) THEN
  563. N1PTEL=3
  564. ELSE IF (MELE.EQ.44) THEN
  565. N1PTEL=2
  566. ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN
  567. N1PTEL=NBNN
  568. ELSE
  569. *
  570. * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  571. *
  572. MOTERR(1:4)=NOMTP(MELE)
  573. MOTERR(5:12)='FPCOQU '
  574. CALL ERREUR(86)
  575. GOTO 9990
  576. ENDIF
  577. *
  578. N1EL=NBELEM
  579. N2PTEL=0
  580. N2EL =0
  581. N2=NCOMP
  582. SEGINI MCHAML
  583. ICHAML(1)=MCHAML
  584. NS=1
  585. NCOSOU=NCOMP
  586. SEGINI MPTVAL
  587. IVAFOR=MPTVAL
  588. NOMID=MOFORC
  589. SEGACT NOMID
  590. DO 4 ICOMP=1,NCOMP
  591. NOMCHE(ICOMP)=LESOBL(ICOMP)
  592. TYPCHE(ICOMP)='REAL*8'
  593. SEGINI MELVAL
  594. IELVAL(ICOMP)=MELVAL
  595. IVAL(ICOMP)=MELVAL
  596. 4 CONTINUE
  597. SEGDES NOMID
  598. *_______________________________________________________________________
  599. *
  600. * CALCUL DES FORCES NODALES EQUIVALENTES
  601. * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  602. *_______________________________________________________________________
  603. *
  604. IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45
  605. 1 .OR.MELE.EQ.93) THEN
  606. *
  607. * ELEMENTS COQ3 , DKT OU DKTC
  608. * ---------------------------
  609. CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR)
  610. ELSE IF (MELE.EQ.44) THEN
  611. *
  612. * ELEMENT COQ2
  613. * ------------
  614. *
  615. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  616. *
  617. IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN
  618. CALL LIROBJ('MCHAML',IPCHE2,0,IRT3)
  619. IND=1
  620. IF (IERR.NE.0) GOTO 9990
  621. IF (IPCHE2.NE.0) THEN
  622. *
  623. * Verification du lieu support du MCHAML de caracteristique
  624. *
  625. CALL QUESUP(IPMODL,IPCHE2,3,1,ISUP,IRETCA)
  626. IF (ISUP.GT.1) GOTO 9990
  627. *
  628. * CREATION DU TABLEAU INFO
  629. *
  630. CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  631. IF (IRTD.EQ.0) GOTO 9990
  632. *
  633. NCARA=0
  634. NCARF=0
  635. NBROBL=0
  636. NBRFAC=1
  637. SEGINI NOMID
  638. MOCARA=NOMID
  639. LESFAC(1)='DIM3'
  640. *
  641. NBTYPE=1
  642. SEGINI NOTYPE
  643. MOTYPE=NOTYPE
  644. TYPE(1)='REAL*8'
  645. *
  646. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,0,
  647. + INFOS,3,IVACAR)
  648. SEGSUP NOTYPE
  649. IF (IERR.NE.0) GOTO 9990
  650. NCARA=NBROBL
  651. NCARF=NBRFAC
  652. NCARR=NCARA+NCARF
  653. *
  654. IF (ISUP.EQ.1) THEN
  655. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  656. ENDIF
  657. *
  658. SEGDES NOMID
  659. ENDIF
  660. ENDIF
  661. *
  662. CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR)
  663. ELSE IF (MELE.EQ.49) THEN
  664. *
  665. * ELEMENTS COQ4
  666. * -------------
  667. *
  668. CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR)
  669. ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  670. *
  671. * ELEMENTS COQ6 OU COQ8
  672. * ---------------------
  673. IF(IPCHE2.EQ.0) THEN
  674. CALL LIROBJ('MCHAML',IPCHE2,1,IRT3)
  675. IF (IRT3.EQ.0) GOTO 9990
  676. *
  677. * Verification du lieu support du MCHAML de caracteristique
  678. *
  679. CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP,IRETCA)
  680. IF (ISUP.GT.1) GOTO 9990
  681. ENDIF
  682. *____________________________________________________________________
  683. *
  684. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  685. * CARACTERISTIQUES POUR LES COQ8 ET COQ6
  686. *____________________________________________________________________
  687. *
  688. IVACAR=0
  689. NCARA=0
  690. NCARF=0
  691. NBROBL=1
  692. NBRFAC=0
  693. SEGINI NOMID
  694. MOCARA=NOMID
  695. LESOBL(1)='EPAI'
  696. IF (IFLAG.EQ.0) THEN
  697. *
  698. * ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL
  699. * DONNE CORRESPONDE A CELUI DE IPCHE21
  700. *
  701. DO 60 KISOUS=1,NSOUS1
  702. IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN
  703. IPMAI1=MAIL1(KISOUS)
  704. GOTO 61
  705. ENDIF
  706. 60 CONTINUE
  707. *
  708. * NE DOIT NORMALEMENT JAMAIS SE PRODUIRE
  709. *
  710. CALL ERREUR (472)
  711. GOTO 9990
  712. ELSE
  713. IPMAI1=IPMAIL
  714. ENDIF
  715. 61 CONTINUE
  716. *
  717. NBTYPE=1
  718. SEGINI NOTYPE
  719. MOTYPE=NOTYPE
  720. TYPE(1)='REAL*8'
  721. *
  722. CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
  723. SEGSUP NOTYPE
  724. IF (IERR.NE.0) GOTO 9990
  725. NCARA=NBROBL
  726. NCARF=NBRFAC
  727. NCARR=NCARA+NCARF
  728. *
  729. IF (ISUP.EQ.1) THEN
  730. CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  731. ENDIF
  732. *
  733. SEGDES NOMID
  734. *
  735. CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR)
  736. ELSE
  737. *
  738. * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  739. *
  740. MOTERR(1:4)=NOMTP(MELE)
  741. MOTERR(5:12)='FPCOQU'
  742. CALL ERREUR(86)
  743. GOTO 9990
  744. ENDIF
  745. *
  746. * ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  747. *
  748. CALL CHAMPO(IPCHEL,0,IPCHPO,IRET)
  749. CALL DTCHAM(IPCHEL)
  750. IF (IRET.EQ.0) GOTO 9990
  751. *
  752. IF (ISOUS.GT.1) THEN
  753. CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0)
  754. CALL DTCHPO(IPCHPO)
  755. CALL DTCHPO(IPTFP)
  756. IF (IRET.EQ.0) GOTO 9990
  757. IPTFP=IRET
  758. ELSE
  759. IPTFP=IPCHPO
  760. ENDIF
  761. *
  762. SEGDES IMODEL
  763. *
  764. IF (ISUP.EQ.1) THEN
  765. CALL DTMVAL(IVACAR,3)
  766. ELSE
  767. CALL DTMVAL(IVACAR,1)
  768. ENDIF
  769. *
  770. MPTVAL=IVASCA
  771. MELVAL=IVAL(1)
  772. SEGDES MELVAL
  773. SEGSUP MPTVAL
  774. *
  775. MPTVAL=IVAFOR
  776. SEGSUP MPTVAL
  777. *
  778. NOMID=MOFORC
  779. if(lsupfo)SEGSUP NOMID
  780. NOMID=MOSCAL
  781. SEGSUP NOMID
  782. SEGDES,MINTE
  783. SEGDES MELEME
  784. NOMID=MOCARA
  785. IF (MOCARA.NE.0) SEGSUP NOMID
  786. *
  787. 100 CONTINUE
  788. IRET=1
  789. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  790. CALL DTCHAM(IPCH1)
  791. SEGDES MMODEL
  792. IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  793. RETURN
  794. *
  795. *
  796. *
  797. 9990 CONTINUE
  798. IRET=0
  799. SEGSUP MCHELM
  800. *
  801. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  802. *
  803. IF (ISUP.EQ.1) THEN
  804. CALL DTMVAL(IVACAR,3)
  805. ELSE
  806. CALL DTMVAL(IVACAR,1)
  807. ENDIF
  808. *
  809. CALL DTMVAL(IVAFOR,1)
  810. *
  811. SEGDES,MINTE
  812. SEGDES MELEME
  813. *
  814. MPTVAL=IVASCA
  815. MELVAL=IVAL(1)
  816. SEGDES MELVAL
  817. SEGSUP MPTVAL
  818. *
  819. NOMID=MOCARA
  820. IF (MOCARA.NE.0) SEGSUP NOMID
  821. NOMID=MOFORC
  822. IF (lsupfo.and.MOFORC.NE.0) SEGSUP NOMID
  823. *
  824. 9997 CONTINUE
  825. SEGDES IMODEL
  826. SEGDES MMODEL
  827. *
  828. IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  829. IF (JPMAIL.NE.0) SEGSUP JPMAIL
  830. *
  831. CALL DTCHAM(IPCH1)
  832. *
  833. RETURN
  834. END
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  
  841.  
  842.  
  843.  

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