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

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