Télécharger precop.eso

Retour à la liste

Numérotation des lignes :

  1. C PRECOP SOURCE BP208322 15/06/22 21:21:23 8543
  2. SUBROUTINE PRECOP(IPMODL,IPCHA1,IPTAB,IPSTRS,IRAN,
  3. & PS1,IPCHC1,IRET)
  4. C======================================================================C
  5. C C
  6. C ENTREES : C
  7. C C
  8. C IPMODL: POINTEUR SUR UN MMODEL C
  9. C IPCHA1: Pointeur sur le MCHAML de CARACTERISTIQUES C
  10. C PS1 : Force sous vérin
  11. C IRAN : Pointeur sur maillage des points d application
  12. C IPCHC1: POINTEUR SUR le MCHAML DE PRECONTRAINTE INITIALE
  13. C IPTAB : pointeur sur la table des parametres frottement .... C
  14. C C
  15. C SORTIES : C
  16. C C
  17. C IPSTRS: MCHAML CONTENANT LES PRECONTAINTES ET LES FORCES C
  18. C DU CABLE SUR LE BETON C
  19. C IRET : 1 cela c est bien passe
  20. C 0 probleme dans le traitement C
  21. C C
  22. C======================================================================C
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. C
  26. -INC CCOPTIO
  27. -INC SMCHAML
  28. -INC SMELEME
  29. -INC SMINTE
  30. -INC SMMODEL
  31. -INC CCHAMP
  32. -INC SMCOORD
  33. -INC SMTABLE
  34. C
  35. REAL*8 XVALIN,XVALRE
  36. LOGICAL LOGRE,LOGIN
  37. CHARACTER*8 TAPIND,TYPOBJ,CHARIN,CHARRE
  38. CHARACTER*4 MOPAR(6)
  39. *
  40. DATA MOPAR/'F1 ','F2 ','GANC','RMU0','FPRG','RH10'/
  41. SEGMENT INFO
  42. INTEGER INFELL(JG)
  43. ENDSEGMENT
  44. * stockage de pointeurs sur des segment sielc crees dans splitag
  45. segment siezo
  46. integer iezon(*)
  47. endsegment
  48. segment sielc
  49. integer ideb(*),ifin(*),nbcz,isens(2,*),idejvu(*)
  50. endsegment
  51. C
  52. SEGMENT ALTRAV
  53. REAL*8 ANG(NAM+1),DANG(NAM),ACUR(NAM+1),DACUR(NAM)
  54. ENDSEGMENT
  55. C
  56. SEGMENT NOTYPE
  57. CHARACTER*16 TYPE(NBTYPE)
  58. ENDSEGMENT
  59. C
  60. SEGMENT MPTVAL
  61. INTEGER IPOS(NS) ,NSOF(NS)
  62. INTEGER IVAL(NCOSOU)
  63. CHARACTER*16 TYVAL(NCOSOU)
  64. ENDSEGMENT
  65. C
  66. SEGMENT WRK3
  67. REAL*8 X1(3),X2(3),X3(3),RL(3),RS(3)
  68. ENDSEGMENT
  69.  
  70. C
  71. CHARACTER*8 CMATE,LNOM
  72. CHARACTER*(NCONCH) CONM
  73. PARAMETER ( NINF=3 )
  74. PARAMETER ( ITEMAX=50 )
  75. INTEGER INFOS(NINF)
  76. DIMENSION FGG(ITEMAX),XLAM(ITEMAX)
  77. logical ivers,lsupco
  78.  
  79. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  80.  
  81. if (ipchc1.ne.0) then
  82. MCHELM = ipchc1
  83. segact MCHELM
  84. C actuellement un cable n a qu une zone de maillage
  85. imail = imache(1)
  86. segdes MCHELM
  87. endif
  88.  
  89. IRET=0
  90. C verification on doit avoir des elements soit BARR soit CERC
  91. MMODEL = ipmodl
  92. segact mmodel
  93. do i = 1,kmodel(/1)
  94. imodel = kmodel(i)
  95. segact imodel
  96. if(ipchc1.ne.0.and.imail.ne.imamod) then
  97. call erreur(21)
  98. return
  99. endif
  100. meleme = imamod
  101. segact meleme
  102. if(ifomod.eq.0.and.itypel.ne.1) then
  103. segdes imodel,meleme,mmodel
  104. call erreur(21)
  105. return
  106. endif
  107. segdes imodel,meleme
  108. enddo
  109. segdes mmodel
  110.  
  111. C --- Vérification du support des MCHAML --------------
  112.  
  113. if(ipchc1.gt.0) then
  114. call quesup(ipmodl,ipchc1,5,0,iresig,iret2)
  115. if(iresig.eq.9999) then
  116. moterr(1:8)='CONTRAIN'
  117. call erreur(124)
  118. return
  119. endif
  120. endif
  121.  
  122. call quesup(ipmodl,ipcha1,5,0,irecar,iret2)
  123. if(irecar.eq.9999) then
  124. moterr(1:8)='CARACTER'
  125. call erreur(124)
  126. return
  127. endif
  128. if(irecar.eq.1) then
  129. ipcara = 0
  130. iret = 0
  131. call chasup(ipmodl,ipcha1,ipcara,iret,5)
  132. if(iret.ne.0) return
  133. else
  134. ipcara = ipcha1
  135. endif
  136. *---------------------------------------------------------
  137. ipmod0 = ipmodl
  138. *---------------------------------------------------------
  139. if(ifomod.ne.0.and.ifomod.ne.1) then
  140. ipcar0 = ipcara
  141. ipchc0 = ipchc1
  142. call splitag(ipmodl,ipcara,ipchc1,ipmod2,ipcar2,
  143. & ipchc2,siezo)
  144. ipmodl = ipmod2
  145. ipcara = ipcar2
  146. ipchc1 = ipchc2
  147. else
  148. C pas elegant mais on duplique le modele
  149. MMODEL = ipmodl
  150. segini , mmode2=MMODEL
  151. ipmodl = mmode2
  152. endif
  153. C
  154. ipmodt = ipmodl
  155. MMODEL = IPMODL
  156. C
  157. SEGACT MMODEL
  158. NSOUS=KMODEL(/1)
  159. C
  160. C ----PREPARATION DU CHAMP DE SORTIE----------------
  161. C
  162. mmode2 = ipmod0
  163. segact mmode2
  164. N1=mmode2.kmodel(/1)
  165. L1=11
  166. N3=6
  167. segini mchel5
  168. mchel5.titche='CONTRAINTES'
  169. mchel5.ifoche=ifour
  170.  
  171. do isous=1,n1
  172. imodel=mmode2.kmodel(isous)
  173. segact imodel
  174. mchel5.imache(isous)=imamod
  175. mchel5.conche(isous)=conmod
  176. mele= nefmod
  177. C====
  178. CALL ELQUOI(MELE,0,5,INFO,IMODEL)
  179. IF (IERR.NE.0) THEN
  180. SEGDES IMODEL*NOMOD,MMODEL*NOMOD
  181. SEGSUP MCHEL5
  182. IRET=0
  183. RETURN
  184. ENDIF
  185. MINTE= INFELL(11)
  186. C====
  187. MCHEL5.INFCHE(ISOUS,1)=0
  188. MCHEL5.INFCHE(ISOUS,2)=0
  189. MCHEL5.INFCHE(ISOUS,3)=NIFOUR
  190. MCHEL5.INFCHE(ISOUS,4)=MINTE
  191. MCHEL5.INFCHE(ISOUS,5)=0
  192. MCHEL5.INFCHE(ISOUS,6)=5
  193. C
  194. N2=1
  195. segini MCHAML
  196. mchel5.ichaml(isous)=mchaml
  197. nomche(1)='EFFX'
  198. typche(1)='REAL*8'
  199. meleme = imamod
  200. segact meleme
  201. N1PTEL=2
  202. N1EL= NUM(/2)
  203. N2PTEL=0
  204. N2EL=0
  205. segini melval
  206. ielval(1)=melval
  207. segdes melval,mchaml,meleme,imodel
  208. segsup info
  209. enddo
  210.  
  211. segdes mmode2
  212. C
  213. C ----FIN PREPARATION DU CHAMP DE SORTIE----------------
  214. C
  215.  
  216. C preparation de la recherche du sens d application des tensions
  217. if(iran.ne.0) then
  218. ipt3=iran
  219. segact ipt3
  220. segini , ipt5=ipt3
  221. segdes ipt3
  222. ity=ipt5.itypel
  223. if(ity.ne.1) then
  224. segdes ipt5
  225. call change(iran,1)
  226. ipt5=iran
  227. segact ipt5
  228. endif
  229. else
  230. ipt5=0
  231. endif
  232.  
  233. C
  234. C --- CREATION DU MCHELM DE CALCUL ( TEMPORAIRE )
  235. C
  236. N1=NSOUS
  237. C
  238. L1=11
  239. N3=6
  240. SEGINI MCHELM
  241. TITCHE='CONTRAINTES'
  242. IFOCHE=IFOUR
  243. IPSTRS=MCHELM
  244. C
  245. C --- DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  246. C
  247. DO 500 ISOUS=1,NSOUS
  248. C
  249. C --- INITIALISATION
  250. C
  251. MOCARA=0
  252. MOMATR=0
  253. MOSTRS=0
  254. IVAMAT=0
  255. IVACAR=0
  256. IVASTR=0
  257. ivasi0=0
  258. c
  259. ipeffx = 0
  260. ipyoun = 0
  261. ipff = 0
  262. ipphif = 0
  263. ipganc = 0
  264. iprmu0 = 0
  265. ipfprg = 0
  266. iprh10 = 0
  267. ipsect = 0
  268. IMODEL=KMODEL(ISOUS)
  269. SEGACT IMODEL
  270. IPMAIL=IMAMOD
  271. CONM =CONMOD
  272. IMACHE(ISOUS)=IPMAIL
  273. CONCHE(ISOUS)=CONMOD
  274. C ...... TRAITEMENT DU MODELE ......................
  275.  
  276. MELE=NEFMOD
  277. MELEME=IPMAIL
  278. C
  279. segact meleme
  280. itpdel=itypel
  281.  
  282. NFOR=FORMOD(/2)
  283. NMAT=MATMOD(/2)
  284. C
  285. C ... on ordonne le nouveau maillage (si on en a besoin) ...
  286.  
  287. NBELEM = NUM(/2)
  288. C=====================================================
  289. if(itypel.eq.1) then
  290.  
  291. c ... dans le cas des POI1 on n'a rien a orienter ...
  292. C=====================================================
  293. elseif(itypel.eq.2) then
  294.  
  295. ipt2 = meleme
  296. NOD1=NUM(1,1)
  297. NOD2=NUM(2,num(/2))
  298. C write(6,*)' noeuds extremites ' ,nod1,nod2
  299. if(iran.eq.0) then
  300. ivers=.false.
  301. else
  302. do ino=1,ipt5.num(/2)
  303. inodi=ipt5.num(1,ino)
  304. if(inodi.eq.nod1) then
  305. ivers=.false.
  306. goto 364
  307. elseif(inodi.eq.nod2) then
  308. ivers=.true.
  309. goto 364
  310. endif
  311. enddo
  312. C aucune des extremites n'est dans la liste
  313. C on applique au point final
  314. call erreur(833)
  315. C attention aux desactivations
  316. SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme
  317. SEGSUP MCHELM
  318. IRET=0
  319. RETURN
  320. 364 continue
  321. endif
  322. C=====================================================
  323. c ... si ITYPEL différent de 1 et 2 ...
  324. else
  325.  
  326. c ... Type d''élément support inconnu !!!!!!!!!!! ............
  327. SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme
  328. SEGSUP MCHELM
  329. IRET=0
  330. RETURN
  331. call erreur(19)
  332. return
  333. endif
  334. C=====================================================
  335. C
  336. C ------ NATURE DU MATERIAU
  337. C
  338. CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  339. IF (CMATE.EQ.' ') THEN
  340. CALL ERREUR(251)
  341. SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme
  342. SEGSUP MCHELM
  343. IRET=0
  344. RETURN
  345. ENDIF
  346. C
  347. C ------ INFORMATION SUR L'ELEMENT FINI
  348. C
  349. CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  350. IF (IERR.NE.0) THEN
  351. SEGDES IMODEL*NOMOD,MMODEL*NOMOD,meleme
  352. SEGSUP MCHELM
  353. IRET=0
  354. RETURN
  355. ENDIF
  356. C
  357. INFO=IPINF
  358. MELE =INFELL(1)
  359. MFR =INFELL(13)
  360. MINTE=INFELL(11)
  361. NSTRS=INFELL(16)
  362.  
  363. SEGINI WRK3
  364. C
  365. C ------ CREATION DU TABLEAU INFOS
  366. C
  367. IPCHE1=0
  368. IPCHE2=0
  369. c ... ATTENTION !!! A quoi ca sert ????????????? .......
  370. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  371. IF (IRTD.EQ.0) THEN
  372. SEGDES IMODEL*NOMOD,MMODEL*NOMOD,meleme
  373. SEGSUP MCHELM
  374. SEGSUP INFO
  375. IRET=0
  376. RETURN
  377. ENDIF
  378.  
  379. c ... Remplissage du tableau INFCHE du MCHELM ...
  380.  
  381. INFCHE(ISOUS,1)=0
  382. INFCHE(ISOUS,2)=0
  383. INFCHE(ISOUS,3)=NIFOUR
  384. INFCHE(ISOUS,4)=MINTE
  385. INFCHE(ISOUS,5)=0
  386. INFCHE(ISOUS,6)=5
  387. C
  388. C ------ LECTURE de NBPGAU dans
  389. C
  390. SEGACT MINTE
  391. NBPGAU=POIGAU(/1)
  392. SEGDES MINTE
  393. C
  394. C ------ RECHERCHE DES NOMS DE COMPOSANTES des contraintes ...
  395. C
  396. if(lnomid(4).ne.0) then
  397. nomid=lnomid(4)
  398. segact nomid
  399. mostrs=nomid
  400. nstr=lesobl(/2)
  401. nfac=lesfac(/2)
  402. lsupco=.false.
  403. else
  404. lsupco=.true.
  405. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  406. endif
  407. nomid = mostrs
  408. segact,nomid
  409. call place(lesobl,nstr,ipeffx,'EFFX')
  410. segdes,nomid
  411. C
  412. C ------ VERIFICATION DE LEUR PRESENCE et ...
  413. C ------ RECUPERATION DES CONTRAINTES INITIALES (s'il le faut) ...
  414. C
  415. if(IPCHC1.gt.0) then
  416.  
  417. NBTYPE=INFELL(16)
  418. SEGINI NOTYPE
  419. MOTYPE=NOTYPE
  420. TYPE(1)='REAL*8'
  421.  
  422. call komcha(ipchc1,ipmail,conm,mostrs,motype,1,infos,3,
  423. & ivasi0)
  424.  
  425. IF (IERR.NE.0) THEN
  426. NSTRS=0
  427. GOTO 9990
  428. ENDIF
  429.  
  430. SEGSUP NOTYPE
  431. endif
  432.  
  433. C
  434. C ------ CREATION DU MCHAML DE LA SOUS ZONE
  435. C
  436. N2=NSTRS
  437. SEGINI MCHAML
  438. ICHAML(ISOUS)=MCHAML
  439.  
  440. NS=1
  441. NCOSOU=NSTRS
  442. SEGINI MPTVAL
  443. IVASTR=MPTVAL
  444.  
  445. C
  446. C ------ RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  447. C
  448. N1PTEL=nbpgau
  449. N1EL=NBELEM
  450. N2PTEL=0
  451. N2EL=0
  452. C
  453. NOMID=MOSTRS
  454. SEGACT NOMID
  455. C initialisation des melvals des precontaintes
  456. DO 100 ICOMP=1,NSTRS
  457. NOMCHE(ICOMP)=LESOBL(ICOMP)
  458. TYPCHE(ICOMP)='REAL*8'
  459. SEGINI MELVAL
  460. IELVAL(ICOMP)=MELVAL
  461. IVAL(ICOMP)=MELVAL
  462. 100 CONTINUE
  463. SEGDES NOMID
  464. C ipacara preparé dans splitag
  465. C recuperation du module de young dans ivamat ( position 1 )
  466. C recuperation de la section dans ivacar ( position 2 )
  467. mchel6=ipcara
  468. segact mchel6
  469. mcham6=mchel6.ichaml(isous)
  470. segact mcham6
  471. melval= mcham6.ielval(1)
  472. segact melval
  473. ivamat=melval
  474. melval= mcham6.ielval(2)
  475. segact melval
  476. ivacar=melval
  477.  
  478. C
  479. C ------ CALCUL lui même --------------------------
  480. C
  481. C ... cas du CERC ...
  482. C
  483.  
  484. IF(MELE.EQ.95) THEN
  485. DO 2004 IB=1,NBELEM
  486. MPTVAL=IVASTR
  487. DO 1701 I=1,NSTRS
  488. MELVAL=IVAL(I)
  489. VELCHE(1,IB)=PS1
  490. 1701 CONTINUE
  491. iret=1
  492. 2004 CONTINUE
  493.  
  494. ELSE
  495. C ----------------valeurs par defaut ----------------------
  496.  
  497. f1 = 0.18d0
  498. f2 = 0.002d0
  499. ganc = 0.d0
  500. rmu0 = 0.43d0
  501. fprg = 1.7d9
  502. rh10 = 2.5d0
  503.  
  504. if(iptab.ne.0) then
  505. MTABLE = iptab
  506. segact mtable
  507. nbind= mlotab
  508. IVALIN = 0
  509. XVALIN = 0.D0
  510. LOGIN = .TRUE.
  511. IOBIN = 0
  512. TAPIND = 'MOT'
  513. C
  514. TYPOBJ = ' '
  515. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'FF',LOGIN,0,
  516. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  517. IF(TYPOBJ.EQ.'FLOTTANT') F1 = XVALRE
  518. IF(TYPOBJ.EQ.'ENTIER ') F1 = IVELRE
  519. TYPOBJ = ' '
  520. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'PHIF',LOGIN,0,
  521. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  522. IF(TYPOBJ.EQ.'FLOTTANT') F2 = XVALRE
  523. IF(TYPOBJ.EQ.'ENTIER ') F2 = IVELRE
  524. TYPOBJ = ' '
  525. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'GANC',LOGIN,0,
  526. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  527. IF(TYPOBJ.EQ.'FLOTTANT') GANC = XVALRE
  528. IF(TYPOBJ.EQ.'ENTIER ') GANC = IVELRE
  529. TYPOBJ = ' '
  530. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'RMU0',LOGIN,0,
  531. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  532. IF(TYPOBJ.EQ.'FLOTTANT') RMU0 = XVALRE
  533. IF(TYPOBJ.EQ.'ENTIER ') RMU0 = IVELRE
  534. TYPOBJ = ' '
  535. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'FPRG',LOGIN,0,
  536. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  537. IF(TYPOBJ.EQ.'FLOTTANT') FPRG = XVALRE
  538. IF(TYPOBJ.EQ.'ENTIER ') RPRG = IVELRE
  539. TYPOBJ = ' '
  540. Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'RH10',LOGIN,0,
  541. & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE)
  542. IF(TYPOBJ.EQ.'FLOTTANT') RH10 = XVALRE
  543. IF(TYPOBJ.EQ.'ENTIER ') RH10 = IVELRE
  544. segdes MTABLE
  545.  
  546. 4321 format(6E12.5)
  547. endif
  548. C----------------------------------------------------------
  549. C write(6,4321) f1,f2,ganc,rmu0,fprg,rh10
  550. C
  551. C ... Boucle sur les éléments dans lesquels on fait le calcul ...
  552. C
  553.  
  554. SLON=0.0D0
  555. FAI=0.0D0
  556. ids= idim+1
  557. segact,minte
  558. if(nbpgau.ne.2) then
  559. call erreur(5)
  560. return
  561. endif
  562. *
  563. * NEW 1-ERE BOUCLE SUR LES ELEMENTS POUR TROUVER
  564. * LA LONGUEUR D'INFLUENCE DU RECUL D'ANCRAGE
  565. *
  566. NAM =NBELEM
  567. SEGINI ALTRAV
  568. IAM=0
  569. SUM =0.D0
  570. ***** PRINT *,'IVERS=',IVERS
  571. *
  572. DO 5005 IC=1,NBELEM
  573.  
  574. if(ivers) then
  575. C ordre inverse
  576. JC= NBELEM+1-IC
  577. NC3=ipt2.NUM(1,JC)
  578. NC2=ipt2.NUM(2,JC)
  579. IF(JC.EQ.NBELEM) THEN
  580. NC1=NC2
  581. ELSE
  582. NC1=IPT2.NUM(2,JC+1)
  583. ENDIF
  584. else
  585. C ordre normal
  586. JC=IC
  587. NC3=ipt2.NUM(2,JC)
  588. NC2=ipt2.NUM(1,JC)
  589. IF(JC.EQ.1) THEN
  590. NC1=NC2
  591. ELSE
  592. NC1=IPT2.NUM(1,JC-1)
  593. ENDIF
  594. endif
  595. ***** PRINT *,'NC1=',NC1,' NC2=',NC2,' NC3=',NC3
  596. JS1=(NC1-1)*IDS
  597. JS2=(NC2-1)*IDS
  598. JS3=(NC3-1)*IDS
  599.  
  600. DO 511 IW=1,IDIM
  601. X1(IW)=XCOOR(JS1+IW)
  602. X2(IW)=XCOOR(JS2+IW)
  603. 511 X3(IW)=XCOOR(JS3+IW)
  604. C --- Distance entre points
  605. DS1=0.0D0
  606. DS2=0.0D0
  607. DO 512 IW=1,IDIM
  608. RL(IW)=X3(IW)-X2(IW)
  609. RS(IW)=X2(IW)-X1(IW)
  610. DS1=DS1+RL(IW)*RL(IW)
  611. 512 DS2=DS2+RS(IW)*RS(IW)
  612. DS1=SQRT(DS1)
  613. DS2=SQRT(DS2)
  614. CS1=0.0D0
  615. IF(DS2.NE.0.D0) THEN
  616. DO 513 IW=1,IDIM
  617. RL(IW)=RL(IW)/DS1
  618. RS(IW)=RS(IW)/DS2
  619. 513 CS1=CS1+RL(IW)*RS(IW)
  620. ELSE
  621. CS1=1.D0
  622. ENDIF
  623. IF(CS1.GT.1.0) CS1=1.0D0
  624. ALFA=ACOS(CS1)
  625. IAM=IAM+1
  626. ANG(IAM)=FAI
  627. DANG(IAM)=ALFA
  628. ACUR(IAM)=SLON
  629. DACUR(IAM)=DS1
  630. SLON=SLON+DS1
  631. FAI=FAI+ALFA
  632.  
  633. * PRINT *,'IAM=',IAM, ' ACUR =',ACUR(IAM),
  634. * & ' ANG=',ANG(IAM),' DACUR=',DACUR(IAM),' DANG=',DANG(IAM)
  635. *
  636. IF(SLON.NE.0.D0) THEN
  637. SUM = SUM + FAI/SLON
  638. ENDIF
  639. *
  640. 5005 CONTINUE
  641. ANG(NAM+1)=FAI
  642. ACUR(NAM+1)=SLON
  643. *
  644. SLONT=SLON
  645. FAIT=FAI
  646. XLMBDA=0.D0
  647. *
  648. IF(GANC.EQ.0.D0) GO TO 7999
  649. *
  650. *------------------------------------------------------------
  651. * CALCUL DE LA LONGUEUR D'INFLUENCE DU RECUL D'ANCRAGE
  652. * LE CAS ECHEANT ( GANC > 0 )
  653. *------------------------------------------------------------
  654. *
  655. * ON PREND LES MODULE ET SECTION DU 1-ER ELEMENT
  656. * POUR LA 1-ERE APPROXIMATION DE XLAMBDA
  657. *
  658. MELVAL =IVAMAT
  659. EA = VELCHE(1,1)
  660. MELVAL =IVACAR
  661. SECT1 = VELCHE(1,1)
  662. * write(6,*) ' f1, f2, slont, ps1, sect1, ea,ganc,sum,nbelem,fai'
  663. * write(6,*) f1, f2, slont, ps1, sect1, ea,ganc,sum,nbelem,fai
  664. IF(F1.EQ.0.D0.OR.FAI.LE.1.D-4) THEN
  665. IF(F2.EQ.0.D0) THEN
  666. XLMBDA=SLONT
  667. ELSE
  668. aaa= F2*GANC*EA*SECT1/PS1
  669. bbb = aaa ** 0.5
  670. ccc = 1.-bbb
  671. if( ccc .le.0.) then
  672. call erreur(768)
  673. return
  674. else
  675. * write(6,*) ' aaa,bbb,ccc',aaa,bbb,ccc
  676. XLMBDA = -(LOG(1.D0-
  677. & (F2*GANC*EA*SECT1/PS1)**0.5))/F2
  678. endif
  679. ENDIF
  680. ELSE
  681. ALSURL=SUM/FLOAT(NBELEM)
  682. PP= F1*ALSURL + F2
  683. IF(PP.EQ.0.D0) THEN
  684. XLMBDA=SLONT
  685. ELSE
  686. XLMBDA = SQRT( (GANC*EA*SECT1)/(PS1*PP) )
  687. ENDIF
  688. * PRINT *,'ALSURL=',ALSURL
  689. * PRINT *,'F2=',F2, 'PP=',PP
  690. ENDIF
  691. *
  692. * TEST SI XLAMBBDA > SLON
  693. *
  694. IF(XLMBDA.GT.SLONT) XLMBDA=SLONT
  695.  
  696. * PRINT *,'INITIALISATION DE XLMBDA=',XLMBDA
  697. *
  698. IF(XLMBDA.LT.0.D0) THEN
  699. ***** PRINT *,' ATTENTION XLAMBDA INITIAL EST < 0 '
  700. CALL ERREUR(460)
  701. SEGSUP ALTRAV
  702. GO TO 9990
  703. ENDIF
  704. *
  705. ITER=0
  706. LAST=0
  707. IDICH=0
  708. *
  709. * ITERATIONS
  710. *
  711. 8000 CONTINUE
  712. ITER=ITER+1
  713. * PRINT *,'ITER = ',ITER
  714. IF(ITER.GT.ITEMAX) THEN
  715. CALL ERREUR(460)
  716. SEGSUP ALTRAV
  717. GO TO 9990
  718. ENDIF
  719. PSL=0.D0
  720. SLON=0.0D0
  721. FAI=0.0D0
  722. IAM=0
  723. *
  724. IF(LAST.EQ.0) THEN
  725. * write(6,*) ' nam + 1',nam+1
  726. * write(6,*) ' xlmbda acur(1) acur(2) ang(1) ang(2) '
  727. * write(6,*) xlmbda,acur(1), acur(2) ,ang(1),ang(2)
  728. * CALCUL DE L'ANGLE XALFA ASSOCIE A XLMBDA
  729. CALL PRECN0(XLMBDA,ACUR,ANG,NAM+1,ANGBDA,ISUC)
  730. IF(ISUC.EQ.NAM+1) ISUC=NAM
  731. *
  732. ***** PRINT *,'ISUC=',ISUC
  733. IF(ISUC.LT.0) THEN
  734. CALL ERREUR(-ISUC)
  735. SEGSUP ALTRAV
  736. GO TO 9990
  737. ENDIF
  738.  
  739. SD=F1*ANGBDA + F2*XLMBDA
  740. DSDDD=F1*DANG(ISUC)/DACUR(ISUC)+F2
  741. *
  742. ELSE
  743. SD=F1*FAIT + F2 * SLONT
  744. ENDIF
  745. *
  746. GG=0.D0
  747. DGDD=0.D0
  748. DO 8005 IC=1,NBELEM
  749. if(ivers) then
  750. JC= NBELEM+1-IC
  751. else
  752. JC=IC
  753. endif
  754. *
  755. IAM=IAM+1
  756. ALFA = DANG(IAM)
  757. DS1 = DACUR(IAM)
  758.  
  759. do 8006 iptg=1,nbpgau
  760.  
  761. if(ivers) then
  762. ig= nbpgau+1-iptg
  763. else
  764. ig = iptg
  765. endif
  766.  
  767. * ---- Récupération des caractéristiques matérielles et géométriques ----
  768.  
  769. melval =ivamat
  770. ea = velche(min(ig,velche(/1)),
  771. & min(JC,velche(/2)))
  772.  
  773. melval =ivacar
  774. sect1 = velche(min(ig,velche(/1)),
  775. & min(JC,velche(/2)))
  776.  
  777. SABS=SLON + DS1*(1+QSIGAU(IPTG))/2
  778. IF(SABS.GT.XLMBDA) GO TO 8007
  779.  
  780. SP=F1*FAI + F2*SABS
  781. IF(LAST.EQ.0) THEN
  782. GG = GG +
  783. & PS1 * (EXP(-SP) - EXP(SP-2.D0*SD))*DS1*0.5D0
  784. & /(EA*SECT1)
  785.  
  786. DGDD = DGDD +
  787. & PS1 * (EXP(SP-2.D0*SD))*DSDDD*DS1/(EA*SECT1)
  788. ELSE
  789. GG = GG + PS1 * (EXP(-SP))*DS1*0.5D0
  790. & /(EA*SECT1)
  791. DGDD = DGDD + (EXP(SP-SD))*DS1*0.5D0
  792. & /(EA*SECT1)
  793. ENDIF
  794.  
  795. 8006 continue
  796. SLON=SLON+DS1
  797. FAI=FAI+ALFA
  798. 8005 CONTINUE
  799. *
  800. * TEST DE CONVERGENCE
  801. *
  802. 8007 CONTINUE
  803. ***** PRINT *,'GG=',GG, ' GANC=',GANC,' FG =',GG-GANC
  804. ***** PRINT *,'DGDD=', DGDD
  805.  
  806. FGG(ITER)=GG-GANC
  807. XLAM(ITER)=XLMBDA
  808.  
  809. *
  810. * CAS OU L'EFFET DE L'ANCRAGE DEPASSE LA LONGUEUR
  811. * DU CABLE
  812. *
  813. ***** PRINT *,'LAST=',LAST
  814. IF(LAST.EQ.1) THEN
  815.  
  816. IF(ABS(GG-GANC)/GANC.LT.1.D-3) THEN
  817. PSL=0.D0
  818. ELSE
  819. PSL=(GG-GANC)/DGDD
  820. ENDIF
  821.  
  822. ***** PRINT *,'PSL=',PSL
  823. IF(PSL.GT.PS1*EXP(-SD)) THEN
  824. ***** PRINT *,' ATTENTION PSL EST TROP GRAND '
  825. ENDIF
  826. GO TO 7999
  827. ENDIF
  828.  
  829.  
  830. IF(ABS(GG-GANC)/GANC.LT.1.D-3) GO TO 7999
  831. *
  832. IF(ITER.GE.6 .AND.IDICH.EQ.0.AND.
  833. & FGG(ITER)*FGG(ITER-1).LT.0.D0) THEN
  834. IDICH=1
  835. XLAM1=XLAM(ITER-1)
  836. XLAM2=XLAM(ITER)
  837. FG1=FGG(ITER-1)
  838. FG2=FGG(ITER)
  839. ENDIF
  840. ***** PRINT *,'IDICH=',IDICH
  841. *
  842. IF(IDICH.EQ.0) THEN
  843. XLMBDA=XLMBDA - (GG-GANC)/DGDD
  844. ELSE
  845. ***** PRINT *,'XLAM(ITER)=',XLAM(ITER)
  846. ***** PRINT *, ' FGG(ITER)=',FGG(ITER)
  847.  
  848. IF(FG1*FGG(ITER).LT.0.D0) THEN
  849. XLAM2=XLAM(ITER)
  850. FG2=FGG(ITER)
  851. ELSE IF (FG1*FGG(ITER).GT.0.D0) THEN
  852. XLAM1=XLAM(ITER)
  853. FG1=FGG(ITER)
  854. ENDIF
  855. *
  856. ***** PRINT *,'XLAM1=',XLAM1,' FG1=',FG1
  857. ***** PRINT *,'XLAM2=',XLAM2,' FG2=',FG2
  858. DLAM=XLAM2-XLAM1
  859. PROF=FG1/(FG1-FG2)
  860. XLMBDA=XLAM1+PROF*DLAM
  861. ENDIF
  862. *
  863. ***** PRINT *,'NOUVELLE XLMBDA = ', XLMBDA
  864.  
  865. IF(XLMBDA.GE.SLONT) THEN
  866. IF(ITER.EQ.ITEMAX-1) THEN
  867. LAST=1
  868. ELSE
  869. XLMBDA=SLONT
  870. ENDIF
  871. ENDIF
  872. *
  873. * si on trouve XLMBDA < 0 , on reinitialise
  874. *
  875. IF(XLMBDA.LT.0.D0) THEN
  876. IF(ITER.GE.2) THEN
  877. XLMBDA=(XLAM(ITER)+XLAM(1))/ITER
  878. ELSE
  879. XLMBDA=XLAM(1)/2.D0
  880. ENDIF
  881. ***** PRINT *,'XLMBDA REINITIALISEE = ', XLMBDA
  882. ENDIF
  883. *
  884. * SORTIE SI IDICH=1 ET XLMBDA CONVERGE
  885. *
  886. IF(IDICH.EQ.1.AND.ITER.EQ.ITEMAX) THEN
  887. IF(XLMBDA.NE.0.D0) THEN
  888. IF(ABS(XLMBDA-XLAM(ITER))/XLMBDA.
  889. & LT.1.D-3) GO TO 7999
  890. ENDIF
  891. ENDIF
  892. *
  893. GO TO 8000
  894. *
  895. * 2-EME BOUCLE SUR LES ELEMENTS
  896. *
  897. 7999 CONTINUE
  898. SLON=0.0D0
  899. FAI=0.0D0
  900. IAM=0
  901. DO 4005 IC=1,NBELEM
  902.  
  903. if(ivers) then
  904. C ordre inverse
  905. JC= NBELEM+1-IC
  906. else
  907. C ordre normal
  908. JC=IC
  909. endif
  910.  
  911. C ---- ON RECUPERE LES GRANDEURS GEOMETRIQUES -----------
  912.  
  913. IAM=IAM+1
  914. ALFA = DANG(IAM)
  915. DS1 = DACUR(IAM)
  916.  
  917. do 12345 iptg=1,nbpgau
  918.  
  919. if(ivers) then
  920. ig= nbpgau+1-iptg
  921. else
  922. ig = iptg
  923. endif
  924.  
  925. C ---- Récupération des EFFX deja présents -----------
  926.  
  927. IF (IPCHC1.EQ.0) THEN
  928. SINI = 0.D0
  929. ELSE
  930. mptval = ivasi0
  931. MELVAL = IVAL(ipeffx)
  932. SINI =velche(min(ig,velche(/1)),
  933. & min(JC,velche(/2)))
  934. ENDIF
  935.  
  936. C ---- Récupération des caractéristiques matérielles et géométriques ----
  937.  
  938. melval =ivamat
  939. ea = velche(min(ig,velche(/1)),
  940. & min(JC,velche(/2)))
  941.  
  942. melval =ivacar
  943. sect1 = velche(min(ig,velche(/1)),
  944. & min(JC,velche(/2)))
  945.  
  946. C --- Calcul des pertes de précontrainte -------------------
  947.  
  948. ICOMP = 0
  949. call precn1(PS1,ea,f1,f2,ganc,RMU0,FPRG,RH10,
  950. & SLON+DS1*(1+qsigau(iptg))/2,FAI,SINI,
  951. & SECT1,XLMBDA,SD,LAST,PSL,PSOUT,ICOMP)
  952. IF (ICOMP.EQ.1) THEN
  953. CALL ERREUR(768)
  954. goto 9990
  955. RETURN
  956. ENDIF
  957.  
  958. C --- On range les résultats
  959.  
  960. iret=1
  961. MPTVAL=IVASTR
  962. DO 1700 I=1,NSTRS
  963. MELVAL=IVAL(I)
  964. VELCHE(ig,JC)=PSOUT
  965. 1700 CONTINUE
  966.  
  967. 12345 continue
  968. SLON=SLON+DS1
  969. FAI=FAI+ALFA
  970. C write(6,*) 'slon et fai ',slon,fai
  971.  
  972. 4005 CONTINUE
  973. SEGSUP ALTRAV
  974. C---------------------- endif sur CERC ou ELEMENTS LINEAIRE
  975. END IF
  976.  
  977. C
  978. 9990 CONTINUE
  979.  
  980. SEGSUP WRK3
  981. SEGDES IMODEL
  982. IF(IERR.NE.0)THEN
  983. SEGSUP MCHAML
  984. ELSE
  985. SEGDES MCHAML
  986. ENDIF
  987. C
  988. segdes meleme
  989. c
  990. melval = ivacar
  991. segdes melval
  992. melval = ivamat
  993. segdes melval,mcham6,mchel6
  994.  
  995. C CALL DTMVAL(IVACAR,1)
  996.  
  997. if(IPCHC1.gt.0) call dtmval(ivasi0,1)
  998. C
  999. IF(IERR.NE.0)THEN
  1000. CALL DTMVAL(IVASTR,3)
  1001. ELSE
  1002. CALL DTMVAL(IVASTR,1)
  1003. ENDIF
  1004. C
  1005. IF(MOMATR.NE.0)THEN
  1006. NOMID=MOMATR
  1007. SEGSUP NOMID
  1008. ENDIF
  1009. IF(MOCARA.NE.0)THEN
  1010. NOMID=MOCARA
  1011. SEGSUP NOMID
  1012. ENDIF
  1013. IF(MOSTRS.NE.0)THEN
  1014. NOMID=MOSTRS
  1015. if(lsupco)SEGSUP NOMID
  1016. ENDIF
  1017. C
  1018. SEGSUP INFO
  1019. if(iret.eq.0) return
  1020. C
  1021. 500 CONTINUE
  1022. c-------- Fin de la boucle sur les zones du MODELE TEMPORAIRE
  1023. C
  1024. C =========== rangement dans le MCHELM final MCHEL5
  1025. if(ifomod.ne.0.and.ifomod.ne.1) then
  1026. C les cables standards
  1027. segact siezo
  1028. C segact mchel5
  1029. MCHELM = IPSTRS
  1030. segact MCHELM
  1031. C
  1032. C boucle sur les zones du modele ou champ initial
  1033.  
  1034. C
  1035. ibc= 0
  1036. do 3010 isous=1,mchel5.imache(/1)
  1037. sielc = iezon(isous)
  1038. segact sielc
  1039. C
  1040. mcham5= mchel5.ichaml(isous)
  1041. segact mcham5
  1042. melva5 =mcham5.ielval(1)
  1043. segact melva5*mod
  1044. C boucle sur les partitions provisoires de la sz
  1045. C
  1046. inel = 0
  1047. do 3020 ik=1,nbcz
  1048. ibc=ibc+1
  1049. mchaml=ichaml(ibc)
  1050. segact mchaml
  1051. melval=ielval(1)
  1052. segact melval
  1053. C
  1054. do iii=1,velche(/2)
  1055. inel = inel+1
  1056. iel=isens(1,inel)
  1057. if(isens(2,inel).eq.1) then
  1058. do ip=1,velche(/1)
  1059. melva5.velche(ip,iel)=velche(ip,iii)
  1060. enddo
  1061. else
  1062. do ip=1,velche(/1)
  1063. melva5.velche(3-ip,iel)=velche(ip,iii)
  1064. enddo
  1065. endif
  1066. enddo
  1067. 3020 continue
  1068. segsup sielc
  1069. segdes melva5,mcham5
  1070. 3010 continue
  1071. call DTCHAM(ipcar2)
  1072. if(ipchc2.ne.0) call DTCHAM(ipchc2)
  1073. segsup ipt5
  1074. else
  1075. C les cerc
  1076. icha1 = MCHEL5
  1077. MCHEL5 = MCHELM
  1078. MCHELM = icha1
  1079. endif
  1080. 333 format(i4,2E12.5)
  1081. C maintenant les destructions d objets temporaires
  1082. call DTCHAM(MCHELM)
  1083. C call DTMODL(ipmodt)
  1084. mmodel = ipmodt
  1085. segsup mmodel
  1086. C
  1087. segdes MCHEL5
  1088. IPSTRS =MCHEL5
  1089. iret = 1
  1090. return
  1091. END
  1092.  
  1093.  
  1094.  
  1095.  
  1096.  
  1097.  
  1098.  
  1099.  
  1100.  
  1101.  
  1102.  
  1103.  
  1104.  
  1105.  

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