Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes :

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

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