Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes :

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

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