Télécharger prinpo.eso

Retour à la liste

Numérotation des lignes :

  1. C PRINPO SOURCE GF238795 18/02/01 21:16:19 9724
  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. -INC CCOPTIO
  27. -INC CCHAMP
  28. -INC SMCHAML
  29. -INC SMINTE
  30. -INC SMMODEL
  31. -INC SMCOORD
  32. -INC SMELEME
  33. C
  34. SEGMENT MWRK1
  35. REAL*8 XEL(3,NBNN)
  36. ENDSEGMENT
  37. C
  38. SEGMENT MWRK2
  39. REAL*8 TXR(3,3,NBNN) ,TH(NBNN)
  40. ENDSEGMENT
  41. C
  42. SEGMENT NOTYPE
  43. CHARACTER*16 TYPE(NBTYPE)
  44. ENDSEGMENT
  45. C
  46. SEGMENT MPTVAL
  47. INTEGER IPOS(NS) ,NSOF(NS)
  48. INTEGER IVAL(NCOSOU)
  49. CHARACTER*16 TYVAL(NCOSOU)
  50. ENDSEGMENT
  51. C
  52. PARAMETER ( NINF=3 )
  53. INTEGER INFOS(NINF)
  54. C
  55. CHARACTER*4 MOTCLE(6),MMM
  56. CHARACTER*(NCONCH) CONM
  57. LOGICAL lsuppr,lsupno
  58. DIMENSION A(3,3),D(3),S(3,3),BPSS(3,3),SIG(9),V1(4)
  59. C
  60. DATA MOTCLE/'SUP ','MOYE','INF ','SUPE','INFE','TRID'/
  61. DATA XZER,UN,DEUX/0.D0,1.D0,2.D0/
  62. C
  63. ISUP2=0
  64. IDIMM=IDIM
  65. XFLOT =XZER
  66. IF(MMM.EQ.MOTCLE(1)) XFLOT= UN
  67. IF(MMM.EQ.MOTCLE(4)) XFLOT= UN
  68. IF(MMM.EQ.MOTCLE(2)) XFLOT= XZER
  69. IF(MMM.EQ.MOTCLE(3)) XFLOT=-UN
  70. IF(MMM.EQ.MOTCLE(5)) XFLOT=-UN
  71. C
  72. LETRID=0
  73. IF(MMM.EQ.MOTCLE(6)) LETRID=1
  74.  
  75. NHRM=NIFOUR
  76. C
  77. IRET = 0
  78. C
  79. ICONT=0
  80. IDEFO=0
  81. MCHELM=IPCHE1
  82. SEGACT MCHELM
  83. IF (TITCHE .EQ.'CONTRAINTES' ) ICONT = 1
  84. IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
  85. C CLB
  86. C CLB DANS LE CAS DES DEFORMATIONS IL FAUT MULTIPLIER LES GAMMA PAR 0.5
  87. C CLB
  88.  
  89. XMULIJ=ICONT + IDEFO/DEUX
  90. SEGDES MCHELM
  91. C
  92. C ERREUR IL FAUT UN CHAMELEM DE SOUS TYPE CONTRAINTES OU DEFORMATIONS
  93. C
  94. IF (ICONT.NE.1 .AND. IDEFO.NE.1) THEN
  95. MOTERR(1:8)='CONTRAIN'
  96. MOTERR(9:16)='DEFORMAT'
  97. CALL ERREUR(109)
  98. RETURN
  99. ENDIF
  100. C
  101. C Verification du lieu support du MCHAML de contraintes
  102. C
  103.  
  104. C Contraintes / Deformations : REDU et Verification du lieu support
  105. CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  106. IF (ISUP1.GT.1) RETURN
  107.  
  108. C Caracteristiques : REDU et Verification du lieu support
  109. **** IPCHE2 = 0
  110. IF (IPCHE2.NE.0) THEN
  111. CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  112. IF (ISUP2.GT.1) RETURN
  113. ENDIF
  114. C
  115. C ACTIVATION DU MODELE
  116. C
  117. MMODEL=IPMODL
  118. SEGACT MMODEL
  119. NSOUS=KMODEL(/1)
  120. C
  121. C CREATION DU MCHELM
  122. C
  123. N1=NSOUS
  124. L1=23
  125. N3=6
  126. SEGINI MCHELM
  127. TITCHE='CONTRAINTES PRINCIPALES'
  128. C CLB
  129. C CLB MODIFICATION DU TITRE DANS LE CAS DES DEFORMATIONS
  130. C CLB
  131. IF (IDEFO .EQ. 1) THEN
  132. TITCHE='DEFORMATIONS PRINCIPALES'
  133. ENDIF
  134. IFOCHE=IFOUR
  135. IPSTRS=MCHELM
  136. C____________________________________________________________________
  137. C
  138. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  139. C____________________________________________________________________
  140. C
  141. DO 500 ISOUS=1,NSOUS
  142. C
  143. IVECT =0
  144. IVACAR=0
  145. IVACOM=0
  146. NCARF =0
  147. NCARA =0
  148. NPRIN =0
  149. MOCARA=0
  150. MOCOMP=0
  151. MOSPRI=0
  152. C
  153. C ON RECUPERE L'INFORMATION GENERALE
  154. C
  155. IMODEL=KMODEL(ISOUS)
  156. SEGACT IMODEL
  157. IPMAIL=IMAMOD
  158. CONM =CONMOD
  159. C
  160. C COQUE INTEGREE OU PAS ?
  161. C
  162. IF(INFMOD(/1).NE.0)THEN
  163. NPINT=INFMOD(1)
  164. ELSE
  165. NPINT=0
  166. ENDIF
  167. c+mdj
  168. C IF (NPINT.NE.0)THEN
  169. C CALL ERREUR(615)
  170. C SEGDES IMODEL,MMODEL
  171. C SEGSUP MCHELM
  172. C RETURN
  173. C ENDIF
  174. c+mdj
  175. C
  176. IMACHE(ISOUS)=IPMAIL
  177. CONCHE(ISOUS)=CONMOD
  178. C
  179. C TRAITEMENT DU MODELE
  180. C
  181. MELE=NEFMOD
  182. MELEME=IMAMOD
  183. C____________________________________________________________________
  184. C
  185. C INFORMATION SUR L'ELEMENT FINI
  186. C____________________________________________________________________
  187. C
  188. C CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  189. C IF (IERR.NE.0) THEN
  190. C SEGDES IMODEL,MMODEL
  191. C SEGSUP MCHELM
  192. C RETURN
  193. C ENDIF
  194. C INFO=IPINF
  195. MFR =INFELE(13)
  196. NBGS =INFELE(4)
  197. NSTRS=INFELE(16)
  198. C MINTE=INFELE(11)
  199. MINTE=INFMOD(7)
  200. IPMINT=MINTE
  201. MINTE1=INFMOD(8)
  202. C SEGSUP,INFO
  203. C
  204. C CREATION DU TABLEAU INFOS
  205. C
  206. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  207. IF (IRTD.EQ.0) GOTO 9990
  208. C
  209. INFCHE(ISOUS,1)=0
  210. INFCHE(ISOUS,2)=0
  211. INFCHE(ISOUS,3)=NHRM
  212. INFCHE(ISOUS,4)=MINTE
  213. INFCHE(ISOUS,5)=0
  214. INFCHE(ISOUS,6)=5
  215. C
  216. C INITIALISATION DE MINTE
  217. C
  218. SEGACT MINTE
  219. NBPGAU=POIGAU(/1)
  220. C
  221. C ACTIVATION DU MELEME
  222. C
  223. SEGACT MELEME
  224. NBNN =NUM(/1)
  225. NBELEM=NUM(/2)
  226. IPPORE=0
  227. IF(MFR.EQ.33) IPPORE=NBNN
  228.  
  229. C____________________________________________________________________
  230. C
  231. C RECHERCHE DES NOMS DE COMPOSANTES
  232. C____________________________________________________________________
  233. C
  234. lsupno=.false.
  235. IF(ICONT.EQ.1) THEN
  236. if(lnomid(4).ne.0) then
  237. nomid=lnomid(4)
  238. segact nomid
  239. mocomp=nomid
  240. ncomp=lesobl(/2)
  241. nfac=lesfac(/2)
  242. else
  243. lsupno=.true.
  244. CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  245. endif
  246. ELSE IF(IDEFO.EQ.1) THEN
  247. if(lnomid(5).ne.0) then
  248. nomid=lnomid(5)
  249. segact nomid
  250. ncomp=lesobl(/2)
  251. mocomp=nomid
  252. else
  253. lsupno=.true.
  254. CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  255. endif
  256. ENDIF
  257. C
  258. if(lnomid(9).ne.0) then
  259. nomid=lnomid(9)
  260. segact nomid
  261. mospri=nomid
  262. nprin=lesobl(/2)
  263. nfac=lesfac(/2)
  264. lsuppr=.false.
  265. else
  266. lsuppr=.true.
  267. CALL IDPRIN(MFR,IFOUR,MOSPRI,NPRIN,NFAC)
  268. endif
  269. C
  270. C____________________________________________________________________
  271. C
  272. C VERIFICATION DE LEUR PRESENCE
  273. C____________________________________________________________________
  274. C
  275. NBTYPE=1
  276. SEGINI NOTYPE
  277. MOTYPE=NOTYPE
  278. TYPE(1)='REAL*8'
  279. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  280. 1 MOTYPE,1,INFOS,3,IVACOM)
  281. SEGSUP NOTYPE
  282. IF (IERR.NE.0) GOTO 9990
  283. IF (ISUP1.EQ.1) THEN
  284. CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
  285. ENDIF
  286. C
  287. C RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
  288. C
  289. N1PTEL=0
  290. N1EL=0
  291. MPTVAL=IVACOM
  292. DO 111 IO=1,NCOMP
  293. MELVAL=IVAL(IO)
  294. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  295. 111 CONTINUE
  296. NBGCOM=N1PTEL
  297. C
  298. N1EL=NBELEM
  299. C
  300. C CREATION DU MCHAML DE LA SOUS ZONE
  301. C
  302. N2=NPRIN
  303. SEGINI MCHAML
  304. ICHAML(ISOUS)=MCHAML
  305. NS=1
  306. NCOSOU=NPRIN
  307. SEGINI MPTVAL
  308. IVAPRI=MPTVAL
  309. NOMID=MOSPRI
  310. SEGACT NOMID
  311. DO 100 ICOMP=1,NPRIN
  312. NOMCHE(ICOMP)=LESOBL(ICOMP)
  313. TYPCHE(ICOMP)='REAL*8'
  314. N2PTEL=0
  315. N2EL=0
  316. SEGINI MELVAL
  317. IELVAL(ICOMP)=MELVAL
  318. IVAL(ICOMP)=MELVAL
  319. 100 CONTINUE
  320. SEGDES NOMID
  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 1010 IB=1,NBELEM
  464. C
  465. C BOUCLE SUR LES POINTS DE GAUSS
  466. C
  467. DO 1010 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. 1010 CONTINUE
  546. C
  547. GOTO 110
  548. 30 CONTINUE
  549. C____________________________________________________________________
  550. C
  551. C FORMULATION COQUE
  552. C____________________________________________________________________
  553. C
  554. SEGINI MWRK1
  555. C
  556. C BOUCLE SUR LES ELEMENTS
  557. DO 1030 IB=1,NBELEM
  558. C
  559. C BOUCLE SUR LES POINTS DE GAUSS
  560. C
  561. DO 1030 IGAU=1,NBPGAU
  562. C
  563. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  564. IF(IDIM.EQ.3) THEN
  565. CALL VPAST(XEL,BPSS)
  566. ELSE IF(IDIM.EQ.2) THEN
  567. CALL VPAST2(XEL,BPSS)
  568. ENDIF
  569. CALL TRPOSE(BPSS)
  570. C
  571. C REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES ET
  572. C CALCUL DES CONTRAINTES
  573. C
  574. MPTVAL=IVACOM
  575. C
  576. DO 130 ID = 1,NSTRS
  577. MELVAL=IVAL(ID)
  578. IGMN=MIN(IGAU,VELCHE(/1))
  579. IBMN=MIN(IB ,VELCHE(/2))
  580. SIG(ID) = VELCHE(IGMN,IBMN)
  581. 130 CONTINUE
  582. C
  583. MPTVAL=IVACAR
  584. C
  585. MELVAL=IVAL(1)
  586. EPAIST = VELCHE(1,1)
  587. C
  588. MELVAL=IVAL(2)
  589. IF (IVAL(2).NE.0) THEN
  590. EXCEN = VELCHE(1,1)
  591. ELSE
  592. EXCEN =REAL(0.D0)
  593. ENDIF
  594. C
  595. c+mdj
  596. IF(NPINT.NE.0) THEN
  597. SIG(4)= SIG(4)*XMULIJ
  598. CALL PRINC(SIG,V1,NSTRS)
  599. MPTVAL=IVAPRI
  600. DO 161 ID = 1,4
  601. MELVAL=IVAL(ID)
  602. IGMN=MIN(IGAU,VELCHE(/1))
  603. IBMN=MIN(IB ,VELCHE(/2))
  604. VELCHE(IGMN,IBMN) = V1(ID)
  605. 161 CONTINUE
  606. GOTO 1130
  607. ENDIF
  608. c+mdj
  609. C
  610. CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  611. C
  612. IF(IFOUR.GT.0) THEN
  613. C
  614. A(1,1) = SIG(1) + XFLOT*SIG(4)
  615. A(2,2) = SIG(2) + XFLOT*SIG(5)
  616. A(1,2) = XMULIJ*(SIG(3) + XFLOT*SIG(6))
  617. A(2,1) = A(1,2)
  618. ELSE IF(IFOUR.LE.0) THEN
  619. A(1,1) = SIG(1) + XFLOT*SIG(3)
  620. A(2,2) = SIG(2) + XFLOT*SIG(4)
  621. A(1,2) =REAL(0.D0)
  622. A(2,1) =REAL(0.D0)
  623. ENDIF
  624. C
  625. CALL JACOB3(A,2,D,S)
  626. CALL MULMAT(A,BPSS,S,3,3,3)
  627. C
  628. MPTVAL=IVAPRI
  629. C
  630. DO 61 ID = 1,2
  631. MELVAL=IVAL(ID)
  632. IGMN=MIN(IGAU,VELCHE(/1))
  633. IBMN=MIN(IB ,VELCHE(/2))
  634. VELCHE(IGMN,IBMN) = D(ID)
  635. 61 CONTINUE
  636. C
  637. DO 2030 ID = 1,3
  638. MELVAL=IVAL(ID+2)
  639. IGMN=MIN(IGAU,VELCHE(/1))
  640. IBMN=MIN(IB ,VELCHE(/2))
  641. VELCHE(IGMN,IBMN)= A(ID,1)
  642. C
  643. MELVAL=IVAL(ID+5)
  644. IGMN=MIN(IGAU,VELCHE(/1))
  645. IBMN=MIN(IB ,VELCHE(/2))
  646. VELCHE(IGMN,IBMN)= A(ID,2)
  647. C
  648. 2030 CONTINUE
  649. 1130 CONTINUE
  650. 1030 CONTINUE
  651. GOTO 110
  652. 50 CONTINUE
  653. C
  654. C FORMULATION COQUE EPAISSE PLUS COMPLIQUE CAR IL FAUT
  655. C RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
  656. C
  657. C PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
  658. C
  659. SEGACT MINTE1
  660. SEGINI MWRK1,MWRK2
  661. N1PTEL=NBGS
  662. C
  663. DO 1052 IB = 1,NBNN
  664. TH(IB)=UN
  665. 1052 CONTINUE
  666.  
  667. C BOUCLE SUR LES ELEMENTS
  668. DO 1050 IB=1,NBELEM
  669. C
  670. C BOUCLE SUR LES POINTS DE GAUSS
  671. C
  672. DO 1050 IGAU=1,NBPGAU
  673.  
  674. C
  675. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  676. CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  677. C
  678. DO 1050 IC=1,NBGS
  679. E=DZEGAU(IC)
  680. C
  681. CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
  682. C
  683. MPTVAL=IVACOM
  684. C
  685. MELVAL=IVAL(1)
  686. IGMN=MIN(IGAU,VELCHE(/1))
  687. IBMN=MIN(IB ,VELCHE(/2))
  688. A(1,1) = VELCHE(IGMN,IBMN)
  689. C
  690. MELVAL=IVAL(2)
  691. IGMN=MIN(IGAU,VELCHE(/1))
  692. IBMN=MIN(IB ,VELCHE(/2))
  693. A(2,2) = VELCHE(IGMN,IBMN)
  694. C
  695. MELVAL=IVAL(3)
  696. IGMN=MIN(IGAU,VELCHE(/1))
  697. IBMN=MIN(IB ,VELCHE(/2))
  698. A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
  699. A(2,1) = A(1,2)
  700. C
  701. CALL JACOB3(A,2,D,S)
  702. CALL MULMAT(A,BPSS,S,3,3,3)
  703. C
  704. MPTVAL=IVAPRI
  705. C
  706. MELVAL=IVAL(1)
  707. IGMN=MIN(IGAU,VELCHE(/1))
  708. IBMN=MIN(IB ,VELCHE(/2))
  709. VELCHE(IGMN,IBMN) = D(1)
  710. C
  711. MELVAL=IVAL(2)
  712. IGMN=MIN(IGAU,VELCHE(/1))
  713. IBMN=MIN(IB ,VELCHE(/2))
  714. VELCHE(IGMN,IBMN)= D(2)
  715. C
  716. DO 2050 ID = 1,3
  717. C
  718. MELVAL=IVAL(ID+2)
  719. IGMN=MIN(IGAU,VELCHE(/1))
  720. IBMN=MIN(IB ,VELCHE(/2))
  721. VELCHE(IGMN,IBMN)= A(ID,1)
  722. C
  723. MELVAL=IVAL(ID+5)
  724. IGMN=MIN(IGAU,VELCHE(/1))
  725. IBMN=MIN(IB ,VELCHE(/2))
  726. VELCHE(IGMN,IBMN)= A(ID,2)
  727. C
  728. 2050 CONTINUE
  729. 1050 CONTINUE
  730. C
  731. SEGDES MINTE1
  732. SEGSUP MWRK1,MWRK2
  733. C
  734. GOTO 110
  735. 90 CONTINUE
  736. C
  737. C CAS LINESPRING
  738. C
  739. C BOUCLE SUR LES ELEMENTS
  740. DO 1090 IB=1,NBELEM
  741. C
  742. C BOUCLE SUR LES POINTS DE GAUSS
  743. C
  744. DO 1090 IGAU=1,NBPGAU
  745.  
  746. MPTVAL=IVACAR
  747. C
  748. MELVAL=IVAL(1)
  749. IGMN=MIN(IGAU,VELCHE(/1))
  750. IBMN=MIN(IB ,VELCHE(/2))
  751. EP = VELCHE(IGMN,IBMN)
  752. EP2 = EP*EP/REAL(6.D0)
  753. C
  754. MPTVAL=IVACOM
  755. C
  756. MELVAL=IVAL(1)
  757. IGMN=MIN(IGAU,VELCHE(/1))
  758. IBMN=MIN(IB ,VELCHE(/2))
  759. AUX1 = VELCHE(IGMN,IBMN)
  760. C
  761. MELVAL=IVAL(4)
  762. IGMN=MIN(IGAU,VELCHE(/1))
  763. IBMN=MIN(IB ,VELCHE(/2))
  764. AUX2 = VELCHE(IGMN,IBMN)
  765. C
  766. MPTVAL=IVAPRI
  767. C
  768. MELVAL=IVAL(1)
  769. IGMN=MIN(IGAU,VELCHE(/1))
  770. IBMN=MIN(IB ,VELCHE(/2))
  771. VELCHE(IGMN,IBMN)=AUX1/EP + XFLOT * AUX2/EP2
  772. 1090 CONTINUE
  773. GOTO 110
  774. C
  775. C____________________________________________________________________
  776. C
  777. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  778. C____________________________________________________________________
  779. C
  780. 110 CONTINUE
  781. SEGDES MINTE
  782. SEGDES MELEME
  783. SEGDES IMODEL
  784. SEGDES MCHAML
  785. C
  786. IF(ISUP1.EQ.1)THEN
  787. CALL DTMVAL(IVACOM,3)
  788. ELSE
  789. CALL DTMVAL(IVACOM,1)
  790. ENDIF
  791. C
  792. IF(ISUP2.EQ.1)THEN
  793. CALL DTMVAL(IVACAR,3)
  794. ELSE
  795. CALL DTMVAL(IVACAR,1)
  796. ENDIF
  797. C
  798. CALL DTMVAL(IVAPRI,1)
  799. C
  800. NOMID=MOCARA
  801. IF (MOCARA.NE.0) SEGSUP NOMID
  802. NOMID=MOCOMP
  803. if(lsupno)SEGSUP NOMID
  804. NOMID=MOSPRI
  805. if(lsuppr)SEGSUP NOMID
  806. C
  807. 500 CONTINUE
  808. C
  809. SEGDES MMODEL
  810. MCHELM=IPCHE1
  811. C* write (6,*) ' mchelm desactive dans prinpo ',mchelm
  812. SEGDES MCHELM
  813. MCHELM=IPSTRS
  814. C* write (6,*) ' ipstrs desactive dans prinpo ',ipstrs
  815. SEGDES MCHELM
  816. IRET = 1
  817. RETURN
  818. C
  819. C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  820. C
  821. 9990 CONTINUE
  822. IRET = 0
  823. C
  824. IF(ISUP1.EQ.1)THEN
  825. CALL DTMVAL(IVACOM,3)
  826. ELSE
  827. CALL DTMVAL(IVACOM,1)
  828. ENDIF
  829. C
  830. IF(ISUP2.EQ.1)THEN
  831. CALL DTMVAL(IVACAR,3)
  832. ELSE
  833. CALL DTMVAL(IVACAR,1)
  834. ENDIF
  835. C
  836. CALL DTMVAL(IVAPRI,3)
  837. C
  838. NOMID=MOCARA
  839. IF (MOCARA.NE.0) SEGSUP NOMID
  840. NOMID=MOCOMP
  841. if(lsupno)SEGSUP NOMID
  842. NOMID=MOSPRI
  843. if(lsuppr)SEGSUP NOMID
  844. C
  845. SEGDES MINTE
  846. SEGDES MELEME
  847. SEGDES IMODEL
  848. SEGSUP MCHAML
  849. C
  850. SEGDES MMODEL
  851. SEGSUP MCHELM
  852.  
  853. RETURN
  854. END
  855.  
  856.  
  857.  
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  

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