Télécharger la plaquette Cast3M


fr en

Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes : 

bsigm1

  1. C BSIGM1    SOURCE    CB215821  24/04/12    21:15:07     11897          
  2.       SUBROUTINE BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,
  3.      &        IPMINT,IVACAR,IPORE,LHOOK,NFOR,IVAFOR,ADPG,BDPG,CDPG,
  4.      &        IIPDPG,NCAR1,MELPHA,noer)
  5. *----------------------------------------------------------------------
  6. *         ______________________________                              *
  7. *        |                              |                             *
  8. *        |  CALCUL DES FORCES AUX NOEUDS|                             *
  9. *        |______________________________|                             *
  10. *                                                                     *
  11. *        massif, poreux, incompressibles                              *
  12. *                                                                     *
  13. *---------------------------------------------------------------------*
  14. *                                                                     *
  15. *   ENTREES :                                                         *
  16. *   ________                                                          *
  17. *                                                                     *
  18. *        IPMAIL   Pointeur sur un segment  MELEME           ACTIF E/S *
  19. *        LRE      Nombre de ddl dans la matrice de rigidite           *
  20. *        NSTRS    Nombre de composante de contraintes/deformations    *
  21. *        NBPGAU   Nombre de points d'integration pour les contraintes *
  22. *        MELE     Numero de l'element fini                            *
  23. *        MFR      Numero de la formulation                            *
  24. *        IVASTR   pointeur sur un segment MPTVAL contenant les        *
  25. *                 les melvals de contraints                           *
  26. *        IPMINT   Pointeur sur un segment MINTE             ACTIF E/S *
  27. *        IVACAR   pointeur sur un segment MPTVAL de caracteristiques  *
  28. *        IPORE    Nombre de fonctions de forme                        *
  29. *        LHOOK    Taille de la matrice de hooke                       *
  30. *        NFOR     Nombre de composantes de forces                     *
  31. *                                                                     *
  32. *   SORTIES :                                                         *
  33. *   ________                                                          *
  34. *                                                                     *
  35. *        IVAFOR   pointeur sur un segment MPTVAL contenant les        *
  36. *                 les melvals de forces                               *
  37. *                                                                     *
  38. *        ADPG      forces aux noeud support des                       *
  39. *        BDPG      deformations planes generalisees                   *
  40. *        CDPG                                                         *
  41. *                                                                     *
  42. *---------------------------------------------------------------------*
  43.       IMPLICIT INTEGER(I-N)
  44.       IMPLICIT REAL*8(A-H,O-Z)
  45.  
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC CCREEL
  50. -INC CCHAMP
  51. -INC CCGEOME
  52.  
  53. -INC SMCHAML
  54. -INC SMCHPOI
  55. -INC SMELEME
  56. -INC SMCOORD
  57. -INC SMMODEL
  58. -INC SMINTE
  59. C
  60.       SEGMENT MWRK1
  61.         REAL*8 XFORC(LRE), XFINC(LRE),XSTRS(NSTRS), XE(3,NBBB)
  62.         REAL*8 SHPWRK(6,NBNO), BGENE(LHOOK,LRE)
  63.       ENDSEGMENT
  64. *
  65.       SEGMENT MWRK3
  66.        REAL*8 BPSS(3,3),XEL(3,NBBB)
  67.       ENDSEGMENT
  68. *
  69.       SEGMENT MWRK5
  70.        REAL*8 XGENE(NSTN,LRN)
  71.       ENDSEGMENT
  72. *
  73.       segment mwrk67
  74.          real*8 valcar(nca1)
  75.       endsegment
  76. *
  77.       SEGMENT MPTVAL
  78.         INTEGER IPOS(NS)    ,NSOF(NS)
  79.         INTEGER      IVAL(NCOSOU)
  80.         CHARACTER*16 TYVAL(NCOSOU)
  81.       ENDSEGMENT
  82. *
  83.       CHARACTER*8  CMATE,CELEM,MO8
  84.       DIMENSION A(4,60),BB(3,60),xatef1(3,3),PP(4,4)
  85.       logical drend
  86. *
  87.       MELEME=IPMAIL
  88.       NBNN=NUM(/1)
  89.       NBELEM=NUM(/2)
  90. *
  91.       IDECAP=0
  92.       NHRM=NIFOUR
  93.       IELE=NUMGEO(MELE)
  94. *
  95.       MINTE=IPMINT
  96. C_______________________________________________________________________
  97. C
  98. C     NUMERO DES ETIQUETTES      :
  99. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  100. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  101. C     5  CONTINUE
  102. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  103. C     44 CONTINUE
  104. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  105. C_______________________________________________________________________
  106. C
  107.       IF(MELE.GE.1.AND.MELE.LE.100) THEN
  108. C            CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  109.       GOTO (   99,  99,  99,   4,  99,   4,  99,   4,  99,   4
  110. C            QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  111.      1      ,  99,  99,  99,   4,   4,   4,   4,  99,  99,  99
  112. C            LIA8 MULT TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP
  113.      2      ,  99,  99,   4,   4,   4,   4,  99,  99,  99,  99
  114. C            FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  115.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  116. C            COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  117.      4      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  118. C            COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  119.      5      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  120. C            CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  121.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,   4,   4
  122. C            ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  123.      7      ,   4,   4,   4,   4,   4,   4,   4,   4,  79,  79
  124. C            CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  125.      8      ,  79,  79,  79,  79,  99,  99,  99,  99,  99,  99
  126. C            LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  127.      9      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99)
  128. c cccccc
  129.      .      ,MELE
  130.       ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  131. C            HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  132.       GOTO (   99,  99,  99,  99,  99,  99,  99,  80,  80,  80
  133. C            POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  134.      1      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  135. C            PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  136.      2      ,   4,   4,  99,  99,  99,  99,  99,  99,  99,  99
  137. C            QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  138.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  139. C            MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  140.      4      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  141. C            TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  142.      5      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  143. C            BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  144.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  145. C            JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  146.      7      ,  99,  99, 173, 173, 173, 173, 173, 173, 173, 173
  147. C            TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  148.      8      , 173, 173,   4,   4, 185, 185, 185, 185, 185, 185
  149. C            T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  150.      9      ,  99,  99,   4,   4,  99,  99,  99,  99,  99,  99)
  151. c cccccc
  152.      .      ,MELE-100
  153.       ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  154. C            LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  155.       GOTO (   99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  156. C            BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  157.      1      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  158. C            MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  159.      2      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  160. C            MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  161.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  162. C            QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  163.      4      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  164. C            QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  165.      5      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  166. C            CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  167.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  168. C            COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  169.      7      ,  99,  99,   4,   4,   4,   4,   4,   4,   4,   4)
  170. c cccccc
  171.      .      ,MELE-200
  172.       ENDIF
  173. C
  174. C_______________________________________________________________________
  175. C
  176. C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES
  177. C_______________________________________________________________________
  178. C
  179.    4  CONTINUE
  180.       DIM3=1.D0
  181.       NBNO=NBNN
  182.       NBBB=NBNN
  183. C
  184. C    INTRODUCTION DES COORD DU POINT AUTOUR DUQUEL SE FAIT LE
  185. C    MOUVEMENT DE LA SECTION EN DEFO PLANE GENERALISEE
  186. C    Pas de rotation en 1D
  187. C    ET INITIALISATION DES FORCES AU NOEUD SUPPORT DE LA DEFO
  188. C    PLANE GENERALISEE
  189.       IF (IIPDPG.GT.0)THEN
  190.         IREF=(IIPDPG-1)*(IDIM+1)
  191.         XDPGE=XCOOR(IREF+1)
  192.         YDPGE=XCOOR(IREF+2)
  193.       ELSE
  194.         XDPGE=XZero
  195.         YDPGE=XZero
  196.       ENDIF
  197.       ADPG=XZero
  198.       BDPG=XZero
  199.       CDPG=XZero
  200. C
  201.       SEGINI MWRK1
  202.       mwrk67=0
  203.  
  204.       if (melpha.gt.0) melva1 = melpha
  205.  
  206.       DO 3004  IB=1,NBELEM
  207. C
  208. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  209. C
  210.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  211. C
  212. C     MISE A 0 DES FORCES
  213. C
  214.       CALL ZERO(XFINC,1,LRE)
  215. C
  216. C     BOUCLE SUR LES POINTS DE GAUSS
  217. C
  218. C     CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE (INCOMPRES)
  219.       IF (MFR.EQ.31) THEN
  220.         CALL BBCALC(MELE,NBNN,MFR,IDIM,XE,
  221.      &              NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  222.      &              NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK,
  223.      &              BGENE,XDPGE,YDPGE,PP)
  224.       ENDIF
  225.  
  226.       ISDJC=0
  227.       DO 5004  IGAU=1,NBPGAU
  228. C
  229. C   RECUPERATION DE L'EPAISSEUR
  230. C
  231.         DIM3=1.D0
  232.       IF (IFOUR.EQ.-2)THEN
  233.         MPTVAL=IVACAR
  234.         IF (IVACAR.NE.0) THEN
  235.          MELVAL=IVAL(1)
  236.          IF (MELVAL.NE.0) THEN
  237.           IGMN=MIN(IGAU,VELCHE(/1))
  238.           IBMN=MIN(IB,VELCHE(/2))
  239.           DIM3=VELCHE(IGMN,IBMN)
  240.          ENDIF
  241.         ENDIF
  242.       ENDIF
  243. *
  244.       CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  245.      1            MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,
  246.      2            XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  247.  
  248.       IF (DJAC.EQ.0.D0) THEN
  249.         INTERR(1)=IB
  250.         if (noer.eq.0) then
  251.          CALL ERREUR(259)
  252.          GOTO 9904
  253.         else
  254.          noer=259
  255.          return
  256.         endif
  257.       ENDIF
  258.       IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  259. *
  260.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  261.  
  262. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  263.       IF (MFR.EQ.31) THEN
  264.         CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  265.      &            MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  266.       ENDIF
  267. C
  268. C     ON CHERCHE LES CONTRAINTES
  269. C
  270.       MPTVAL=IVASTR
  271.       DO 6004 ICOMP=1,NSTRS
  272.         MELVAL=IVAL(ICOMP)
  273.         IGMN=MIN(IGAU,VELCHE(/1))
  274.         IBMN=MIN(IB  ,VELCHE(/2))
  275.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  276.  6004 CONTINUE
  277. C
  278. C     CALCUL DE B*SIGMA
  279. C
  280. * initialise
  281.       CALL ZERO(XFORC,1,LRE)
  282. * contribution point  d integration
  283.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  284. * matrice d'efficacite
  285.         drend = .false.
  286.         MPTVAL=IVACAR
  287.         IF (IVACAR.GT.0) THEN
  288.          nca1 = ival(/1)
  289.          if (mwrk67.eq.0) segini mwrk67
  290.          if (nca1.ne.valcar(/1)) segadj mwrk67
  291.          celem = 'MASSIF  '
  292.          IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
  293.           DO 9008 IM= 1,IVAL(/1)
  294.           IF (IVAL(IM).GT.0) THEN
  295.             MELVAL=IVAL(IM)
  296.  
  297. C         Pour optimisation et eviter _gfortran_compare_string inefficace
  298.             MO8=TYVAL(IM)(1:8)
  299.             IF (MO8.EQ.'REAL*8  ') THEN
  300.               IBMN=MIN(IB  ,VELCHE(/2))
  301.               IGMN=MIN(IGAU,VELCHE(/1))
  302.               VALCAR(IM)=VELCHE(IGMN,IBMN)
  303.             ELSE
  304.               IBMN=MIN(IB  ,IELCHE(/2))
  305.               IGMN=MIN(IGAU,IELCHE(/1))
  306.               VALCAR(IM)=IELCHE(IGMN,IBMN)
  307.             ENDIF
  308.           ELSE
  309.             VALCAR(IM)=0.D0
  310.           ENDIF
  311.  9008    CONTINUE
  312.         nstep = 2
  313.         if (ifour.eq.2) nstep = 3
  314.         MO8=TYVAL(ncar1)(1:8)
  315.         if (ival(ncar1).gt.0.and.MO8.eq.'REAL*8  ') then
  316.            drend = .true.
  317.            do i = 1,nstep
  318.             do j = 1, nstep
  319.               xatef1(i,j) = 0.d0
  320.             enddo
  321.             xatef1(i,i) = valcar(ncar1)
  322.           enddo
  323.         endif
  324.         MO8=TYVAL(ncar1+1)(1:8)
  325.         if (ival(ncar1).eq.0.and.MO8.eq.'REAL*8  ') then
  326.           drend = .false.
  327.           do i = 1,nstep
  328.             do j = 1, nstep
  329.               xatef1(i,j) = 0.d0
  330.             enddo
  331.             xatef1(1,1) = valcar(ncar1+7)
  332.             xatef1(2,2) = valcar(ncar1+8)
  333.             if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  334.           enddo
  335.         endif
  336.         call effi3(valcar,tyval,nca1,ncar1,xforc,lre,ib,igau,xatef1,
  337.      & nstep,drend,celem)
  338.         ENDIF
  339.       ENDIF
  340.  
  341. * ponderation par la phase
  342.         IF (MELPHA.GT.0) THEN
  343.           IBMN=MIN(IB  ,melva1.VELCHE(/2))
  344.           IGMN=MIN(IGAU,melva1.VELCHE(/1))
  345.           coe1 = melva1.velche(igmn,ibmn)
  346.        CALL OPTABj(1,1,2,1,xforc,0.d0,xforc,LRE,1,LRE,2,0,coe1,IRETO)
  347.         ENDIF
  348.  
  349. *  stocke
  350. C      do ii = 1,LRE
  351. C          xfinc(ii) = xfinc(ii) + xforc(ii)
  352. C      enddo
  353. C      On realise l'addition en FORTRAN pur (plus rapide)
  354.        CALL OPTABj(1,1,3,2,xfinc,xforc,xfinc,LRE,LRE,LRE,0,0,0.D0,IRETO)
  355. *
  356.  5004 CONTINUE
  357.  
  358.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  359.         INTERR(1)=IB
  360.         if (noer.eq.0) then
  361.          CALL ERREUR(195)
  362.          GOTO 9904
  363.         else
  364.          noer=195
  365.          return
  366.         endif
  367.       ENDIF
  368. C
  369. C   EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  370. C   ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  371. C
  372.       NFOFO=NFOR
  373.       if (IIPDPG.gt.0) then
  374.       IF (IFOUR.EQ.-3) THEN
  375.         NFOFO=NFOR-3
  376.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  377.         BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  378.         CDPG=CDPG+XFINC(NBNN*NFOFO+3)
  379.       ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  380.      .         IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  381.         NFOFO=NFOR-1
  382.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  383.       ELSE IF (IFOUR.EQ.11) THEN
  384.         NFOFO=NFOR-2
  385.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  386.         BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  387.       ENDIF
  388.       endif
  389. C
  390. C     ON RANGE XFORC DANS MELVAL
  391. C
  392.       IE=0
  393.       MPTVAL=IVAFOR
  394.       DO IGAU=1,NBNN
  395.        DO ICOMP=1,NFOFO
  396.         IE=IE+1
  397.         MELVAL=IVAL(ICOMP)
  398.         IBMN=MIN(IB  ,VELCHE(/2))
  399.         VELCHE(IGAU,IBMN)=XFINC(IE)
  400.        ENDDO
  401.       ENDDO
  402.  3004 CONTINUE
  403.  
  404.  9904 CONTINUE
  405.       SEGSUP MWRK1
  406.       if (mwrk67.ne.0) segsup mwrk67
  407.       GOTO 510
  408. C__________________________________________________________________
  409. C_______________________________________________________________________
  410. C
  411. C     MILIEUX POREUX
  412. C_______________________________________________________________________
  413. C
  414.   79  CONTINUE
  415. C
  416. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  417. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  418. C
  419.       DIM3=1.D0
  420.       NBNO=IPORE
  421.       NBBB=NBNN
  422.       LRN = NBNO-NBBB
  423.       LRB=LRE-LRN
  424. *
  425.       NSTN=1
  426.       SEGINI MWRK1,MWRK5
  427. C
  428.       DO 3079  IB=1,NBELEM
  429. C
  430. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  431. C
  432.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  433. C
  434. C     MISE A 0 DES FORCES
  435. C
  436.       CALL ZERO(XFORC,1,LRE)
  437. C
  438. C     BOUCLE SUR LES POINTS DE GAUSS
  439. C
  440.       ISDJC=0
  441.       DO 5079  IGAU=1,NBPGAU
  442. C
  443. C   RECUPERATION DE L'EPAISSEUR
  444. C
  445.       IF (IFOUR.EQ.-2)THEN
  446.         MPTVAL=IVACAR
  447.         IF (IVACAR.NE.0) THEN
  448.          MELVAL=IVAL(1)
  449.          IF (MELVAL.NE.0) THEN
  450.           IGMN=MIN(IGAU,VELCHE(/1))
  451.           IBMN=MIN(IB,VELCHE(/2))
  452.           DIM3=VELCHE(IGMN,IBMN)
  453.         ELSE
  454.           DIM3=1.D0
  455.         ENDIF
  456.        ENDIF
  457.       ENDIF
  458. C
  459.       CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  460.      .            DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  461.       IF (DJAC.EQ.0.D0) THEN
  462.         INTERR(1)=IB
  463.         if (noer.eq.0) then
  464.          CALL ERREUR(259)
  465.          GOTO 9979
  466.         else
  467.          noer=259
  468.          return
  469.         endif
  470.       ENDIF
  471.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  472.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  473. C
  474. C     ON CHERCHE LES CONTRAINTES
  475. C
  476.       MPTVAL=IVASTR
  477.       DO 6079 ICOMP=1,NSTRS
  478.         MELVAL=IVAL(ICOMP)
  479.         IGMN=MIN(IGAU,VELCHE(/1))
  480.         IBMN=MIN(IB  ,VELCHE(/2))
  481.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  482.  6079 CONTINUE
  483. C
  484. C     CALCUL DE B*SIGMA
  485. C
  486.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  487.  
  488. *     ON AJOUTE LES TERMES EN FP
  489. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  490. *
  491.       r_z = XSTRS(NSTRS)*DJAC
  492.       DO 6179 J=1,LRN
  493.          JJ=LRB+J
  494.          XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J)
  495.  6179 CONTINUE
  496. *
  497.  5079 CONTINUE
  498.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  499.         INTERR(1)=IB
  500.         if (noer.eq.0) then
  501.          CALL ERREUR(195)
  502.          GOTO 9979
  503.         else
  504.          noer=195
  505.          return
  506.         endif
  507.       ENDIF
  508. C
  509. C     ON RANGE XFORC DANS MELVAL
  510. C     D'ABORD LES FORCES PUIS LES DEBITS
  511. C
  512.       IE=0
  513.       MPTVAL=IVAFOR
  514.       DO IGAU=1,NBNN
  515.        DO ICOMP=1,NFOR-1
  516.         IE=IE+1
  517.         MELVAL=IVAL(ICOMP)
  518.         VELCHE(IGAU,IB)=XFORC(IE)
  519.        ENDDO
  520.       ENDDO
  521. *
  522.       DO 7179 IGAU=1,NBSOM(IELE)
  523.         IE=IE+1
  524.         MELVAL=IVAL(NFOR)
  525.         IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  526.         VELCHE(IGAV,IB)=XFORC(IE)
  527.  7179 CONTINUE
  528. *
  529.  3079 CONTINUE
  530.  
  531.  9979 CONTINUE
  532.       SEGSUP MWRK1,MWRK5
  533.       GOTO 510
  534. C_______________________________________________________________________
  535. C__________________________________________________________________
  536. C
  537. C     MILIEUX POREUX - SUITE
  538. C_______________________________________________________________________
  539. C
  540.  173  CONTINUE
  541. C
  542. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  543. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  544. C
  545.       DIM3=1.D0
  546.       NBNO=IPORE
  547.       NBBB=NBNN
  548.       IF(MELE.GE.173.AND.MELE.LE.177) THEN
  549.         IDECAP = 2
  550.       ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  551.         IDECAP = 3
  552.       ENDIF
  553. *
  554.       NSTN=IDECAP
  555.       NSTB=4
  556.       IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  557.       LPP = NBNO-NBBB
  558.       LRN=IDECAP*LPP
  559.       LRB=LRE-LRN
  560.  
  561.       SEGINI MWRK1,MWRK5
  562. C
  563.       DO 3173  IB=1,NBELEM
  564. C
  565. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  566. C
  567.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  568. C
  569. C     MISE A 0 DES FORCES
  570. C
  571.       CALL ZERO(XFORC,1,LRE)
  572. C
  573. C     BOUCLE SUR LES POINTS DE GAUSS
  574. C
  575.       ISDJC=0
  576.       DO 5173  IGAU=1,NBPGAU
  577. C
  578. C   RECUPERATION DE L'EPAISSEUR
  579. C
  580.       IF (IFOUR.EQ.-2)THEN
  581.         MPTVAL=IVACAR
  582.         IF (IVACAR.NE.0) THEN
  583.          MELVAL=IVAL(1)
  584.          IF (MELVAL.NE.0) THEN
  585.           IGMN=MIN(IGAU,VELCHE(/1))
  586.           IBMN=MIN(IB,VELCHE(/2))
  587.           DIM3=VELCHE(IGMN,IBMN)
  588.         ELSE
  589.           DIM3=1.D0
  590.         ENDIF
  591.        ENDIF
  592.       ENDIF
  593. C
  594.       CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  595.      &     DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  596.       IF (DJAC.EQ.0.D0) THEN
  597.         INTERR(1)=IB
  598.         if (noer.eq.0) then
  599.          CALL ERREUR(259)
  600.          GOTO 99173
  601.         else
  602.          noer=259
  603.          return
  604.         endif
  605.       ENDIF
  606.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  607.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  608. C
  609. C     ON CHERCHE LES CONTRAINTES
  610. C
  611.       MPTVAL=IVASTR
  612.       DO 6173 ICOMP=1,NSTRS
  613.         MELVAL=IVAL(ICOMP)
  614.         IGMN=MIN(IGAU,VELCHE(/1))
  615.         IBMN=MIN(IB  ,VELCHE(/2))
  616.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  617.  6173 CONTINUE
  618. C
  619. C     CALCUL DE B*SIGMA
  620. C
  621.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  622. *
  623. *     ON AJOUTE LES TERMES EN FP
  624. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  625. *
  626.       DO 6273 IPR=1,IDECAP
  627.          IPR1=(IPR-1)*LPP
  628.          IPR2=NSTRS-IDECAP+IPR
  629.          r_z = XSTRS(IPR2) * DJAC
  630.          DO 6373 J=1,LPP
  631.            JJ=LRB+IPR1+J
  632.            XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J)
  633.  6373    CONTINUE
  634.  6273 CONTINUE
  635. *
  636.  5173 CONTINUE
  637.  
  638.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  639.         INTERR(1)=IB
  640.         if (noer.eq.0) then
  641.          CALL ERREUR(195)
  642.          GOTO 99173
  643.         else
  644.          noer=195
  645.          return
  646.         endif
  647.       ENDIF
  648. C
  649. C     ON RANGE XFORC DANS MELVAL
  650. C     D'ABORD LES FORCES PUIS LES DEBITS
  651. C
  652.       IE=0
  653.       MPTVAL=IVAFOR
  654.       DO IGAU=1,NBNN
  655.        DO ICOMP=1,NFOR-IDECAP
  656.         IE=IE+1
  657.         MELVAL=IVAL(ICOMP)
  658.         VELCHE(IGAU,IB)=XFORC(IE)
  659.        ENDDO
  660.       ENDDO
  661. *
  662.       DO 7273 IPR=1,IDECAP
  663.          IPR1=NFOR-IDECAP+IPR
  664.          DO 7373 IGAU=1,NBSOM(IELE)
  665.            IE=IE+1
  666.            MELVAL=IVAL(IPR1)
  667.            IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  668.            VELCHE(IGAV,IB)=XFORC(IE)
  669.  7373    CONTINUE
  670.  7273 CONTINUE
  671. *
  672.  3173 CONTINUE
  673. *
  674. 99173 CONTINUE
  675.       SEGSUP MWRK1,MWRK5
  676.       GOTO 510
  677. C__________________________________________________________________
  678. C_______________________________________________________________________
  679. C
  680. C     JOINTS EN FORMULATION MILIEUX POREUX
  681. C_______________________________________________________________________
  682. C
  683.   80  CONTINUE
  684. C
  685. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  686. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  687. C
  688.       NBNO=IPORE
  689.       NBBB=NBNN
  690.       LRN=(NBNO-NBBB)*3/2
  691.       LRB=LRE-LRN
  692.       NSTN=1
  693.       NFAC=(3*NBBB-NBNO)/2
  694.       NMIL=LRN-NBSOM(IELE)
  695.       SEGINI MWRK1,MWRK3,MWRK5
  696.       I195=0
  697.       I259=0
  698. C
  699.       DO 3080  IB=1,NBELEM
  700. C
  701. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  702. C
  703.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  704. C
  705. C     CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  706. C
  707.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  708. C
  709. C     MISE A 0 DES FORCES
  710. C
  711.       CALL ZERO(XFORC,1,LRE)
  712. C
  713. C     BOUCLE SUR LES POINTS DE GAUSS
  714. C
  715.       ISDJC=0
  716.       DO 5080  IGAU=1,NBPGAU
  717. C
  718.       CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  719.      .            SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  720.       IF (DJAC.EQ.0.) THEN
  721.         INTERR(1)=IB
  722.         if (noer.eq.0) then
  723.          CALL ERREUR(259)
  724.          GOTO 9980
  725.         else
  726.          noer=259
  727.          return
  728.         endif
  729.       ENDIF
  730.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  731.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  732. C
  733. C     ON CHERCHE LES CONTRAINTES
  734. C
  735.       MPTVAL=IVASTR
  736.       DO 6080 ICOMP=1,NSTRS
  737.         MELVAL=IVAL(ICOMP)
  738.         IGMN=MIN(IGAU,VELCHE(/1))
  739.         IBMN=MIN(IB  ,VELCHE(/2))
  740.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  741.  6080 CONTINUE
  742. C
  743. C     CALCUL DE B*SIGMA
  744. C
  745.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  746. *
  747. *     ON AJOUTE LES TERMES EN FP
  748. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  749. *
  750.       r_z = XSTRS(NSTRS)*DJAC
  751.       DO 6180 J=1,LRN
  752.          JJ=LRB+J
  753.          XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z
  754.  6180 CONTINUE
  755.  
  756.  5080 CONTINUE
  757.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  758.         INTERR(1)=IB
  759.         if (noer.eq.0) then
  760.          CALL ERREUR(195)
  761.          GOTO 9980
  762.         else
  763.          noer=195
  764.          return
  765.         endif
  766.       ENDIF
  767. C
  768. C     ON RANGE XFORC DANS MELVAL
  769. C     D'ABORD LES FORCES PUIS LES DEBITS
  770. C
  771.       MPTVAL=IVAFOR
  772. C
  773.       IE=0
  774.       DO IGAU=1,NFAC
  775.         DO ICOMP=1,NFOR-1
  776.           IE=IE+1
  777.           MELVAL=IVAL(ICOMP)
  778.           VELCHE(IGAU,IB)=XFORC(IE)
  779.         ENDDO
  780.       ENDDO
  781. *
  782. *     debits ( d'abord sommets puis mileux des cotes ad-hoc )
  783. *
  784.       MELVAL=IVAL(NFOR)
  785.       IGMN = NSPOS(IELE)-1
  786.       DO IGAU=1,NBSOM(IELE)
  787.          IE   = IE+1
  788.          IGAV = IBSOM(IGMN + IGAU)
  789. C*       VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  790.          VELCHE(IGAV,IB)=0.D0
  791.       ENDDO
  792. *
  793.       IGMN = NBBB - NMIL
  794.       DO IGAU=1,NMIL
  795.          IE=IE+1
  796.          IGAV  = IGMN + IGAU
  797.          VELCHE(IGAV,IB)=XFORC(IE)
  798.       ENDDO
  799. *
  800.  3080 CONTINUE
  801.  
  802.  9980 CONTINUE
  803.       SEGSUP MWRK1,MWRK3,MWRK5
  804.       GOTO 510
  805. C__________________________________________________________________
  806. C_______________________________________________________________________
  807. C
  808. C     JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  809. C_______________________________________________________________________
  810. C
  811.  185  CONTINUE
  812. C
  813. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  814. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  815. C
  816.       IF (MELE.GE.185.AND.MELE.LE.187) THEN
  817.         IDECAP = 2
  818.       ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  819.         IDECAP = 3
  820.       ENDIF
  821. C
  822.       NBNO=IPORE
  823.       NSTN=IDECAP
  824.       NSTB=2
  825.       IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  826. C
  827.       NBBB=NBNN
  828.       LPP=(NBNO-NBBB)*3/2
  829.       LRN=IDECAP*LPP
  830.       LRB=LRE-LRN
  831.       NFAC=(3*NBBB-NBNO)/2
  832.       NMIL=LPP-NBSOM(IELE)
  833.       SEGINI MWRK1,MWRK3,MWRK5
  834.       I195=0
  835.       I259=0
  836. C
  837.       DO 3185  IB=1,NBELEM
  838. C
  839. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  840. C
  841.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  842. C
  843. C     CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  844. C
  845.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  846. C
  847. C     MISE A 0 DES FORCES
  848. C
  849.       CALL ZERO(XFORC,1,LRE)
  850. C
  851. C     BOUCLE SUR LES POINTS DE GAUSS
  852. C
  853.       ISDJC=0
  854.       DO 5185  IGAU=1,NBPGAU
  855. C
  856.       CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  857.      .      SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  858.       IF (DJAC.EQ.0.) THEN
  859.         INTERR(1)=IB
  860.         if (noer.eq.0) then
  861.          CALL ERREUR(259)
  862.          GOTO 9985
  863.         else
  864.          noer=259
  865.          return
  866.         endif
  867.       ENDIF
  868.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  869.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  870. C
  871. C     ON CHERCHE LES CONTRAINTES
  872. C
  873.       MPTVAL=IVASTR
  874.       DO 6185 ICOMP=1,NSTRS
  875.         MELVAL=IVAL(ICOMP)
  876.         IGMN=MIN(IGAU,VELCHE(/1))
  877.         IBMN=MIN(IB  ,VELCHE(/2))
  878.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  879.  6185 CONTINUE
  880. C
  881. C     CALCUL DE B*SIGMA
  882. C
  883.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  884. *
  885. *     ON AJOUTE LES TERMES EN FP
  886. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  887. *
  888.       DO IPR=1,IDECAP
  889.         IPR1=(IPR-1)*LPP
  890.         IPR2=NSTRS-IDECAP+IPR
  891.         r_z = XSTRS(IPR2)*DJAC
  892.         DO J=1,LPP
  893.           JJ=LRB+IPR1+J
  894.           XFORC(JJ)=XFORC(JJ)-XGENE(IPR,IPR1+J)*r_z
  895.         ENDDO
  896.       ENDDO
  897.  
  898.  5185 CONTINUE
  899.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  900.         INTERR(1)=IB
  901.         if (noer.eq.0) then
  902.          CALL ERREUR(195)
  903.          GOTO 9985
  904.         else
  905.          noer=195
  906.          return
  907.         endif
  908.       ENDIF
  909. C
  910. C     ON RANGE XFORC DANS MELVAL
  911. C     D'ABORD LES FORCES PUIS LES DEBITS
  912. C
  913.       IE=0
  914.       MPTVAL=IVAFOR
  915.       JCOMP = NFOR-IDECAP
  916.       DO IGAU=1,NFAC
  917.         DO ICOMP=1,JCOMP
  918.           IE=IE+1
  919.           MELVAL=IVAL(ICOMP)
  920.           VELCHE(IGAU,IB)=XFORC(IE)
  921.         ENDDO
  922.       ENDDO
  923. *
  924. *     debits ( d'abord sommets puis mileux des cotes ad-hoc )
  925. *
  926.       DO 7485 IPR=1,IDECAP
  927.         IPR1 = NFOR-IDECAP+IPR
  928.         MELVAL=IVAL(IPR1)
  929.  
  930.         DO 7285 IGAU=1,NBSOM(IELE)
  931.           IE=IE+1
  932.           IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  933. C*        VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  934.           VELCHE(IGAV,IB)=0.D0
  935.  7285   CONTINUE
  936. *
  937.         DO 7385 IGAU=1,NMIL
  938.           IE=IE+1
  939.           IGAV  = NBBB - NMIL +IGAU
  940.           VELCHE(IGAV,IB)=XFORC(IE)
  941.  7385   CONTINUE
  942.  7485 CONTINUE
  943. *
  944.  3185 CONTINUE
  945.  
  946.  9985 CONTINUE
  947.       SEGSUP MWRK1,MWRK3,MWRK5
  948.       GOTO 510
  949. C
  950. C
  951.    99 CONTINUE
  952.       MOTERR(1:4)=NOMTP(MELE)
  953.       MOTERR(5:12)='BSIGMA'
  954.       CALL ERREUR(86)
  955. C
  956.   510 CONTINUE
  957.  
  958.       END
  959.  
  960.  
  961.  
  962.  
  963.  
  964.  
  965.  
  966.  
  967.  
  968.  

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