Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes :

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

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