Télécharger prinpo.eso

Retour à la liste

Numérotation des lignes :

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

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