Télécharger la plaquette Cast3M


fr en

Télécharger precop.eso

Retour à la liste

Numérotation des lignes : 

precop

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

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