Télécharger fofis1.eso

Retour à la liste

Numérotation des lignes :

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

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