Télécharger prinpo.eso

Retour à la liste

Numérotation des lignes :

prinpo
  1. C PRINPO SOURCE JB251061 23/05/10 21:15:15 11667
  2. SUBROUTINE PRINPO(IPCHE1,MMM,IPCHE2,IPMODL,IPSTRS,IRET)
  3. C=======================================================================
  4. C
  5. C entr{es :
  6. C ========
  7. C
  8. C IPCHE1 =pointeur sur un MCHAML de CONTRAINTES ou de DEFORMATIONS
  9. C MMM =motcle pour les COQUES ( sortie sur la peau SUP INF OU MOYE)
  10. C IPCHE2 =pointeur sur un MCHAML de CARACTERISTIQUES
  11. C IPMODL =pointeur sur un MODELE
  12. C
  13. C sorties :
  14. C =======
  15. C
  16. C IPSTRS =pointeur sur un MCHAML de CONTRAINTES PRINCIPALES
  17. C IRET =1 OU 0 SUIVANT SUCCES OU PAS (MESSAGE D'ERREUR
  18. C imprim{ dans ce cas)
  19. C
  20. C Passage aux nouveaux Chamelem par S.RAMAHANDRY le 21/09/90
  21. C
  22. C=======================================================================
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. INTEGER ISUP2
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30. -INC SMCHAML
  31. -INC SMINTE
  32. -INC SMMODEL
  33. -INC SMCOORD
  34. -INC SMELEME
  35. C
  36. SEGMENT MWRK1
  37. REAL*8 XEL(3,NBNN)
  38. ENDSEGMENT
  39. C
  40. SEGMENT MWRK2
  41. REAL*8 TXR(3,3,NBNN) ,TH(NBNN)
  42. ENDSEGMENT
  43. C
  44. SEGMENT NOTYPE
  45. CHARACTER*16 TYPE(NBTYPE)
  46. ENDSEGMENT
  47. C
  48. SEGMENT MPTVAL
  49. INTEGER IPOS(NS) ,NSOF(NS)
  50. INTEGER IVAL(NCOSOU)
  51. CHARACTER*16 TYVAL(NCOSOU)
  52. ENDSEGMENT
  53. C
  54. PARAMETER ( NINF=3 )
  55. INTEGER INFOS(NINF)
  56. C
  57. CHARACTER*4 MOTCLE(6),MMM
  58. CHARACTER*(NCONCH) CONM
  59. LOGICAL lsuppr,lsupno
  60. DIMENSION A(3,3),D(3),S(3,3),BPSS(3,3),SIG(9),V1(4)
  61. C
  62. DATA MOTCLE/'SUP ','MOYE','INF ','SUPE','INFE','TRID'/
  63. DATA XZER,UN,DEUX/0.D0,1.D0,2.D0/
  64. C
  65. LSUPNO=.FALSE.
  66. LSUPpR=.FALSE.
  67. ISUP2=0
  68. IDIMM=IDIM
  69. XFLOT =XZER
  70. IF(MMM.EQ.MOTCLE(1)) XFLOT= UN
  71. IF(MMM.EQ.MOTCLE(4)) XFLOT= UN
  72. IF(MMM.EQ.MOTCLE(2)) XFLOT= XZER
  73. IF(MMM.EQ.MOTCLE(3)) XFLOT=-UN
  74. IF(MMM.EQ.MOTCLE(5)) XFLOT=-UN
  75. C
  76. LETRID=0
  77. IF(MMM.EQ.MOTCLE(6)) LETRID=1
  78.  
  79. NHRM=NIFOUR
  80. C
  81. IRET = 0
  82. C
  83. ICONT=0
  84. IDEFO=0
  85. MCHELM=IPCHE1
  86. SEGACT MCHELM
  87. IF (TITCHE .EQ.'CONTRAINTES' ) ICONT = 1
  88. IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
  89. C CLB
  90. C CLB DANS LE CAS DES DEFORMATIONS IL FAUT MULTIPLIER LES GAMMA PAR 0.5
  91. C CLB
  92.  
  93. XMULIJ=ICONT + IDEFO/DEUX
  94. C
  95. C ERREUR IL FAUT UN CHAMELEM DE SOUS TYPE CONTRAINTES OU DEFORMATIONS
  96. C
  97. IF (ICONT.NE.1 .AND. IDEFO.NE.1) THEN
  98. MOTERR(1:24)='CONTRAINTES'
  99. MOTERR(25:48)='DEFORMATIONS'
  100. CALL ERREUR(109)
  101. RETURN
  102. ENDIF
  103. C
  104. C Verification du lieu support du MCHAML de contraintes
  105. C
  106.  
  107. C Contraintes / Deformations : REDU et Verification du lieu support
  108. CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  109. IF (ISUP1.GT.1) RETURN
  110.  
  111. C Caracteristiques : REDU et Verification du lieu support
  112. **** IPCHE2 = 0
  113. IF (IPCHE2.NE.0) THEN
  114. CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  115. IF (ISUP2.GT.1) RETURN
  116. ENDIF
  117. C
  118. C ACTIVATION DU MODELE
  119. C
  120. MMODEL=IPMODL
  121. SEGACT MMODEL
  122. NSOUS=KMODEL(/1)
  123. C
  124. C CREATION DU MCHELM
  125. C
  126. N1=NSOUS
  127. L1=23
  128. N3=6
  129. SEGINI MCHELM
  130. TITCHE='CONTRAINTES PRINCIPALES'
  131. C CLB
  132. C CLB MODIFICATION DU TITRE DANS LE CAS DES DEFORMATIONS
  133. C CLB
  134. IF (IDEFO .EQ. 1) THEN
  135. TITCHE='DEFORMATIONS PRINCIPALES'
  136. ENDIF
  137. IFOCHE=IFOUR
  138. IPSTRS=MCHELM
  139. C____________________________________________________________________
  140. C
  141. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  142. C____________________________________________________________________
  143. C
  144. DO 500 ISOUS=1,NSOUS
  145. C
  146. IVECT =0
  147. IVACAR=0
  148. IVACOM=0
  149. NCARF =0
  150. NCARA =0
  151. NPRIN =0
  152. MOCARA=0
  153. MOCOMP=0
  154. MOSPRI=0
  155. C
  156. C ON RECUPERE L'INFORMATION GENERALE
  157. C
  158. IMODEL=KMODEL(ISOUS)
  159. SEGACT IMODEL
  160. IPMAIL=IMAMOD
  161. CONM =CONMOD
  162. C
  163. C COQUE INTEGREE OU PAS ?
  164. C
  165. IF(INFMOD(/1).NE.0)THEN
  166. NPINT=INFMOD(1)
  167. ELSE
  168. NPINT=0
  169. ENDIF
  170. c+mdj
  171. C IF (NPINT.NE.0)THEN
  172. C CALL ERREUR(615)
  173. C SEGSUP MCHELM
  174. C RETURN
  175. C ENDIF
  176. c+mdj
  177. C
  178. IMACHE(ISOUS)=IPMAIL
  179. CONCHE(ISOUS)=CONMOD
  180. C
  181. C TRAITEMENT DU MODELE
  182. C
  183. MELE=NEFMOD
  184. MELEME=IMAMOD
  185. C____________________________________________________________________
  186. C
  187. C INFORMATION SUR L'ELEMENT FINI
  188. C____________________________________________________________________
  189. C
  190. C CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  191. C IF (IERR.NE.0) THEN
  192. C SEGSUP MCHELM
  193. C RETURN
  194. C ENDIF
  195. C INFO=IPINF
  196. MFR =INFELE(13)
  197. NBGS =INFELE(4)
  198. NSTRS=INFELE(16)
  199. C MINTE=INFELE(11)
  200. MINTE=INFMOD(7)
  201. IPMINT=MINTE
  202. MINTE1=INFMOD(8)
  203. C SEGSUP,INFO
  204. C
  205. C CREATION DU TABLEAU INFOS
  206. C
  207. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  208. IF (IRTD.EQ.0) GOTO 9990
  209. C
  210. INFCHE(ISOUS,1)=0
  211. INFCHE(ISOUS,2)=0
  212. INFCHE(ISOUS,3)=NHRM
  213. INFCHE(ISOUS,4)=MINTE
  214. INFCHE(ISOUS,5)=0
  215. INFCHE(ISOUS,6)=5
  216. C
  217. C INITIALISATION DE MINTE
  218. C
  219. SEGACT MINTE
  220. NBPGAU=POIGAU(/1)
  221. C
  222. C ACTIVATION DU MELEME
  223. C
  224. SEGACT MELEME
  225. NBNN =NUM(/1)
  226. NBELEM=NUM(/2)
  227. IPPORE=0
  228. IF(MFR.EQ.33) IPPORE=NBNN
  229.  
  230. C____________________________________________________________________
  231. C
  232. C RECHERCHE DES NOMS DE COMPOSANTES
  233. C____________________________________________________________________
  234. C
  235. lsupno=.false.
  236. IF(ICONT.EQ.1) THEN
  237. if(lnomid(4).ne.0) then
  238. nomid=lnomid(4)
  239. segact nomid
  240. mocomp=nomid
  241. ncomp=lesobl(/2)
  242. nfac=lesfac(/2)
  243. else
  244. lsupno=.true.
  245. CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  246. endif
  247. ELSE IF(IDEFO.EQ.1) THEN
  248. if(lnomid(5).ne.0) then
  249. nomid=lnomid(5)
  250. segact nomid
  251. ncomp=lesobl(/2)
  252. mocomp=nomid
  253. else
  254. lsupno=.true.
  255. CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  256. endif
  257. ENDIF
  258. C
  259. if(lnomid(9).ne.0) then
  260. nomid=lnomid(9)
  261. segact nomid
  262. mospri=nomid
  263. nprin=lesobl(/2)
  264. nfac=lesfac(/2)
  265. lsuppr=.false.
  266. else
  267. lsuppr=.true.
  268. CALL IDPRIN(MFR,IFOUR,MOSPRI,NPRIN,NFAC)
  269. endif
  270. C
  271. C____________________________________________________________________
  272. C
  273. C VERIFICATION DE LEUR PRESENCE
  274. C____________________________________________________________________
  275. C
  276. NBTYPE=1
  277. SEGINI NOTYPE
  278. MOTYPE=NOTYPE
  279. TYPE(1)='REAL*8'
  280. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  281. 1 MOTYPE,1,INFOS,3,IVACOM)
  282. SEGSUP NOTYPE
  283. IF (IERR.NE.0) GOTO 9990
  284. IF (ISUP1.EQ.1) THEN
  285. CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
  286. ENDIF
  287. C
  288. C RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
  289. C
  290. N1PTEL=0
  291. N1EL=0
  292. MPTVAL=IVACOM
  293. DO 111 IO=1,NCOMP
  294. MELVAL=IVAL(IO)
  295. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  296. 111 CONTINUE
  297. NBGCOM=N1PTEL
  298. C
  299. N1EL=NBELEM
  300. C
  301. C CREATION DU MCHAML DE LA SOUS ZONE
  302. C
  303. N2=NPRIN
  304. SEGINI MCHAML
  305. ICHAML(ISOUS)=MCHAML
  306. NS=1
  307. NCOSOU=NPRIN
  308. SEGINI MPTVAL
  309. IVAPRI=MPTVAL
  310. NOMID=MOSPRI
  311. SEGACT NOMID
  312. DO 100 ICOMP=1,NPRIN
  313. NOMCHE(ICOMP)=LESOBL(ICOMP)
  314. TYPCHE(ICOMP)='REAL*8'
  315. N2PTEL=0
  316. N2EL=0
  317. SEGINI MELVAL
  318. IELVAL(ICOMP)=MELVAL
  319. IVAL(ICOMP)=MELVAL
  320. 100 CONTINUE
  321. C____________________________________________________________________
  322. C
  323. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
  324. C____________________________________________________________________
  325. C
  326. NBROBL=0
  327. NBRFAC=0
  328. MOCARA=0
  329. C
  330. C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  331. C
  332. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  333. NBROBL=1
  334. NBRFAC=1
  335. SEGINI NOMID
  336. MOCARA=NOMID
  337. LESOBL(1)='EPAI'
  338. LESFAC(1)='EXCE'
  339. C
  340. C CARACTERISTIQUES POUR LES LINESPRING
  341. C
  342. ELSE IF (MFR.EQ.15) THEN
  343. NBROBL=1
  344. SEGINI NOMID
  345. MOCARA=NOMID
  346. LESOBL(1)='EPAI'
  347. ENDIF
  348. C
  349. IF (MOCARA.NE.0) THEN
  350. IF (IPCHE2.NE.0) THEN
  351. NBTYPE=1
  352. SEGINI NOTYPE
  353. MOTYPE=NOTYPE
  354. TYPE(1)='REAL*8'
  355. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  356. 1 MOTYPE,1,INFOS,3,IVACAR)
  357. SEGSUP NOTYPE
  358. IF (IERR.NE.0) GOTO 9990
  359. IF (IVECT.EQ.1) THEN
  360. MPTVAL=IVACAR
  361. IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  362. C
  363. C MOT CLE VECT EN CAS DE CONVERSION
  364. C
  365. IVECT=2
  366. NOMID=MOCARA
  367. SEGACT NOMID
  368. NBRFAC=NBRFAC+2
  369. SEGADJ NOMID
  370. MOCARA=NOMID
  371. LESFAC(NBRFAC-2)='VX '
  372. LESFAC(NBRFAC-1)='VY '
  373. LESFAC(NBRFAC) ='VZ '
  374. C
  375. NBTYPE=1
  376. SEGINI NOTYPE
  377. MOTYPE=NOTYPE
  378. TYPE(1)='REAL*8'
  379. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  380. 1 MOTYPE,1,INFOS,3,IVACAR)
  381. SEGSUP NOTYPE
  382. IF (IERR.NE.0) GOTO 9990
  383. ENDIF
  384. ENDIF
  385. ELSE
  386. MOTERR(1:8)='CARACTER'
  387. MOTERR(9:12)=NOMTP(NEFMOD)
  388. MOTERR(13:20)='PRIN '
  389. CALL ERREUR(145)
  390. GOTO 9990
  391. ENDIF
  392. ENDIF
  393. C
  394. NCARA=NBROBL
  395. NCARF=NBRFAC
  396. NCARR=NCARA+NCARF
  397. IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
  398. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  399. IF(IERR.NE.0)THEN
  400. ISUP2=0
  401. GOTO 9990
  402. ENDIF
  403. ENDIF
  404. C
  405. C=================================================================
  406. C MASSI COQUE COQEP POUT CIST THER TUYAU LISP
  407. GOTO (10,66,30,66,50,66,66,66,30,66,66,66,66,66,90),MFR
  408. C Cas particulier des elements InCompressibles (MFR=31)
  409. IF (MFR.EQ.31) GOTO 10
  410. c cas Xfem: identique au cas massif
  411. IF(MFR.EQ.63) goto 10
  412. c
  413. C=================================================================
  414. 66 CONTINUE
  415. MOTERR(1:8)=NOMFR(MFR)
  416. CALL ERREUR (194)
  417. GOTO 9990
  418. C____________________________________________________________________
  419. C
  420. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  421. C____________________________________________________________________
  422. C
  423. 10 CONTINUE
  424. C
  425. C REMPLISSAGE DU SEGMENT CONTENANT LES MATRICES(JACOBIEN)
  426. C
  427. IF (IDIM.EQ.1) THEN
  428. DO IB=1,NBELEM
  429. DO IGAU=1,NBPGAU
  430. MPTVAL=IVACOM
  431. MELVAL=IVAL(1)
  432. IGMN=MIN(IGAU,VELCHE(/1))
  433. IBMN=MIN(IB ,VELCHE(/2))
  434. SIG(1)=VELCHE(IGMN,IBMN)
  435. MELVAL=IVAL(2)
  436. IGMN=MIN(IGAU,VELCHE(/1))
  437. IBMN=MIN(IB ,VELCHE(/2))
  438. SIG(2)=VELCHE(IGMN,IBMN)
  439. MELVAL=IVAL(3)
  440. IGMN=MIN(IGAU,VELCHE(/1))
  441. IBMN=MIN(IB ,VELCHE(/2))
  442. SIG(3)=VELCHE(IGMN,IBMN)
  443. CALL ORDO01(SIG(1),3,.FALSE.)
  444. MPTVAL=IVAPRI
  445. MELVAL=IVAL(1)
  446. IGMN=MIN(IGAU,VELCHE(/1))
  447. IBMN=MIN(IB ,VELCHE(/2))
  448. VELCHE(IGMN,IBMN)=SIG(1)
  449. MELVAL=IVAL(2)
  450. IGMN=MIN(IGAU,VELCHE(/1))
  451. IBMN=MIN(IB ,VELCHE(/2))
  452. VELCHE(IGMN,IBMN)=SIG(2)
  453. MELVAL=IVAL(3)
  454. IGMN=MIN(IGAU,VELCHE(/1))
  455. IBMN=MIN(IB ,VELCHE(/2))
  456. VELCHE(IGMN,IBMN)=SIG(3)
  457. ENDDO
  458. ENDDO
  459. GOTO 110
  460. ENDIF
  461.  
  462. C BOUCLE SUR LES ELEMENTS
  463. DO IB=1,NBELEM
  464. C
  465. C BOUCLE SUR LES POINTS DE GAUSS
  466. C
  467. DO IGAU=1,NBPGAU
  468. C
  469. MPTVAL=IVACOM
  470.  
  471. MELVAL=IVAL(1)
  472. IGMN=MIN(IGAU,VELCHE(/1))
  473. IBMN=MIN(IB ,VELCHE(/2))
  474. A(1,1) = VELCHE(IGMN,IBMN)
  475. C
  476. MELVAL=IVAL(2)
  477. IGMN=MIN(IGAU,VELCHE(/1))
  478. IBMN=MIN(IB ,VELCHE(/2))
  479. A(2,2) = VELCHE(IGMN,IBMN)
  480. C
  481. MELVAL=IVAL(3)
  482. IGMN=MIN(IGAU,VELCHE(/1))
  483. IBMN=MIN(IB ,VELCHE(/2))
  484. A(3,3) = VELCHE(IGMN,IBMN)
  485. C
  486. MELVAL=IVAL(4)
  487. IGMN=MIN(IGAU,VELCHE(/1))
  488. IBMN=MIN(IB ,VELCHE(/2))
  489. A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
  490. A(2,1) = A(1,2)
  491. C
  492. IF(IFOUR.LT.1.AND.IFOUR.GE.-3) THEN
  493. IF(LETRID.EQ.1) THEN
  494. IDIMM = 3
  495. A(1,3)=0.
  496. A(2,3)=0.
  497. ENDIF
  498. GO TO 6610
  499. ENDIF
  500. C
  501. IF(IFOUR.EQ.1) IDIMM=3
  502. MELVAL=IVAL(5)
  503. IGMN=MIN(IGAU,VELCHE(/1))
  504. IBMN=MIN(IB ,VELCHE(/2))
  505. A(3,1) = XMULIJ*VELCHE(IGMN,IBMN)
  506. C
  507. MELVAL=IVAL(6)
  508. IGMN=MIN(IGAU,VELCHE(/1))
  509. IBMN=MIN(IB ,VELCHE(/2))
  510. A(3,2) = XMULIJ*VELCHE(IGMN,IBMN)
  511. A(1,3) = A(3,1)
  512. A(2,3) = A(3,2)
  513. C
  514. 6610 CONTINUE
  515. C
  516. C REMPLISSAGE DU SEGMENT CONTENANT LES VALEURS ET VECTEURS PROPRES
  517. C
  518. CALL JACOB3(A,IDIMM,D,S)
  519. C
  520. MPTVAL=IVAPRI
  521. C
  522. DO 2010 ID = 1,3
  523. MELVAL=IVAL(ID)
  524. IGMN=MIN(IGAU,VELCHE(/1))
  525. IBMN=MIN(IB ,VELCHE(/2))
  526. VELCHE(IGMN,IBMN) = D(ID)
  527. C
  528. MELVAL=IVAL(ID+3)
  529. IGMN=MIN(IGAU,VELCHE(/1))
  530. IBMN=MIN(IB ,VELCHE(/2))
  531. VELCHE(IGMN,IBMN) = S(ID,1)
  532. C
  533. MELVAL=IVAL(ID+6)
  534. IGMN=MIN(IGAU,VELCHE(/1))
  535. IBMN=MIN(IB ,VELCHE(/2))
  536. VELCHE(IGMN,IBMN) = S(ID,2)
  537. C
  538. MELVAL=IVAL(ID+9)
  539. IGMN=MIN(IGAU,VELCHE(/1))
  540. IBMN=MIN(IB ,VELCHE(/2))
  541. VELCHE(IGMN,IBMN) = S(ID,3)
  542. C
  543. 2010 CONTINUE
  544. C
  545. END DO
  546. C
  547. END DO
  548. C
  549. GOTO 110
  550. 30 CONTINUE
  551. C____________________________________________________________________
  552. C
  553. C FORMULATION COQUE
  554. C____________________________________________________________________
  555. C
  556. SEGINI MWRK1
  557. C
  558. C BOUCLE SUR LES ELEMENTS
  559. DO IB=1,NBELEM
  560. C
  561. C BOUCLE SUR LES POINTS DE GAUSS
  562. C
  563. DO IGAU=1,NBPGAU
  564. C
  565. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  566. IF(IDIM.EQ.3) THEN
  567. CALL VPAST(XEL,BPSS)
  568. ELSE IF(IDIM.EQ.2) THEN
  569. CALL VPAST2(XEL,BPSS)
  570. ENDIF
  571. CALL TRPOSE(BPSS)
  572. C
  573. C REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES ET
  574. C CALCUL DES CONTRAINTES
  575. C
  576. MPTVAL=IVACOM
  577. C
  578. DO ID = 1,NSTRS
  579. MELVAL=IVAL(ID)
  580. IGMN=MIN(IGAU,VELCHE(/1))
  581. IBMN=MIN(IB ,VELCHE(/2))
  582. SIG(ID) = VELCHE(IGMN,IBMN)
  583. END DO
  584. C
  585. MPTVAL=IVACAR
  586. C
  587. MELVAL=IVAL(1)
  588. EPAIST = VELCHE(1,1)
  589. C
  590. MELVAL=IVAL(2)
  591. IF (IVAL(2).NE.0) THEN
  592. EXCEN = VELCHE(1,1)
  593. ELSE
  594. EXCEN =REAL(0.D0)
  595. ENDIF
  596. C
  597. c+mdj
  598. IF(NPINT.NE.0) THEN
  599. SIG(4)= SIG(4)*XMULIJ
  600. CALL PRINC(SIG,V1,NSTRS)
  601. MPTVAL=IVAPRI
  602. DO ID = 1,4
  603. MELVAL=IVAL(ID)
  604. IGMN=MIN(IGAU,VELCHE(/1))
  605. IBMN=MIN(IB ,VELCHE(/2))
  606. VELCHE(IGMN,IBMN) = V1(ID)
  607. END DO
  608. GOTO 1130
  609. ENDIF
  610. c+mdj
  611. C
  612. CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  613. C
  614. IF(IFOUR.GT.0) THEN
  615. C
  616. A(1,1) = SIG(1) + XFLOT*SIG(4)
  617. A(2,2) = SIG(2) + XFLOT*SIG(5)
  618. A(1,2) = XMULIJ*(SIG(3) + XFLOT*SIG(6))
  619. A(2,1) = A(1,2)
  620. ELSE IF(IFOUR.LE.0) THEN
  621. A(1,1) = SIG(1) + XFLOT*SIG(3)
  622. A(2,2) = SIG(2) + XFLOT*SIG(4)
  623. A(1,2) =REAL(0.D0)
  624. A(2,1) =REAL(0.D0)
  625. ENDIF
  626. C
  627. CALL JACOB3(A,2,D,S)
  628. CALL MULMAT(A,BPSS,S,3,3,3)
  629. C
  630. MPTVAL=IVAPRI
  631. C
  632. DO ID = 1,2
  633. MELVAL=IVAL(ID)
  634. IGMN=MIN(IGAU,VELCHE(/1))
  635. IBMN=MIN(IB ,VELCHE(/2))
  636. VELCHE(IGMN,IBMN) = D(ID)
  637. END DO
  638. C
  639. DO ID = 1,3
  640. MELVAL=IVAL(ID+2)
  641. IGMN=MIN(IGAU,VELCHE(/1))
  642. IBMN=MIN(IB ,VELCHE(/2))
  643. VELCHE(IGMN,IBMN)= A(ID,1)
  644. C
  645. MELVAL=IVAL(ID+5)
  646. IGMN=MIN(IGAU,VELCHE(/1))
  647. IBMN=MIN(IB ,VELCHE(/2))
  648. VELCHE(IGMN,IBMN)= A(ID,2)
  649. END DO
  650.  
  651. 1130 CONTINUE
  652.  
  653. C
  654. END DO
  655. C
  656. END DO
  657. C
  658. GOTO 110
  659. 50 CONTINUE
  660. C
  661. C FORMULATION COQUE EPAISSE PLUS COMPLIQUE CAR IL FAUT
  662. C RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
  663. C
  664. C PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
  665. C
  666. SEGACT MINTE1
  667. SEGINI MWRK1,MWRK2
  668. N1PTEL=NBGS
  669. C
  670. DO 1052 IB = 1,NBNN
  671. TH(IB)=UN
  672. 1052 CONTINUE
  673.  
  674. C BOUCLE SUR LES ELEMENTS
  675. DO IB=1,NBELEM
  676. C
  677. C BOUCLE SUR LES POINTS DE GAUSS
  678. C
  679. DO IGAU=1,NBPGAU
  680.  
  681. C
  682. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  683. CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  684. C
  685. DO IC=1,NBGS
  686. E=DZEGAU(IC)
  687. C
  688. CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
  689. C
  690. MPTVAL=IVACOM
  691. C
  692. MELVAL=IVAL(1)
  693. IGMN=MIN(IGAU,VELCHE(/1))
  694. IBMN=MIN(IB ,VELCHE(/2))
  695. A(1,1) = VELCHE(IGMN,IBMN)
  696. C
  697. MELVAL=IVAL(2)
  698. IGMN=MIN(IGAU,VELCHE(/1))
  699. IBMN=MIN(IB ,VELCHE(/2))
  700. A(2,2) = VELCHE(IGMN,IBMN)
  701. C
  702. MELVAL=IVAL(3)
  703. IGMN=MIN(IGAU,VELCHE(/1))
  704. IBMN=MIN(IB ,VELCHE(/2))
  705. A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
  706. A(2,1) = A(1,2)
  707. C
  708. CALL JACOB3(A,2,D,S)
  709. CALL MULMAT(A,BPSS,S,3,3,3)
  710. C
  711. MPTVAL=IVAPRI
  712. C
  713. MELVAL=IVAL(1)
  714. IGMN=MIN(IGAU,VELCHE(/1))
  715. IBMN=MIN(IB ,VELCHE(/2))
  716. VELCHE(IGMN,IBMN) = D(1)
  717. C
  718. MELVAL=IVAL(2)
  719. IGMN=MIN(IGAU,VELCHE(/1))
  720. IBMN=MIN(IB ,VELCHE(/2))
  721. VELCHE(IGMN,IBMN)= D(2)
  722. C
  723. DO ID = 1,3
  724. MELVAL=IVAL(ID+2)
  725. IGMN=MIN(IGAU,VELCHE(/1))
  726. IBMN=MIN(IB ,VELCHE(/2))
  727. VELCHE(IGMN,IBMN)= A(ID,1)
  728. C
  729. MELVAL=IVAL(ID+5)
  730. IGMN=MIN(IGAU,VELCHE(/1))
  731. IBMN=MIN(IB ,VELCHE(/2))
  732. VELCHE(IGMN,IBMN)= A(ID,2)
  733. END DO
  734. C
  735. END DO
  736. C
  737. END DO
  738. C
  739. END DO
  740. C
  741. SEGSUP MWRK1,MWRK2
  742. C
  743. GOTO 110
  744. 90 CONTINUE
  745. C
  746. C CAS LINESPRING
  747. C
  748. C BOUCLE SUR LES ELEMENTS
  749. DO IB=1,NBELEM
  750. C
  751. C BOUCLE SUR LES POINTS DE GAUSS
  752. C
  753. DO IGAU=1,NBPGAU
  754.  
  755. MPTVAL=IVACAR
  756. C
  757. MELVAL=IVAL(1)
  758. IGMN=MIN(IGAU,VELCHE(/1))
  759. IBMN=MIN(IB ,VELCHE(/2))
  760. EP = VELCHE(IGMN,IBMN)
  761. EP2 = EP*EP/REAL(6.D0)
  762. C
  763. MPTVAL=IVACOM
  764. C
  765. MELVAL=IVAL(1)
  766. IGMN=MIN(IGAU,VELCHE(/1))
  767. IBMN=MIN(IB ,VELCHE(/2))
  768. AUX1 = VELCHE(IGMN,IBMN)
  769. C
  770. MELVAL=IVAL(4)
  771. IGMN=MIN(IGAU,VELCHE(/1))
  772. IBMN=MIN(IB ,VELCHE(/2))
  773. AUX2 = VELCHE(IGMN,IBMN)
  774. C
  775. MPTVAL=IVAPRI
  776. C
  777. MELVAL=IVAL(1)
  778. IGMN=MIN(IGAU,VELCHE(/1))
  779. IBMN=MIN(IB ,VELCHE(/2))
  780. VELCHE(IGMN,IBMN)=AUX1/EP + XFLOT * AUX2/EP2
  781. C
  782. END DO
  783. C
  784. END DO
  785. C
  786. GOTO 110
  787. C
  788. C____________________________________________________________________
  789. C
  790. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  791. C____________________________________________________________________
  792. C
  793. 110 CONTINUE
  794. C
  795. IF(ISUP1.EQ.1)THEN
  796. CALL DTMVAL(IVACOM,3)
  797. ELSE
  798. CALL DTMVAL(IVACOM,1)
  799. ENDIF
  800. C
  801. IF(ISUP2.EQ.1)THEN
  802. CALL DTMVAL(IVACAR,3)
  803. ELSE
  804. CALL DTMVAL(IVACAR,1)
  805. ENDIF
  806. C
  807. CALL DTMVAL(IVAPRI,1)
  808. C
  809. NOMID=MOCARA
  810. IF (MOCARA.NE.0) SEGSUP NOMID
  811. NOMID=MOCOMP
  812. if(lsupno)SEGSUP NOMID
  813. NOMID=MOSPRI
  814. if(lsuppr)SEGSUP NOMID
  815. C
  816. 500 CONTINUE
  817. C
  818. IRET = 1
  819. RETURN
  820. C
  821. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  822. C
  823. 9990 CONTINUE
  824. IRET = 0
  825. C
  826. IF(ISUP1.EQ.1)THEN
  827. CALL DTMVAL(IVACOM,3)
  828. ELSE
  829. CALL DTMVAL(IVACOM,1)
  830. ENDIF
  831. C
  832. IF(ISUP2.EQ.1)THEN
  833. CALL DTMVAL(IVACAR,3)
  834. ELSE
  835. CALL DTMVAL(IVACAR,1)
  836. ENDIF
  837. C
  838. CALL DTMVAL(IVAPRI,3)
  839. C
  840. NOMID=MOCARA
  841. IF (MOCARA.NE.0) SEGSUP NOMID
  842. NOMID=MOCOMP
  843. if(lsupno)SEGSUP NOMID
  844. NOMID=MOSPRI
  845. if(lsuppr)SEGSUP NOMID
  846.  
  847. SEGSUP MCHAML
  848.  
  849. SEGSUP MCHELM
  850.  
  851. END
  852.  
  853.  
  854.  
  855.  
  856.  
  857.  

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