Télécharger fofis1.eso

Retour à la liste

Numérotation des lignes :

  1. C FOFIS1 SOURCE GF238795 18/02/01 21:15:33 9724
  2. SUBROUTINE FOFIS1(IPMODL,IPCHE1,IPCHE2,IPCHE3,
  3. 1 IPCHE4,IPCHP1,IRET)
  4. *
  5. ************************************************************************
  6. *
  7. * ENTREES :
  8. * _________
  9. *
  10. * IPMODL = POINTEUR SUR UN MMODEL
  11. * IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES
  12. * IPCHE2 = POINTEUR SUR UN MCHAML DE GRADIENT
  13. * IPCHE3 = POINTEUR SUR UN MCHAML DE GRADIENT DE FLEXION
  14. * IPCHE4 = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  15. *
  16. * SORTIES :
  17. * __________
  18. *
  19. * IPCHP1 = POINTEUER SUR UN CHPOINT DE FORCES NODALES
  20. * IRET = 1 OU 0 SUIVANT SUCCES OU PAS
  21. *
  22. ************************************************************************
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. *
  26. -INC CCOPTIO
  27. -INC CCHAMP
  28. -INC SMCHAML
  29. -INC SMCHPOI
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC SMMODEL
  33. -INC SMINTE
  34. *
  35. SEGMENT WRK1
  36. REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB)
  37. ENDSEGMENT
  38. *
  39. SEGMENT WRK2
  40. REAL*8 SHPWRK(6,NBNO), GRAD(9)
  41. REAL*8 GRAF(9),BPRIM(NSTRS,LRE)
  42. ENDSEGMENT
  43. *
  44. SEGMENT WRK3
  45. REAL*8 WORK(LW)
  46. ENDSEGMENT
  47. *
  48. SEGMENT WRK4
  49. REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  50. ENDSEGMENT
  51. *
  52. SEGMENT MPTVAL
  53. INTEGER IPOS(NS) ,NSOF(NS)
  54. INTEGER IVAL(NCOSOU)
  55. CHARACTER*16 TYVAL(NCOSOU)
  56. ENDSEGMENT
  57. *
  58. SEGMENT NOTYPE
  59. CHARACTER*16 TYPE(NBTYPE)
  60. ENDSEGMENT
  61. *
  62. PARAMETER ( NINF=3 )
  63. INTEGER INFOS(NINF)
  64. CHARACTER*(NCONCH) CONM
  65. LOGICAL lsupfo,lsupgd,lsupgf,lsupco
  66. INTEGER ISUP1,ISUP2,ISUP3,ISUP4
  67. *
  68. ISUP1=0
  69. ISUP2=0
  70. ISUP3=0
  71. ISUP4=0
  72. IRET = 0
  73. IPCHP1 = 0
  74. *
  75. * Verification du sous-type et du lieu support du MCHAML de contrain
  76. *
  77. MCHELM=IPCHE1
  78. SEGACT,MCHELM
  79. IF(TITCHE.NE.'CONTRAINTES')THEN
  80. MOTERR(1:8)='CONTRAIN'
  81. MOTERR(9:16)=' '
  82. CALL ERREUR(109)
  83. SEGDES,MCHELM
  84. RETURN
  85. ENDIF
  86. SEGDES,MCHELM
  87. CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  88. IF (ISUP1.GT.1) RETURN
  89. *
  90. * Verification du sous-type et du lieu support du MCHAML de gradient
  91. *
  92. MCHELM=IPCHE2
  93. SEGACT,MCHELM
  94. IF(TITCHE.NE.'GRADIENT')THEN
  95. MOTERR(1:8)='GRADIENT'
  96. MOTERR(9:16)=' '
  97. CALL ERREUR(109)
  98. SEGDES,MCHELM
  99. RETURN
  100. ENDIF
  101. SEGDES,MCHELM
  102. CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  103. IF (ISUP2.GT.1) RETURN
  104. *
  105. * Verification du sous-tyoe et du lieu support du MCHAML
  106. * de gradient de flexion
  107. *
  108. IF (IPCHE3.NE.0) THEN
  109. MCHELM=IPCHE3
  110. SEGACT,MCHELM
  111. IF(TITCHE.NE.'GRADIENT DE FLEXION')THEN
  112. MOTERR(1:8)='GRAFLEXI'
  113. MOTERR(9:16)=' '
  114. CALL ERREUR(109)
  115. SEGDES,MCHELM
  116. RETURN
  117. ENDIF
  118. SEGDES,MCHELM
  119. CALL QUESUP (IPMODL,IPCHE3,5,0,ISUP3,IRET3)
  120. IF (ISUP3.GT.1) RETURN
  121. ENDIF
  122. *
  123. * Verification du sous-type et du lieu support du MCHAML
  124. * de caracteristiques
  125. *
  126. IF (IPCHE4.NE.0) THEN
  127. MCHELM=IPCHE4
  128. SEGACT,MCHELM
  129. IF(TITCHE.NE.'CARACTERISTIQUES')THEN
  130. MOTERR(1:8)='CARACTER'
  131. MOTERR(9:16)=' '
  132. CALL ERREUR(109)
  133. SEGDES,MCHELM
  134. RETURN
  135. ENDIF
  136. SEGDES,MCHELM
  137. CALL QUESUP (IPMODL,IPCHE4,5,0,ISUP4,IRET4)
  138. IF (ISUP4.GT.1) RETURN
  139. ENDIF
  140. C_______________________________________________________________________
  141. C
  142. C ACTIVATION DU MODELE
  143. C_______________________________________________________________________
  144. C
  145. MMODEL=IPMODL
  146. SEGACT MMODEL
  147. NSOUS=KMODEL(/1)
  148. C
  149. C INITIALISATION DU MCHELM DE FORCES
  150. C
  151. L1=6
  152. N1=NSOUS
  153. N3=6
  154. SEGINI MCHELM
  155. IPCHE5=MCHELM
  156. IFOCHE=IFOUR
  157. TITCHE='FORCES'
  158. C_______________________________________________________________________
  159. C
  160. C BOUCLE SUR LES SOUS ZONES
  161. C_______________________________________________________________________
  162. C
  163. DO 500 ISOUS=1,NSOUS
  164. C
  165. IVASTR=0
  166. NSTR=0
  167. IVAGRA=0
  168. NGRAD=0
  169. IVAGRF=0
  170. NGRAF=0
  171. IVACAR=0
  172. NCARR=0
  173. IVAFOR=0
  174. C
  175. C TRAITEMENT DU MODELE
  176. C
  177. IMODEL=KMODEL(ISOUS)
  178. SEGACT IMODEL
  179. CONM=CONMOD
  180. MELE=NEFMOD
  181. IPMAIL=IMAMOD
  182. C
  183. C ACTIVATION DU MELEME
  184. C
  185. MELEME=IPMAIL
  186. SEGACT MELEME
  187. NBNN=NUM(/1)
  188. NBELEM=NUM(/2)
  189. C
  190. C RECOPIE DU MCHELM
  191. C
  192. IMACHE(ISOUS)=IPMAIL
  193. C
  194. C CREATION DU TABLEAU INFOS
  195. C
  196. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  197. IF (IRTD.EQ.0) GOTO 991
  198. C_______________________________________________________________________
  199. C
  200. C INFORMATIONS SUR L'{L{MENT FINI
  201. C_______________________________________________________________________
  202. C
  203. * CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  204. * IF (IERR.NE.0) GOTO 991
  205. * INFO=IPINF
  206. NBPGS= INFELE(4)
  207. NBPGAU = INFELE(6)
  208.  
  209. * MINTE = INFELE(11)
  210. MINTE=infmod(5)
  211. IPMINT= MINTE
  212. MINTE1= INFMOD(8)
  213. NSTRS = INFELE(16)
  214. MFR = INFELE(13)
  215. LW = INFELE(7)
  216. NDDL = INFELE(15)
  217. LRE = INFELE(9)
  218. IPPORE=0
  219. IF(MFR.EQ.33) IPPORE=NBNN
  220. LVAL = (LRE*(LRE+1))/2
  221. NHRM = NIFOUR
  222. C
  223. SEGACT MINTE
  224. NBNO=SHPTOT(/2)
  225. C
  226. C REMPLIR LE TABLEAU DE L'INFORMATION DE MCHAML
  227. C
  228. INFCHE(ISOUS,1)=0
  229. INFCHE(ISOUS,2)=0
  230. INFCHE(ISOUS,3)=NIFOUR
  231. INFCHE(ISOUS,4)=0
  232. INFCHE(ISOUS,5)=0
  233. INFCHE(ISOUS,6)=1
  234. C_______________________________________________________________________
  235. C
  236. C NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
  237. C_______________________________________________________________________
  238. C
  239. if(lnomid(2).ne.0) then
  240. nomid = lnomid(2)
  241. segact nomid
  242. moforc=nomid
  243. nfor=lesobl(/2)
  244. nfac=0
  245. lsupfo=.false.
  246. else
  247. CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  248. lsupfo=.true.
  249. endif
  250. C
  251. C CREATION DU MCHAML
  252. C
  253. N2=NFOR
  254. SEGINI MCHAML
  255. ICHAML(ISOUS)=MCHAML
  256. NOMID=MOFORC
  257. SEGACT NOMID
  258. DO 110 ICOMP=1,NFOR
  259. NOMCHE(ICOMP)=LESOBL(ICOMP)
  260. TYPCHE(ICOMP)='REAL*8'
  261. 110 CONTINUE
  262. if(lsupfo)SEGSUP NOMID
  263. C_______________________________________________________________________
  264. C
  265. C NOMS DE COMPOSANTES NECESSAIRES(CONTRAINTES,GRADIENT,
  266. C GRADIENT DE FLEXION )
  267. C_______________________________________________________________________
  268. C
  269. if(lnomid(4).ne.0) then
  270. nomid=lnomid(4)
  271. segact nomid
  272. mostrs=nomid
  273. nstr=lesobl(/2)
  274. nfac=lesfac(/2)
  275. lsupco=.false.
  276. else
  277. lsupco=.true.
  278. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  279. endif
  280. C
  281. if(lnomid(3).ne.0) then
  282. nomid=lnomid(3)
  283. segact nomid
  284. mograd=nomid
  285. ngrad=lesobl(/2)
  286. nfac=lesfac(/2)
  287. lsupgd=.false.
  288. else
  289. lsupgd=.true.
  290. CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC)
  291. endif
  292. C
  293. * write(6,*) ' lnomid() ' ,(lnomid(iou),iou=1,12)
  294. if(lnomid(11).ne.0) then
  295. nomid=lnomid(11)
  296. segact nomid
  297. mograf=nomid
  298. ngraf=lesobl(/2)
  299. nfac=lesfac(/2)
  300. lsupgf=.false.
  301. else
  302. lsupgf=.true.
  303. CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  304. endif
  305. C
  306. C VERIFICATION DE LEUR PRESENCE
  307. C
  308. NBTYPE=1
  309. SEGINI NOTYPE
  310. MOTYPE=NOTYPE
  311. TYPE(1)='REAL*8'
  312. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  313. NOMID=MOSTRS
  314. if(lsupco)SEGSUP NOMID
  315. IF (IERR.NE.0)THEN
  316. SEGSUP NOTYPE
  317. GOTO 510
  318. ENDIF
  319. *
  320. IF (ISUP1.EQ.1) THEN
  321. CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  322. ENDIF
  323. *
  324. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA)
  325. NOMID=MOGRAD
  326. * write(6,*) ' lsupgd 1',lsupgd
  327. if(lsupgd)SEGSUP NOMID
  328. IF (IERR.NE.0)THEN
  329. SEGSUP NOTYPE
  330. GOTO 510
  331. ENDIF
  332. *
  333. IF (ISUP2.EQ.1) THEN
  334. CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE,MOGRAD,MELE)
  335. ENDIF
  336. *
  337. IF(NGRAF.NE.0)THEN
  338. IF(IPCHE3.NE.0)THEN
  339. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF)
  340. NOMID=MOGRAF
  341. if(lsupgf)SEGSUP NOMID
  342. IF (IERR.NE.0)THEN
  343. SEGSUP NOTYPE
  344. GOTO 510
  345. ENDIF
  346. *
  347. IF (ISUP3.EQ.1) THEN
  348. CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE,MOGRAF,MELE)
  349. ENDIF
  350. ELSE
  351. MOTERR(1:8)='GRAFLEXI'
  352. MOTERR(9:12)=NOMTP(MELE)
  353. MOTERR(13:20)='FOFISS'
  354. CALL ERREUR(145)
  355. GO TO 510
  356. ENDIF
  357. ENDIF
  358. SEGSUP NOTYPE
  359. C_____________________________________________________________________
  360.  
  361. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
  362. C____________________________________________________________________
  363. C
  364. NBROBL=0
  365. NBRFAC=0
  366. MOCARA=0
  367. IVECT=0
  368. NOMID=0
  369. ** write(6,*) ' mfr ifour ipche4 ngraf ipche3 '
  370. * $ ,mfr,ifour,ipche4, ngraf, ipche3
  371. * write(6,*) ' lsupgd 2',lsupgd
  372. *
  373. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  374. *
  375. IF((MFR.EQ.1.OR.MFR.EQ.33).AND.IFOUR.EQ.-2.
  376. + AND.IPCHE4.NE.0)THEN
  377. NBROBL=0
  378. NBRFAC=1
  379. SEGINI NOMID
  380. MOCARA=NOMID
  381. LESFAC(1)='DIM3'
  382. *
  383. NBTYPE=1
  384. SEGINI NOTYPE
  385. MOTYPE=NOTYPE
  386. TYPE(1)='REAL*8'
  387. *
  388. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  389. *
  390. ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  391. NBROBL=1
  392. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  393. NBRFAC=2
  394. ELSE
  395. NBRFAC=1
  396. ENDIF
  397. SEGINI NOMID
  398. MOCARA=NOMID
  399. LESOBL(1)='EPAI'
  400. LESFAC(1)='EXCE'
  401. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3'
  402. *
  403. NBTYPE=1
  404. SEGINI NOTYPE
  405. MOTYPE=NOTYPE
  406. TYPE(1)='REAL*8'
  407. *
  408. * SECTION POUR LES BARRES
  409. *
  410. ELSE IF (MFR.EQ.27) THEN
  411. NBROBL=1
  412. SEGINI NOMID
  413. MOCARA=NOMID
  414. LESOBL(1)='SECT'
  415. *
  416. NBTYPE=1
  417. SEGINI NOTYPE
  418. MOTYPE=NOTYPE
  419. TYPE(1)='REAL*8'
  420. *
  421. * CARACTERISTIQUES POUR LES POUTRES
  422. *
  423. ELSE IF (MFR.EQ.7 ) THEN
  424. NBROBL=4
  425. NBRFAC=3
  426. SEGINI NOMID
  427. MOCARA=NOMID
  428. LESOBL(1)='TORS'
  429. LESOBL(2)='INRY'
  430. LESOBL(3)='INRZ'
  431. LESOBL(4)='SECT'
  432. LESFAC(1)='SECY'
  433. LESFAC(2)='SECZ'
  434. LESFAC(3)='VECT'
  435. IVECT=1
  436. *
  437. NBTYPE=7
  438. SEGINI NOTYPE
  439. MOTYPE=NOTYPE
  440. TYPE(1)='REAL*8'
  441. TYPE(2)='REAL*8'
  442. TYPE(3)='REAL*8'
  443. TYPE(4)='REAL*8'
  444. TYPE(5)='REAL*8'
  445. TYPE(6)='REAL*8'
  446. TYPE(7)='POINTEURPOINT '
  447. *
  448. * CARACTERISTIQUES POUR LES TUYAUX
  449. *
  450. ELSE IF (MFR.EQ.13) THEN
  451. NBROBL=2
  452. NBRFAC=2
  453. SEGINI NOMID
  454. MOCARA=NOMID
  455. LESOBL(1)='EPAI'
  456. LESOBL(2)='RAYO'
  457. LESFAC(1)='RACO'
  458. LESFAC(2)='VECT'
  459. IVECT=1
  460. *
  461. NBTYPE=4
  462. SEGINI NOTYPE
  463. MOTYPE=NOTYPE
  464. TYPE(1)='REAL*8'
  465. TYPE(2)='REAL*8'
  466. TYPE(3)='REAL*8'
  467. TYPE(4)='POINTEURPOINT '
  468. *
  469. * CARACTERISTIQUES POUR LES LINESPRING
  470. *
  471. ELSE IF (MFR.EQ.15) THEN
  472. NBROBL=5
  473. SEGINI NOMID
  474. MOCARA=NOMID
  475. LESOBL(1)='EPAI'
  476. LESOBL(2)='FISS'
  477. LESOBL(3)='VX '
  478. LESOBL(4)='VY '
  479. LESOBL(5)='VZ '
  480. *
  481. NBTYPE=1
  482. SEGINI NOTYPE
  483. MOTYPE=NOTYPE
  484. TYPE(1)='REAL*8'
  485. *
  486. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  487. *
  488. ELSE IF (MFR.EQ.17) THEN
  489. NBROBL=9
  490. SEGINI NOMID
  491. MOCARA=NOMID
  492. LESOBL(1)='RAYO'
  493. LESOBL(2)='EPAI'
  494. LESOBL(3)='VX '
  495. LESOBL(4)='VY '
  496. LESOBL(5)='VZ '
  497. LESOBL(6)='VXF '
  498. LESOBL(7)='VYF '
  499. LESOBL(8)='VZF '
  500. LESOBL(9)='ANGL'
  501. *
  502. NBTYPE=1
  503. SEGINI NOTYPE
  504. MOTYPE=NOTYPE
  505. TYPE(1)='REAL*8'
  506. *
  507. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  508. *
  509. ELSE IF (MFR.EQ.37) THEN
  510. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  511. NBROBL=4
  512. SEGINI NOMID
  513. MOCARA=NOMID
  514. LESOBL(1)='SCEL'
  515. LESOBL(2)='SFLU'
  516. LESOBL(3)='EPS '
  517. LESOBL(4)='XINE'
  518. ELSE
  519. NBROBL=3
  520. SEGINI NOMID
  521. MOCARA=NOMID
  522. LESOBL(1)='SCEL'
  523. LESOBL(2)='SFLU'
  524. LESOBL(3)='EPS '
  525. ENDIF
  526. *
  527. NBTYPE=1
  528. SEGINI NOTYPE
  529. MOTYPE=NOTYPE
  530. TYPE(1)='REAL*8'
  531. ENDIF
  532.  
  533. *
  534. IF (MOCARA.NE.0) THEN
  535. IF (IPCHE4.NE.0) THEN
  536. *
  537. CALL KOMCHA(IPCHE4,IPMAIL,CONM,MOCARA,MOTYPE,1,
  538. 1 INFOS,3,IVACAR)
  539. SEGSUP NOTYPE
  540. IF (IERR.NE.0) GOTO 9990
  541. IF (IVECT.EQ.1) THEN
  542. MPTVAL=IVACAR
  543. IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  544. *
  545. * MOT CLE VECT EN CAS DE CONVERSION
  546. *
  547. IVECT=2
  548. NOMID=MOCARA
  549. SEGACT NOMID
  550. NBRFAC=NBRFAC+2
  551. SEGADJ NOMID
  552. MOCARA=NOMID
  553. LESFAC(NBRFAC-2)='VX '
  554. LESFAC(NBRFAC-1)='VY '
  555. LESFAC(NBRFAC )='VZ '
  556. *
  557. NBTYPE=1
  558. SEGINI NOTYPE
  559. MOTYPE=NOTYPE
  560. TYPE(1)='REAL*8'
  561. *
  562. CALL KOMCHA(IPCHE4,IPMAIL,CONM,MOCARA,MOTYPE,1,
  563. 1 INFOS,3,IVACAR)
  564. SEGSUP NOTYPE
  565. IF (IERR.NE.0) GOTO 510
  566. ENDIF
  567. ENDIF
  568. ELSE
  569. MOTERR(1:8)='CARACTER'
  570. MOTERR(9:12)=NOMTP(MELE)
  571. MOTERR(13:20)='FOFISS '
  572. CALL ERREUR(145)
  573. SEGSUP NOMID
  574. NCARA=0
  575. NCARF=0
  576. MOCARA=0
  577. GOTO 510
  578. ENDIF
  579. NCARA=NBROBL
  580. NCARF=NBRFAC
  581. NCARR=NCARA+NCARF
  582. *
  583. IF (ISUP4.EQ.1) THEN
  584. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  585. IF(IERR.NE.0)THEN
  586. SEGSUP NOMID
  587. ISUP4=0
  588. GOTO 510
  589. ENDIF
  590. ENDIF
  591. * write(6,*) ' lsupgd 3 ' , lsupgd
  592. SEGSUP NOMID
  593. * write(6,*) ' lsupgd 4 ' , lsupgd , nomid
  594. ENDIF
  595.  
  596. NCARA=NBROBL
  597. NCARF=NBRFAC
  598. NCARR=NCARA+NCARF
  599. C
  600. C RECHERCHE DES TAILLES DE MELVAL
  601. C
  602. N1EL=NBELEM
  603. N1PTEL=NBNN
  604. NBPTEL=N1PTEL
  605. NEL =N1EL
  606. C
  607. C CREATION DU MELVAL DE FORCES
  608. C
  609. NS=1
  610. NCOSOU=NFOR
  611. SEGINI MPTVAL
  612. IVAFOR=MPTVAL
  613. DO 100 ICOMP=1,NFOR
  614. N2PTEL=0
  615. N2EL=0
  616. SEGINI MELVAL
  617. IELVAL(ICOMP)=MELVAL
  618. IVAL(ICOMP)=MELVAL
  619. 100 CONTINUE
  620. C
  621. C=======================================================================
  622. C NUMERO DES ETIQUETTES :
  623. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  624. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  625. C 5 CONTINUE
  626. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  627. C 44 CONTINUE
  628. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  629. C=======================================================================
  630. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  631. 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  632. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  633. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  634. 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  635. C
  636. C GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  637. C 1 99,99, 4, 4, 4, 4,27,28,29,30,99,99,99,99,99,99,99,99,99,99,
  638. C 2 41,29,99,44,99,99,99,99,49,30,51,99,99,99,99,41,99,99,99,99,
  639. C 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  640. C 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  641. C
  642. 99 CONTINUE
  643. MOTERR(1:4)=NOMTP(MELE)
  644. MOTERR(5:12)='FOFISS'
  645. CALL ERREUR(86)
  646. GOTO 510
  647. C
  648. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  649. C
  650. 4 CONTINUE
  651. DIM3=1.D0
  652. NBNO=NBNN
  653. NBBB=NBNN
  654. SEGINI WRK1,WRK2
  655. I195=0
  656. I259=0
  657. DO 3004 IB=1,NBELEM
  658. C
  659. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  660. C
  661. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  662. C
  663. C MISE A 0 DES FORCES
  664. C
  665. CALL ZERO(XFORC,1,LRE)
  666. C
  667. C BOUCLE SUR LES POINTS DE GAUSS
  668. C
  669. ISDJC=0
  670. DO 5004 IGAU=1,NBPGAU
  671. C
  672. C RECUPERATION DE L'EPAISSEUR
  673. C
  674. IF (IFOUR.EQ.-2)THEN
  675. MPTVAL=IVACAR
  676. IF (IVACAR.NE.0) THEN
  677. MELVAL=IVAL(1)
  678. IF (MELVAL.NE.0) THEN
  679. IGMN=MIN(IGAU,VELCHE(/1))
  680. IBMN=MIN(IB,VELCHE(/2))
  681. DIM3=VELCHE(IGMN,IBMN)
  682. ELSE
  683. DIM3=1.D0
  684. ENDIF
  685. ENDIF
  686. ENDIF
  687. C
  688. C *****************
  689. C ON CHERCHE LES GRADIENTS
  690.  
  691. MPTVAL=IVAGRA
  692. DO 1104 ICOMP=1,9
  693.  
  694. MELVAL=IVAL(ICOMP)
  695. IBMN=MIN(IB,VELCHE(/2))
  696. IGMN=MIN(IGAU,VELCHE(/1))
  697. GRAD(ICOMP)=VELCHE(IGMN,IBMN)
  698. 1104 CONTINUE
  699. C *****************
  700. CALL BPRIMA(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,
  701. 1 DIM3,XE,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC)
  702. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  703. IF(DJAC.EQ.0.) THEN
  704. INTERR(1) = IB
  705. CALL ERREUR(259)
  706. GOTO 9904
  707. ENDIF
  708. DJAC=ABS(DJAC)*POIGAU(IGAU)
  709. C
  710. C ON CHERCHE LES CONTRAINTES
  711. C
  712. MPTVAL=IVASTR
  713. DO 6004 ICOMP=1,NSTR
  714. MELVAL=IVAL(ICOMP)
  715. IBMN=MIN(IB,VELCHE(/2))
  716. IGMN=MIN(IGAU,VELCHE(/1))
  717. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  718. 6004 CONTINUE
  719. C
  720. C CALCUL DE BPRIM*SIGMA
  721. C
  722. CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC)
  723. 5004 CONTINUE
  724. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  725. INTERR(1) = IB
  726. CALL ERREUR(195)
  727. GOTO 9904
  728. ENDIF
  729. C
  730. C ON RANGE XFORC DANS MELVAL
  731. C
  732. IE=0
  733. MPTVAL=IVAFOR
  734. DO 7004 IGAU=1,NBNN
  735. DO 7004 ICOMP=1,NFOR
  736. IE=IE+1
  737. MELVAL=IVAL(ICOMP)
  738. IBMN=MIN(IB ,VELCHE(/2))
  739. VELCHE(IGAU,IBMN)=XFORC(IE)
  740. 7004 CONTINUE
  741. 3004 CONTINUE
  742.  
  743. 9904 CONTINUE
  744. SEGSUP WRK1,WRK2
  745. GOTO 510
  746. C ------------------------------------------------------------------
  747. C ELEMENT COQ3 (NON) | | | | | | | | | | | | | | | | | | |
  748. C
  749. *********************************************************************
  750. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  751. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  752. *********************************************************************
  753. * 27 CONTINUE
  754. * NBBB=NBNN
  755. * LW=151
  756. * SEGINI WRK1,WRK3
  757. * DO 3027 IB=1,NBELEM
  758. * IBMN1=MIN(IB,NEL1)
  759. * IBMN4=MIN(IB,NEL4)
  760. *C
  761. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  762. *C
  763. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  764. *C
  765. *C ON REACTUALISE LA GEOMETRIE
  766. *C
  767. * IF(IRT4.EQ.0) GOTO 8027
  768. * DO 4027 IC=1,3
  769. * DO 4027 ID=1,3
  770. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  771. * 4027 CONTINUE
  772. * 8027 CONTINUE
  773. *C
  774. *C MISE A ZERO DES FORCES INTERNES
  775. *C
  776. * CALL ZERO(XFORC,1,LRE)
  777. *C
  778. *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  779. *
  780. * EPAIST=XZER
  781. * DO 5027 IC=1,NBPTE4
  782. * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  783. *5027 CONTINUE
  784. * EPAIST=EPAIST/NBPTE4
  785. * ****************
  786. * ON CHERCHE LES GRADIENTS ET GRAFLEXIS
  787. *
  788. * DO 1127 IC=1,9
  789. * GRAD(IC)=MELVA2.VELCHA(1,IC,IBMN1)
  790. *1127 CONTINUE
  791. * IF (IRT5.EQ.0) GO TO 1327
  792. * DO 1227 IC=1,9
  793. * GRAF(IC)=MELVA5.VELCHA(1,IC,IBMN1)
  794. *1227 CONTINUE
  795. *1327 CONTINUE
  796. * ****************
  797. * ON CHERCHE LES CONTRAINTES
  798. *
  799. * DO 7027 IC=1,NCOEL1
  800. * XSTRS(IC)=MELVA1.VELCHA(1,IC,IBMN1)
  801. * 7027 CONTINUE
  802. *C
  803. *C ON CALCULE B*SIGMA
  804. *C
  805. * CALL BSIGCO(EPAIST,XE,XSTRS,XFORC,WORK,WORK,WORK(82),WORK(88),
  806. * * WORK(92),WORK(119),WORK(128),WORK(134),WORK(143),WORK(143),
  807. * * WORK(146),WORK(149))
  808. *C
  809. *C RANGEMENT DANS MELVAL
  810. *C
  811. * IE=0
  812. * DO 9027 IC=1,NBNN
  813. * DO 9027 ID=1,6
  814. * IE=IE+1
  815. * VELCHA(IC,ID,IB)=XFORC(IE)
  816. * 9027 CONTINUE
  817. * 3027 CONTINUE
  818. * SEGSUP WRK1,WRK3
  819. * GOTO 510
  820. *C
  821. *C ELEMENT DKT (NON)
  822. *C
  823. *********************************************************************
  824. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  825. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  826. *********************************************************************
  827. * 28 CONTINUE
  828. * NBNO=NBNN
  829. * NBBB=NBNN
  830. * SEGINI WRK1,WRK2,WRK3,WRK4
  831. * DO 3028 IB=1,NBELEM
  832. * IBMN1=MIN(IB,NEL1)
  833. * IBMN4=MIN(IB,NEL4)
  834. *C
  835. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  836. *C
  837. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  838. *C
  839. *C ON REACTUALISE LA GEOMETRIE
  840. *C
  841. * IF(IRT4.EQ.0) GOTO 8028
  842. * DO 4028 IC=1,NBPTE3
  843. * DO 4028 ID=1,3
  844. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  845. * 4028 CONTINUE
  846. * 8028 CONTINUE
  847. *C
  848. *C MISE A ZERO DES FORCES INTERNES
  849. *C
  850. * CALL ZERO(XFORC,1,LRE)
  851. *C
  852. * CALL VPAST(XE,BPSS)
  853. *C BPSS STOCKE LA MATRICE DE PASSAGE
  854. * CALL VCORLC (XE,XEL,BPSS)
  855. * CALL TRPOSE(BPSS)
  856. *C
  857. *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  858. *C
  859. * EPAIST=XZER
  860. * DO 5028 IC=1,NBPTE4
  861. * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  862. * 5028 CONTINUE
  863. * EPAIST=EPAIST/NBPTE4
  864. *C
  865. *C BOUCLE SUR LES POINTS DE GAUSS
  866. *C
  867. * DO 6028 IGAU=1,NBPGAU
  868.  
  869. * IGMN1=MIN(IGAU,NBPTE1)
  870. *C *******************
  871. *C ON CHERCHE LES GRADIENTS ET GRAFLEXIS
  872. *C
  873. * DO 1028 IC=1,9
  874. * GRAD(IC)=MELVA2.VELCHA(IGMN1,IC,IBMN1)
  875. * 1028 CONTINUE
  876. * IF (IRT5.EQ.0) GO TO 1328
  877. * DO 1228 IC=1,9
  878. * GRAF(IC)=MELVA5.VELCHA(IGMN1,IC,IBMN1)
  879. * 1228 CONTINUE
  880. * 1328 CONTINUE
  881. *C *******************
  882. * CALL BPRIMA(IGAU,MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,
  883. * 1 XEL,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC)
  884. * DJAC=DJAC*POIGAU(IGAU)
  885. *C
  886. *C ON CHERCHE LES CONTRAINTES
  887. *C
  888. * DO 7028 IC=1,NCOEL1
  889. * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  890. * 7028 CONTINUE
  891. *C
  892. *C ON CALCULE BPRIM*SIGMA
  893. *C
  894. * CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC)
  895. * 6028 CONTINUE
  896. *C
  897. *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  898. *C
  899. * EPA=EPAIST*EPAIST/6.
  900. * DO 1128 IC=1,3
  901. * IE=(IC-1)*6
  902. * XFORC(IE+1)=EPAIST*XFORC(IE+1)
  903. * XFORC(IE+2)=EPAIST*XFORC(IE+2)
  904. * XFORC(IE+3)= EPA*XFORC(IE+3)
  905. * XFORC(IE+4)= EPA*XFORC(IE+4)
  906. * XFORC(IE+5)= EPA*XFORC(IE+5)
  907. * 1128 CONTINUE
  908. * CALL MATVEC(XFORC,XFOLO,BPSS,6)
  909. * IE=0
  910. * DO 9028 IC=1,NBNN
  911. * DO 9028 ID=1,6
  912. * IE=IE+1
  913. * VELCHA(IC,ID,IB)=XFOLO(IE)
  914. * 9028 CONTINUE
  915. * 3028 CONTINUE
  916. * SEGSUP WRK1,WRK2,WRK3,WRK4
  917. * GOTO 510
  918. *C
  919. *C ELEMENT POUTRE (NON)
  920. *C
  921. *********************************************************************
  922. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  923. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  924. *********************************************************************
  925. * 29 CONTINUE
  926. * NBBB=NBNN
  927. * SEGINI WRK1,WRK3
  928. * DO 3029 IB=1,NBELEM
  929. * IBMN1=MIN(IB,NEL1)
  930. * IBMN4=MIN(IB,NEL4)
  931. *C
  932. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  933. *C
  934. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  935. *C
  936. *C ON REACTUALISE LA GEOMETRIE
  937. *C
  938. * IF(IRT4.EQ.0) GO TO 8029
  939. * DO 4029 IC=1,NBPTE3
  940. * DO 4029 ID=1,IDIM
  941. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  942. *4029 CONTINUE
  943. *C
  944. *C IL FAUDRAIT AUSSI MODIFIER LE VECTEUR LOCAL DE LA POUTRE
  945. *C
  946. *8029 CONTINUE
  947. *C
  948. *C MISE A ZERO DES FORCES INTERNES
  949. *C
  950. * CALL ZERO(XFORC,1,LRE)
  951. *C
  952. *C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  953. *C
  954. * DO 6029 IC=1,ICARA
  955. * WORK(IC)=MELVA4.VELCHA(1,IC,IBMN4)
  956. *6029 CONTINUE
  957. *C
  958. *C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  959. *C EQUIVALENTE (NON)
  960. *C
  961. * IF(MELE.EQ.42) CALL TUYCAR(WORK,KERRE,0)
  962. *C
  963. *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  964. *C
  965. * IE=9
  966. * DO 7029 ID=1,NBPTE1
  967. * DO 7029 IC=1,NCOEL1
  968. * IE=IE+1
  969. * WORK(IE)=MELVA1.VELCHA(ID,IC,IBMN1)
  970. *7029 CONTINUE
  971. *C
  972. *C ON CALCULE LES FORCES INTERNES
  973. *C
  974. * CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE)
  975. * IF(KERRE.EQ.0) GO TO 5029
  976. * INTERR(1)=IA
  977. * INTERR(2)=IB
  978. * SEGSUP WRK1,WRK3
  979. * CALL ERREUR(128)
  980. * GO TO 9990
  981.  
  982. *5029 CONTINUE
  983. *C
  984. *C RANGEMENT DANS MELVAL
  985. *C
  986. * IE=0
  987. * DO 9029 ID=1,NBPTEL
  988. * DO 9029 IC=1,NCOELE
  989. * IE=IE+1
  990. * VELCHA(ID,IC,IB)=XFORC(IE)
  991. *9029 CONTINUE
  992. *029 CONTINUE
  993. * SEGSUP WRK1,WRK3
  994. * GO TO 510
  995. *
  996. * ELEMENTS LISP ET LISM (NON)
  997. *********************************************************************
  998. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  999. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  1000. *********************************************************************
  1001. *
  1002. * 30 CONTINUE
  1003. * NBBB=NBNN
  1004. * SEGINI WRK1,WRK3,WRK4
  1005. * DO 3030 IB=1,NBELEM
  1006. * IBMN1=MIN(IB,NEL1)
  1007. * IBMN4=MIN(IB,NEL4)
  1008. *C
  1009. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1010. *C
  1011. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1012. *C
  1013. *C ON REACTUALISE LA GEOMETRIE
  1014. *C
  1015. * IF(IRT4.EQ.1) THEN
  1016. * DO 4030 IC=1,3
  1017. * DO 4030 ID=1,3
  1018. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1019. * 4030 CONTINUE
  1020. * ENDIF
  1021. *C
  1022. *C MISE A ZERO DES FORCES INTERNES
  1023. *C
  1024. * CALL ZERO(XFORC,1,LRE)
  1025. *C
  1026. *C ON CHERCHE LES CONTRAINTES
  1027. *C
  1028. * IE=0
  1029. * DO 7030 IC=1,NBPGAU
  1030. * ICMN1=MIN(IC,NBPTE1)
  1031. * DO 7030 ID=1,NCOEL1
  1032. * IE=IE+1
  1033. * WORK(IE)=MELVA1.VELCHA(ICMN1,ID,IBMN1)
  1034. * 7030 CONTINUE
  1035. *C
  1036. *C ON CHERCHE LES CARACTERISTIQUES
  1037. *C
  1038. * DO 6030 IC=1,NBPGAU
  1039. * ICMN4=MIN(IC,NBPTE4)
  1040. * DO 6030 ID=1,NCOEL4
  1041. * IE=IE+1
  1042. * WORK(IE)=MELVA4.VELCHA(ICMN4,ID,IBMN4)
  1043. * 6030 CONTINUE
  1044. *C
  1045. *C ON CALCULE B*SIGMA
  1046. *C
  1047. * ICNT=NBPGAU*NSTRS+1
  1048. * CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT,
  1049. * 1 NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC)
  1050. *C
  1051. *C RANGEMENT DANS MELVAL
  1052. *C
  1053. * IE=0
  1054. * DO 9030 IC=1,NBNN
  1055. * DO 9030 ID=1,6
  1056. * IE=IE+1
  1057. * VELCHA(IC,ID,IB)=XFORC(IE)
  1058. * 9030 CONTINUE
  1059. * 3030 CONTINUE
  1060. * SEGSUP WRK1,WRK3,WRK4
  1061. * GOTO 510
  1062. *C
  1063. *C ELEMENT COQ8 COQ6 (NON)
  1064. *C
  1065. *********************************************************************
  1066. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1067. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  1068. *********************************************************************
  1069. * 41 CONTINUE
  1070. * NBBB=NBNN
  1071. * SEGINI WRK1,WRK3
  1072. * SEGACT MINTE1
  1073. * NBPGA1=MINTE1.SHPTOT(/3)
  1074. * NBN1 =MINTE1.SHPTOT(/2)
  1075. *C
  1076. *C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1077. *C
  1078. * I240=0
  1079. * I241=0
  1080. * DO 3041 IB=1,NBELEM
  1081. * IBMN1=MIN(IB,NEL1)
  1082. * IBMN4=MIN(IB,NEL4)
  1083. *C
  1084. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1085. *C
  1086. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1087. *C
  1088. *C ON REACTUALISE LA GEOMETRIE
  1089. *C
  1090. * IF(IRT4.EQ.1) THEN
  1091. * DO 4041 IC=1,3
  1092. * DO 4041 ID=1,3
  1093. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1094. * 4041 CONTINUE
  1095. * ENDIF
  1096. *C
  1097. *C MISE A ZERO DES FORCES INTERNES
  1098. *C
  1099. * CALL ZERO(XFORC,1,LRE)
  1100. *C
  1101. *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  1102. *C
  1103. * EPAIST=XZER
  1104. * DO 5041 IC=1,NBPTE4
  1105. * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  1106. * 5041 CONTINUE
  1107. * EPAIST=EPAIST/DBLE(NBPTE4)
  1108. * CALL ZERO(XFORC,1,LRE)
  1109. *C
  1110. *C ON CHERCHE LES CONTRAINTES
  1111. *C
  1112. * IE=1
  1113. * DO 7041 IC=1,NBPGAU
  1114. * DO 7041 ID=1,NSTRS
  1115. * WORK(IE)=MELVA1.VELCHA(IC,ID,IBMN1)
  1116. * IE=IE+1
  1117. * 7041 CONTINUE
  1118. *C
  1119. *C ON CALCULE B*SIGMA
  1120. *C
  1121. * CALL COQ8BS(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,DZEGAU,POIGAU,
  1122. * * SHPTOT,MINTE1.SHPTOT,WORK(1),XFORC,IRRT)
  1123. * IF(IRRT.EQ.0) I241=IB
  1124. * IF(IRRT.EQ.-1) I240=IB
  1125. *C
  1126. *C RANGEMENT DANS MELVAL
  1127. *C
  1128. * IE=0
  1129. * DO 9041 IC=1,NBNN
  1130. * DO 9041 ID=1,6
  1131. * IE=IE+1
  1132. * VELCHA(IC,ID,IB)=XFORC(IE)
  1133. * 9041 CONTINUE
  1134. * 3041 CONTINUE
  1135. * SEGSUP WRK1,WRK3
  1136. * SEGDES MINTE1
  1137. * IF(I241.NE.0) INTERR(1)=I241
  1138. * IF(I241.NE.0) CALL ERREUR(241)
  1139. * IF(I240.NE.0) INTERR(1)=I240
  1140. * IF(I240.NE.0) CALL ERREUR(240)
  1141. * IF(I241.NE.0.OR.I240.NE.0)GO TO 9990
  1142. * GOTO 510
  1143. *C
  1144. *C ELEMENT COQ2 (NON)
  1145. *C
  1146. *********************************************************************
  1147. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1148. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  1149. *********************************************************************
  1150. * 44 CONTINUE
  1151. * DIM3=1.D0
  1152. * NBNO=NBNN
  1153. * NBBB=NBNN
  1154. * SEGINI WRK1,WRK2
  1155. * I255=0
  1156. * I256=0
  1157. * DO 3044 IB=1,NBELEM
  1158. * IBMN1=MIN(IB,NEL1)
  1159. * IBMN4=MIN(IB,NEL4)
  1160. *C
  1161. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1162. *C
  1163. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1164. *C
  1165. *C ON REACTUALISE LA GEOMETRIE
  1166. *C
  1167. * IF(IRT4.EQ.1) THEN
  1168. * DO 4044 IC=1,NBPTE3
  1169. * DO 4044 ID=1,IDIM
  1170. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1171. * 4044 CONTINUE
  1172. * ENDIF
  1173. *C
  1174. *C MISE A ZERO DES FORCES INTERNES
  1175. *C
  1176. * CALL ZERO(XFORC,1,LRE)
  1177. *C
  1178. *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1179. *C
  1180. * EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1181. * EPA=EPAIST*EPAIST/6.D0
  1182. *
  1183. *C
  1184. *C BOUCLE SUR LES POINTS DE GAUSS
  1185. *C
  1186. * DO 6044 IGAU=1,NBPGAU
  1187. * IGMN1=MIN(IGAU,NBPTE1)
  1188. * MPTVAL=IVACAR
  1189. * MELVAL=IVAL(2)
  1190. * IF (MELVAL.NE.0) THEN
  1191. * IGMN=MIN(IGAU ,VELCHE(/1))
  1192. * IBMN=MIN(IB ,VELCHE(/2))
  1193. * EXCEN =VELCHE(IGMN,IBMN)
  1194. * ELSE
  1195. * EXCEN=0.D0
  1196. * ENDIF
  1197. * IF(IFOUR.EQ.-2) THEN
  1198. * MELVAL=IVAL(3)
  1199. * IF (MELVAL.NE.0) THEN
  1200. * IGMN=MIN(IGAU ,VELCHE(/1))
  1201. * IBMN=MIN(IB ,VELCHE(/2))
  1202. * DIM3=VELCHE(IGMN,IBMN)
  1203. * ELSE
  1204. * DIM3=1.D0
  1205. * ENDIF
  1206. * ENDIF
  1207. * CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  1208. * . EXCEN,DIM3,IRRT,XDPGE,YDPGE)
  1209. * IF(IRRT.EQ.1) I255=IB
  1210. * IF(IRRT.EQ.2) I256=IB
  1211. *C
  1212. *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS XSTRS
  1213. *C
  1214. * DO 7044 IC=1,NCOEL1
  1215. * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1216. * 7044 CONTINUE
  1217. * NCO1 = NCOEL1/2
  1218. * DO 8044 IC=1,NCO1
  1219. * XSTRS(IC )=XSTRS(IC )*EPAIST
  1220. * XSTRS(IC+NCO1)=XSTRS(IC+NCO1)*EPA
  1221. * 8044 CONTINUE
  1222. *C
  1223. *C ON CALCULE B*SIGMA
  1224. *C
  1225. * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1226. * 6044 CONTINUE
  1227. *C
  1228. *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1229. *C
  1230. * IF(IFOUR.GT.0) THEN
  1231. * DO 9044 IC=1,2
  1232. * IE=(IC-1)*4
  1233. * VELCHA(IC,1,IB)= XFORC(IE+1)
  1234. * VELCHA(IC,2,IB)= XFORC(IE+2)
  1235. * VELCHA(IC,3,IB)= XFORC(IE+3)
  1236. * VELCHA(IC,4,IB)= XFORC(IE+4)
  1237. * 9044 CONTINUE
  1238. * ELSE IF(IFOUR.LE.0) THEN
  1239. * DO 9944 IC=1,2
  1240. * IE=(IC-1)*3
  1241. * VELCHA(IC,1,IB)= XFORC(IE+1)
  1242. * VELCHA(IC,2,IB)= XFORC(IE+2)
  1243. * VELCHA(IC,3,IB)= XFORC(IE+3)
  1244. * 9944 CONTINUE
  1245. * ENDIF
  1246. * 3044 CONTINUE
  1247. * SEGSUP WRK1,WRK2
  1248. * IF(I255.NE.0) THEN
  1249. * INTERR(1)=I255
  1250. * CALL ERREUR(255)
  1251. * ENDIF
  1252. * IF(I256.NE.0) THEN
  1253. * INTERR(1)=I256
  1254. * CALL ERREUR(256)
  1255. * ENDIF
  1256. * IF(I255.NE.0.OR.I256.NE.0)GO TO 9990
  1257. * GOTO 510
  1258. *C
  1259. *C ELEMENT COQ4 (NON)
  1260. *C
  1261. *********************************************************************
  1262. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1263. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  1264. *********************************************************************
  1265. * 49 CONTINUE
  1266. * IG1=0
  1267. * NBNO=NBNN
  1268. * NBBB=NBNN
  1269. * SEGINI WRK1,WRK2,WRK4
  1270. * DO 3049 IB=1,NBELEM
  1271. * IBMN1=MIN(IB,NEL1)
  1272. * IBMN4=MIN(IB,NEL4)
  1273. *C
  1274. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1275. *C
  1276. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1277. *C
  1278. *C ON REACTUALISE LA GEOMETRIE
  1279. *C
  1280. * IF(IRT4.EQ.1) THEN
  1281. * DO 4049 IC=1,NBPTE3
  1282. * DO 4049 ID=1,IDIM
  1283. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1284. * 4049 CONTINUE
  1285. * ENDIF
  1286. *C
  1287. *C MISE A ZERO DES FORCES INTERNES
  1288. *C
  1289. * CALL ZERO(XFORC,1,LRE)
  1290. *C
  1291. *C RIFERIMENTO LOCALE
  1292. *C
  1293. * CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  1294. * CALL TRPOSE(BPSS)
  1295. *C
  1296. *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1297. *C
  1298. * EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1299. *C
  1300. *C BOUCLE SUR LES POINTS DE GAUSS
  1301. *C
  1302. * DO 6049 IGAU=1,NBPGAU
  1303. * IGMN1=MIN(IGAU,NBPTE1)
  1304. * CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT,0)
  1305. * IF (IERT.NE.0) IG1=IB
  1306. *C
  1307. *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  1308. *C
  1309. * DO 7049 IC=1,NCOEL1
  1310. * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1311. * 7049 CONTINUE
  1312. *C
  1313. *C ON CALCULE B*SIGMA
  1314. *C
  1315. * DJAC=DJAC*POIGAU(IGAU)
  1316. * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1317. * 6049 CONTINUE
  1318. *C
  1319. *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1320. *C
  1321. * EPA=EPAIST*EPAIST/6.D0
  1322. * DO 8049 IC=1,4
  1323. * IE=(IC-1)*6
  1324. * XFORC(IE+1)=EPAIST*XFORC(IE+1)
  1325. * XFORC(IE+2)=EPAIST*XFORC(IE+2)
  1326. * XFORC(IE+3)=EPAIST*XFORC(IE+3)
  1327. * XFORC(IE+4)= EPA*XFORC(IE+4)
  1328. * XFORC(IE+5)= EPA*XFORC(IE+5)
  1329. * XFORC(IE+6)= EPA*XFORC(IE+6)
  1330. * 8049 CONTINUE
  1331. * CALL MATVEC(XFORC,XFOLO,BPSS,8)
  1332. * IE=0
  1333. * DO 9049 IC=1,4
  1334. * DO 9049 ID=1,6
  1335. * IE=IE+1
  1336. * VELCHA(IC,ID,IB)=XFOLO(IE)
  1337. * 9049 CONTINUE
  1338. * 3049 CONTINUE
  1339. * SEGSUP WRK1,WRK2,WRK4
  1340. * IF(IG1.NE.0) THEN
  1341. * INTERR(1)=IG1
  1342. * CALL ERREUR (321)
  1343. * GO TO 9990
  1344. * ENDIF
  1345. * GOTO 510
  1346. *C
  1347. *C ELEMENT COF3 (NON)
  1348. *C
  1349. *********************************************************************
  1350. * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1351. * CHAMELEMS COMME POUR LES ELEMENTS MASSIF
  1352. *********************************************************************
  1353. * 51 CONTINUE
  1354. * NBNO=NBNN
  1355. * NBBB=NBNN
  1356. * SEGINI WRK1,WRK2
  1357. * DO 3051 IB=1,NBELEM
  1358. * IBMN1=MIN(IB,NEL1)
  1359. * IBMN4=MIN(IB,NEL4)
  1360. *C
  1361. *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1362. *C
  1363. * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1364. *C
  1365. *C ON REACTUALISE LA GEOMETRIE
  1366. *C
  1367. * IF(IRT4.EQ.1) THEN
  1368. * DO 4051 IC=1,NBPTE3
  1369. * DO 4051 ID=1,IDIM
  1370. * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1371. * 4051 CONTINUE
  1372. * ENDIF
  1373. *C
  1374. *C MISE A ZERO DES FORCES INTERNES
  1375. *C
  1376. * CALL ZERO(XFORC,1,LRE)
  1377. *C
  1378. *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1379. *C
  1380. * EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1381. *C
  1382. *C BOUCLE SUR LES POINTS DE GAUSS
  1383. *C
  1384. * DO 6051 IGAU=1,NBPGAU
  1385. * IGMN1=MIN(IGAU,NBPTE1)
  1386. * CALL BCOF3(BGENE,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,IRRT)
  1387. *C
  1388. *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  1389. *C
  1390. * DO 7051 IC=1,NCOEL1
  1391. * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1392. * 7051 CONTINUE
  1393. *C
  1394. *C ON CALCULE B*SIGMA
  1395. *C
  1396. * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1397. * 6051 CONTINUE
  1398. *C
  1399. *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1400. *C
  1401. * EPA=EPAIST*EPAIST/6.D0
  1402. * DO 9051 IC=1,2
  1403. * IE=(IC-1)*4
  1404. * VELCHA(IC,1,IB)=EPAIST*XFORC(IE+1)
  1405. * VELCHA(IC,2,IB)=EPAIST*XFORC(IE+2)
  1406. * VELCHA(IC,3,IB)=EPAIST*XFORC(IE+3)
  1407. * VELCHA(IC,4,IB)= EPA*XFORC(IE+4)
  1408. * 9051 CONTINUE
  1409. * 3051 CONTINUE
  1410. * SEGSUP WRK1,WRK2
  1411. * GOTO 510
  1412. C | | | | | | | | | | | | | |
  1413. C ---------------------------------------------------------------
  1414. C_______________________________________________________________________
  1415. C
  1416. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1417. C_______________________________________________________________________
  1418. C
  1419. 510 CONTINUE
  1420. C
  1421. IF (ISUP1.EQ.1) THEN
  1422. CALL DTMVAL(IVASTR,3)
  1423. ELSE
  1424. CALL DTMVAL(IVASTR,1)
  1425. ENDIF
  1426. *
  1427. IF (ISUP2.EQ.1) THEN
  1428. CALL DTMVAL(IVAGRA,3)
  1429. ELSE
  1430. CALL DTMVAL(IVAGRA,1)
  1431. ENDIF
  1432. *
  1433. IF (ISUP3.EQ.1) THEN
  1434. CALL DTMVAL(IVAGRF,3)
  1435. ELSE
  1436. CALL DTMVAL(IVAGRF,1)
  1437. ENDIF
  1438. *
  1439. IF (ISUP4.EQ.1) THEN
  1440. CALL DTMVAL(IVACAR,3)
  1441. ELSE
  1442. CALL DTMVAL(IVACAR,1)
  1443. ENDIF
  1444. *
  1445. IF (IERR.NE.0) THEN
  1446. CALL DTMVAL(IVAFOR,3)
  1447. SEGSUP MCHAML
  1448. ELSE
  1449. CALL DTMVAL(IVAFOR,1)
  1450. SEGDES MCHAML
  1451. ENDIF
  1452.  
  1453. SEGDES,MINTE
  1454. 991 CONTINUE
  1455. SEGDES MELEME,IMODEL
  1456. *
  1457. IF (IERR.NE.0) GOTO 9990
  1458. *
  1459. 500 CONTINUE
  1460. C_______________________________________________________________________
  1461. C
  1462. C TRANSFORMATION DU CHAMELEM EN CHPOINT
  1463. C_______________________________________________________________________
  1464. C
  1465. IRET = 1
  1466. CALL CHAMPO(IPCHE5,0,IPCHP1,IRET)
  1467. C ATTRIBUTION D'UNE NATURE DISCRETE
  1468. CALL DTCHAM(IPCHE5)
  1469. IF (IRET.EQ.1) THEN
  1470. MCHPOI = IPCHP1
  1471. SEGACT MCHPOI
  1472. NAT = MAX ( JATTRI(/1) , 1 )
  1473. NSOUPO = IPCHP(/1)
  1474. SEGADJ MCHPOI
  1475. JATTRI(1) = 2
  1476. SEGDES MCHPOI
  1477. ENDIF
  1478. C
  1479. SEGDES MMODEL
  1480. RETURN
  1481. *
  1482. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1483. *
  1484. 9990 CONTINUE
  1485. IRET=0
  1486. SEGDES MMODEL
  1487. SEGSUP MCHELM
  1488.  
  1489. RETURN
  1490. END
  1491.  
  1492.  
  1493.  
  1494.  
  1495.  
  1496.  
  1497.  

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