Télécharger fofis1.eso

Retour à la liste

Numérotation des lignes :

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

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