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    SP204843  25/07/03    21:15:05     12308          
  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,NOER)
  221.         IF (NOER.NE.0) THEN
  222.           CALL ERREUR(noer)
  223.           RETURN
  224.         ENDIF
  225.       ENDIF
  226.  
  227.       ISDJC=0
  228.       DO 5004  IGAU=1,NBPGAU
  229. C
  230. C   RECUPERATION DE L'EPAISSEUR
  231. C
  232.         DIM3=1.D0
  233.       IF (IFOUR.EQ.-2)THEN
  234.         MPTVAL=IVACAR
  235.         IF (IVACAR.NE.0) THEN
  236.          MELVAL=IVAL(1)
  237.          IF (MELVAL.NE.0) THEN
  238.           IGMN=MIN(IGAU,VELCHE(/1))
  239.           IBMN=MIN(IB,VELCHE(/2))
  240.           DIM3=VELCHE(IGMN,IBMN)
  241.          ENDIF
  242.         ENDIF
  243.       ENDIF
  244. *
  245.       CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  246.      1            MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,
  247.      2            XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  248.  
  249.       IF (DJAC.EQ.0.D0) THEN
  250.         INTERR(1)=IB
  251.         if (noer.eq.0) then
  252.          CALL ERREUR(259)
  253.          GOTO 9904
  254.         else
  255.          noer=259
  256.          return
  257.         endif
  258.       ENDIF
  259.       IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  260. *
  261.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  262.  
  263. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  264.       IF (MFR.EQ.31) THEN
  265.         CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  266.      &            MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  267.       ENDIF
  268. C
  269. C     ON CHERCHE LES CONTRAINTES
  270. C
  271.       MPTVAL=IVASTR
  272.       DO 6004 ICOMP=1,NSTRS
  273.         MELVAL=IVAL(ICOMP)
  274.         IGMN=MIN(IGAU,VELCHE(/1))
  275.         IBMN=MIN(IB  ,VELCHE(/2))
  276.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  277.  6004 CONTINUE
  278. C
  279. C     CALCUL DE B*SIGMA
  280. C
  281. * initialise
  282.       CALL ZERO(XFORC,1,LRE)
  283. * contribution point  d integration
  284.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  285. * matrice d'efficacite
  286.         drend = .false.
  287.         MPTVAL=IVACAR
  288.         IF (IVACAR.GT.0) THEN
  289.          nca1 = ival(/1)
  290.          if (mwrk67.eq.0) segini mwrk67
  291.          if (nca1.ne.valcar(/1)) segadj mwrk67
  292.          celem = 'MASSIF  '
  293.          IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
  294.           DO 9008 IM= 1,IVAL(/1)
  295.           IF (IVAL(IM).GT.0) THEN
  296.             MELVAL=IVAL(IM)
  297.  
  298. C         Pour optimisation et eviter _gfortran_compare_string inefficace
  299.             MO8=TYVAL(IM)(1:8)
  300.             IF (MO8.EQ.'REAL*8  ') THEN
  301.               IBMN=MIN(IB  ,VELCHE(/2))
  302.               IGMN=MIN(IGAU,VELCHE(/1))
  303.               VALCAR(IM)=VELCHE(IGMN,IBMN)
  304.             ELSE
  305.               IBMN=MIN(IB  ,IELCHE(/2))
  306.               IGMN=MIN(IGAU,IELCHE(/1))
  307.               VALCAR(IM)=IELCHE(IGMN,IBMN)
  308.             ENDIF
  309.           ELSE
  310.             VALCAR(IM)=0.D0
  311.           ENDIF
  312.  9008    CONTINUE
  313.         nstep = 2
  314.         if (ifour.eq.2) nstep = 3
  315.         MO8=TYVAL(ncar1)(1:8)
  316.         if (ival(ncar1).gt.0.and.MO8.eq.'REAL*8  ') then
  317.            drend = .true.
  318.            do i = 1,nstep
  319.             do j = 1, nstep
  320.               xatef1(i,j) = 0.d0
  321.             enddo
  322.             xatef1(i,i) = valcar(ncar1)
  323.           enddo
  324.         endif
  325.         MO8=TYVAL(ncar1+1)(1:8)
  326.         if (ival(ncar1).eq.0.and.MO8.eq.'REAL*8  ') then
  327.           drend = .false.
  328.           do i = 1,nstep
  329.             do j = 1, nstep
  330.               xatef1(i,j) = 0.d0
  331.             enddo
  332.             xatef1(1,1) = valcar(ncar1+7)
  333.             xatef1(2,2) = valcar(ncar1+8)
  334.             if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  335.           enddo
  336.         endif
  337.         call effi3(valcar,tyval,nca1,ncar1,xforc,lre,ib,igau,xatef1,
  338.      & nstep,drend,celem)
  339.         ENDIF
  340.       ENDIF
  341.  
  342. * ponderation par la phase
  343.         IF (MELPHA.GT.0) THEN
  344.           IBMN=MIN(IB  ,melva1.VELCHE(/2))
  345.           IGMN=MIN(IGAU,melva1.VELCHE(/1))
  346.           coe1 = melva1.velche(igmn,ibmn)
  347.        CALL OPTABj(1,1,2,1,xforc,0.d0,xforc,LRE,1,LRE,2,0,coe1,IRETO)
  348.         ENDIF
  349.  
  350. *  stocke
  351. C      do ii = 1,LRE
  352. C          xfinc(ii) = xfinc(ii) + xforc(ii)
  353. C      enddo
  354. C      On realise l'addition en FORTRAN pur (plus rapide)
  355.        CALL OPTABj(1,1,3,2,xfinc,xforc,xfinc,LRE,LRE,LRE,0,0,0.D0,IRETO)
  356. *
  357.  5004 CONTINUE
  358.  
  359.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  360.         INTERR(1)=IB
  361.         if (noer.eq.0) then
  362.          CALL ERREUR(195)
  363.          GOTO 9904
  364.         else
  365.          noer=195
  366.          return
  367.         endif
  368.       ENDIF
  369. C
  370. C   EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  371. C   ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  372. C
  373.       NFOFO=NFOR
  374.       if (IIPDPG.gt.0) then
  375.       IF (IFOUR.EQ.-3) THEN
  376.         NFOFO=NFOR-3
  377.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  378.         BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  379.         CDPG=CDPG+XFINC(NBNN*NFOFO+3)
  380.       ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  381.      .         IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  382.         NFOFO=NFOR-1
  383.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  384.       ELSE IF (IFOUR.EQ.11) THEN
  385.         NFOFO=NFOR-2
  386.         ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  387.         BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  388.       ENDIF
  389.       endif
  390. C
  391. C     ON RANGE XFORC DANS MELVAL
  392. C
  393.       IE=0
  394.       MPTVAL=IVAFOR
  395.       DO IGAU=1,NBNN
  396.        DO ICOMP=1,NFOFO
  397.         IE=IE+1
  398.         MELVAL=IVAL(ICOMP)
  399.         IBMN=MIN(IB  ,VELCHE(/2))
  400.         VELCHE(IGAU,IBMN)=XFINC(IE)
  401.        ENDDO
  402.       ENDDO
  403.  3004 CONTINUE
  404.  
  405.  9904 CONTINUE
  406.       SEGSUP MWRK1
  407.       if (mwrk67.ne.0) segsup mwrk67
  408.       GOTO 510
  409. C__________________________________________________________________
  410. C_______________________________________________________________________
  411. C
  412. C     MILIEUX POREUX
  413. C_______________________________________________________________________
  414. C
  415.   79  CONTINUE
  416. C
  417. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  418. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  419. C
  420.       DIM3=1.D0
  421.       NBNO=IPORE
  422.       NBBB=NBNN
  423.       LRN = NBNO-NBBB
  424.       LRB=LRE-LRN
  425. *
  426.       NSTN=1
  427.       SEGINI MWRK1,MWRK5
  428. C
  429.       DO 3079  IB=1,NBELEM
  430. C
  431. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  432. C
  433.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  434. C
  435. C     MISE A 0 DES FORCES
  436. C
  437.       CALL ZERO(XFORC,1,LRE)
  438. C
  439. C     BOUCLE SUR LES POINTS DE GAUSS
  440. C
  441.       ISDJC=0
  442.       DO 5079  IGAU=1,NBPGAU
  443. C
  444. C   RECUPERATION DE L'EPAISSEUR
  445. C
  446.       IF (IFOUR.EQ.-2)THEN
  447.         MPTVAL=IVACAR
  448.         IF (IVACAR.NE.0) THEN
  449.          MELVAL=IVAL(1)
  450.          IF (MELVAL.NE.0) THEN
  451.           IGMN=MIN(IGAU,VELCHE(/1))
  452.           IBMN=MIN(IB,VELCHE(/2))
  453.           DIM3=VELCHE(IGMN,IBMN)
  454.         ELSE
  455.           DIM3=1.D0
  456.         ENDIF
  457.        ENDIF
  458.       ENDIF
  459. C
  460.       CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  461.      .            DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  462.       IF (DJAC.EQ.0.D0) THEN
  463.         INTERR(1)=IB
  464.         if (noer.eq.0) then
  465.          CALL ERREUR(259)
  466.          GOTO 9979
  467.         else
  468.          noer=259
  469.          return
  470.         endif
  471.       ENDIF
  472.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  473.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  474. C
  475. C     ON CHERCHE LES CONTRAINTES
  476. C
  477.       MPTVAL=IVASTR
  478.       DO 6079 ICOMP=1,NSTRS
  479.         MELVAL=IVAL(ICOMP)
  480.         IGMN=MIN(IGAU,VELCHE(/1))
  481.         IBMN=MIN(IB  ,VELCHE(/2))
  482.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  483.  6079 CONTINUE
  484. C
  485. C     CALCUL DE B*SIGMA
  486. C
  487.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  488.  
  489. *     ON AJOUTE LES TERMES EN FP
  490. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  491. *
  492.       r_z = XSTRS(NSTRS)*DJAC
  493.       DO 6179 J=1,LRN
  494.          JJ=LRB+J
  495.          XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J)
  496.  6179 CONTINUE
  497. *
  498.  5079 CONTINUE
  499.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  500.         INTERR(1)=IB
  501.         if (noer.eq.0) then
  502.          CALL ERREUR(195)
  503.          GOTO 9979
  504.         else
  505.          noer=195
  506.          return
  507.         endif
  508.       ENDIF
  509. C
  510. C     ON RANGE XFORC DANS MELVAL
  511. C     D'ABORD LES FORCES PUIS LES DEBITS
  512. C
  513.       IE=0
  514.       MPTVAL=IVAFOR
  515.       DO IGAU=1,NBNN
  516.        DO ICOMP=1,NFOR-1
  517.         IE=IE+1
  518.         MELVAL=IVAL(ICOMP)
  519.         VELCHE(IGAU,IB)=XFORC(IE)
  520.        ENDDO
  521.       ENDDO
  522. *
  523.       DO 7179 IGAU=1,NBSOM(IELE)
  524.         IE=IE+1
  525.         MELVAL=IVAL(NFOR)
  526.         IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  527.         VELCHE(IGAV,IB)=XFORC(IE)
  528.  7179 CONTINUE
  529. *
  530.  3079 CONTINUE
  531.  
  532.  9979 CONTINUE
  533.       SEGSUP MWRK1,MWRK5
  534.       GOTO 510
  535. C_______________________________________________________________________
  536. C__________________________________________________________________
  537. C
  538. C     MILIEUX POREUX - SUITE
  539. C_______________________________________________________________________
  540. C
  541.  173  CONTINUE
  542. C
  543. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  544. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  545. C
  546.       DIM3=1.D0
  547.       NBNO=IPORE
  548.       NBBB=NBNN
  549.       IF(MELE.GE.173.AND.MELE.LE.177) THEN
  550.         IDECAP = 2
  551.       ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  552.         IDECAP = 3
  553.       ENDIF
  554. *
  555.       NSTN=IDECAP
  556.       NSTB=4
  557.       IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  558.       LPP = NBNO-NBBB
  559.       LRN=IDECAP*LPP
  560.       LRB=LRE-LRN
  561.  
  562.       SEGINI MWRK1,MWRK5
  563. C
  564.       DO 3173  IB=1,NBELEM
  565. C
  566. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  567. C
  568.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  569. C
  570. C     MISE A 0 DES FORCES
  571. C
  572.       CALL ZERO(XFORC,1,LRE)
  573. C
  574. C     BOUCLE SUR LES POINTS DE GAUSS
  575. C
  576.       ISDJC=0
  577.       DO 5173  IGAU=1,NBPGAU
  578. C
  579. C   RECUPERATION DE L'EPAISSEUR
  580. C
  581.       IF (IFOUR.EQ.-2)THEN
  582.         MPTVAL=IVACAR
  583.         IF (IVACAR.NE.0) THEN
  584.          MELVAL=IVAL(1)
  585.          IF (MELVAL.NE.0) THEN
  586.           IGMN=MIN(IGAU,VELCHE(/1))
  587.           IBMN=MIN(IB,VELCHE(/2))
  588.           DIM3=VELCHE(IGMN,IBMN)
  589.         ELSE
  590.           DIM3=1.D0
  591.         ENDIF
  592.        ENDIF
  593.       ENDIF
  594. C
  595.       CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  596.      &     DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  597.       IF (DJAC.EQ.0.D0) THEN
  598.         INTERR(1)=IB
  599.         if (noer.eq.0) then
  600.          CALL ERREUR(259)
  601.          GOTO 99173
  602.         else
  603.          noer=259
  604.          return
  605.         endif
  606.       ENDIF
  607.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  608.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  609. C
  610. C     ON CHERCHE LES CONTRAINTES
  611. C
  612.       MPTVAL=IVASTR
  613.       DO 6173 ICOMP=1,NSTRS
  614.         MELVAL=IVAL(ICOMP)
  615.         IGMN=MIN(IGAU,VELCHE(/1))
  616.         IBMN=MIN(IB  ,VELCHE(/2))
  617.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  618.  6173 CONTINUE
  619. C
  620. C     CALCUL DE B*SIGMA
  621. C
  622.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  623. *
  624. *     ON AJOUTE LES TERMES EN FP
  625. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  626. *
  627.       DO 6273 IPR=1,IDECAP
  628.          IPR1=(IPR-1)*LPP
  629.          IPR2=NSTRS-IDECAP+IPR
  630.          r_z = XSTRS(IPR2) * DJAC
  631.          DO 6373 J=1,LPP
  632.            JJ=LRB+IPR1+J
  633.            XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J)
  634.  6373    CONTINUE
  635.  6273 CONTINUE
  636. *
  637.  5173 CONTINUE
  638.  
  639.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  640.         INTERR(1)=IB
  641.         if (noer.eq.0) then
  642.          CALL ERREUR(195)
  643.          GOTO 99173
  644.         else
  645.          noer=195
  646.          return
  647.         endif
  648.       ENDIF
  649. C
  650. C     ON RANGE XFORC DANS MELVAL
  651. C     D'ABORD LES FORCES PUIS LES DEBITS
  652. C
  653.       IE=0
  654.       MPTVAL=IVAFOR
  655.       DO IGAU=1,NBNN
  656.        DO ICOMP=1,NFOR-IDECAP
  657.         IE=IE+1
  658.         MELVAL=IVAL(ICOMP)
  659.         VELCHE(IGAU,IB)=XFORC(IE)
  660.        ENDDO
  661.       ENDDO
  662. *
  663.       DO 7273 IPR=1,IDECAP
  664.          IPR1=NFOR-IDECAP+IPR
  665.          DO 7373 IGAU=1,NBSOM(IELE)
  666.            IE=IE+1
  667.            MELVAL=IVAL(IPR1)
  668.            IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  669.            VELCHE(IGAV,IB)=XFORC(IE)
  670.  7373    CONTINUE
  671.  7273 CONTINUE
  672. *
  673.  3173 CONTINUE
  674. *
  675. 99173 CONTINUE
  676.       SEGSUP MWRK1,MWRK5
  677.       GOTO 510
  678. C__________________________________________________________________
  679. C_______________________________________________________________________
  680. C
  681. C     JOINTS EN FORMULATION MILIEUX POREUX
  682. C_______________________________________________________________________
  683. C
  684.   80  CONTINUE
  685. C
  686. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  687. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  688. C
  689.       NBNO=IPORE
  690.       NBBB=NBNN
  691.       LRN=(NBNO-NBBB)*3/2
  692.       LRB=LRE-LRN
  693.       NSTN=1
  694.       NFAC=(3*NBBB-NBNO)/2
  695.       NMIL=LRN-NBSOM(IELE)
  696.       SEGINI MWRK1,MWRK3,MWRK5
  697.       I195=0
  698.       I259=0
  699. C
  700.       DO 3080  IB=1,NBELEM
  701. C
  702. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  703. C
  704.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  705. C
  706. C     CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  707. C
  708.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  709. C
  710. C     MISE A 0 DES FORCES
  711. C
  712.       CALL ZERO(XFORC,1,LRE)
  713. C
  714. C     BOUCLE SUR LES POINTS DE GAUSS
  715. C
  716.       ISDJC=0
  717.       DO 5080  IGAU=1,NBPGAU
  718. C
  719.       CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  720.      .            SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  721.       IF (DJAC.EQ.0.) THEN
  722.         INTERR(1)=IB
  723.         if (noer.eq.0) then
  724.          CALL ERREUR(259)
  725.          GOTO 9980
  726.         else
  727.          noer=259
  728.          return
  729.         endif
  730.       ENDIF
  731.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  732.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  733. C
  734. C     ON CHERCHE LES CONTRAINTES
  735. C
  736.       MPTVAL=IVASTR
  737.       DO 6080 ICOMP=1,NSTRS
  738.         MELVAL=IVAL(ICOMP)
  739.         IGMN=MIN(IGAU,VELCHE(/1))
  740.         IBMN=MIN(IB  ,VELCHE(/2))
  741.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  742.  6080 CONTINUE
  743. C
  744. C     CALCUL DE B*SIGMA
  745. C
  746.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  747. *
  748. *     ON AJOUTE LES TERMES EN FP
  749. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  750. *
  751.       r_z = XSTRS(NSTRS)*DJAC
  752.       DO 6180 J=1,LRN
  753.          JJ=LRB+J
  754.          XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z
  755.  6180 CONTINUE
  756.  
  757.  5080 CONTINUE
  758.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  759.         INTERR(1)=IB
  760.         if (noer.eq.0) then
  761.          CALL ERREUR(195)
  762.          GOTO 9980
  763.         else
  764.          noer=195
  765.          return
  766.         endif
  767.       ENDIF
  768. C
  769. C     ON RANGE XFORC DANS MELVAL
  770. C     D'ABORD LES FORCES PUIS LES DEBITS
  771. C
  772.       MPTVAL=IVAFOR
  773. C
  774.       IE=0
  775.       DO IGAU=1,NFAC
  776.         DO ICOMP=1,NFOR-1
  777.           IE=IE+1
  778.           MELVAL=IVAL(ICOMP)
  779.           VELCHE(IGAU,IB)=XFORC(IE)
  780.         ENDDO
  781.       ENDDO
  782. *
  783. *     debits ( d'abord sommets puis mileux des cotes ad-hoc )
  784. *
  785.       MELVAL=IVAL(NFOR)
  786.       IGMN = NSPOS(IELE)-1
  787.       DO IGAU=1,NBSOM(IELE)
  788.          IE   = IE+1
  789.          IGAV = IBSOM(IGMN + IGAU)
  790. C*       VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  791.          VELCHE(IGAV,IB)=0.D0
  792.       ENDDO
  793. *
  794.       IGMN = NBBB - NMIL
  795.       DO IGAU=1,NMIL
  796.          IE=IE+1
  797.          IGAV  = IGMN + IGAU
  798.          VELCHE(IGAV,IB)=XFORC(IE)
  799.       ENDDO
  800. *
  801.  3080 CONTINUE
  802.  
  803.  9980 CONTINUE
  804.       SEGSUP MWRK1,MWRK3,MWRK5
  805.       GOTO 510
  806. C__________________________________________________________________
  807. C_______________________________________________________________________
  808. C
  809. C     JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  810. C_______________________________________________________________________
  811. C
  812.  185  CONTINUE
  813. C
  814. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  815. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  816. C
  817.       IF (MELE.GE.185.AND.MELE.LE.187) THEN
  818.         IDECAP = 2
  819.       ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  820.         IDECAP = 3
  821.       ENDIF
  822. C
  823.       NBNO=IPORE
  824.       NSTN=IDECAP
  825.       NSTB=2
  826.       IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  827. C
  828.       NBBB=NBNN
  829.       LPP=(NBNO-NBBB)*3/2
  830.       LRN=IDECAP*LPP
  831.       LRB=LRE-LRN
  832.       NFAC=(3*NBBB-NBNO)/2
  833.       NMIL=LPP-NBSOM(IELE)
  834.       SEGINI MWRK1,MWRK3,MWRK5
  835.       I195=0
  836.       I259=0
  837. C
  838.       DO 3185  IB=1,NBELEM
  839. C
  840. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  841. C
  842.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  843. C
  844. C     CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  845. C
  846.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  847. C
  848. C     MISE A 0 DES FORCES
  849. C
  850.       CALL ZERO(XFORC,1,LRE)
  851. C
  852. C     BOUCLE SUR LES POINTS DE GAUSS
  853. C
  854.       ISDJC=0
  855.       DO 5185  IGAU=1,NBPGAU
  856. C
  857.       CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  858.      .      SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  859.       IF (DJAC.EQ.0.) THEN
  860.         INTERR(1)=IB
  861.         if (noer.eq.0) then
  862.          CALL ERREUR(259)
  863.          GOTO 9985
  864.         else
  865.          noer=259
  866.          return
  867.         endif
  868.       ENDIF
  869.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  870.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  871. C
  872. C     ON CHERCHE LES CONTRAINTES
  873. C
  874.       MPTVAL=IVASTR
  875.       DO 6185 ICOMP=1,NSTRS
  876.         MELVAL=IVAL(ICOMP)
  877.         IGMN=MIN(IGAU,VELCHE(/1))
  878.         IBMN=MIN(IB  ,VELCHE(/2))
  879.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  880.  6185 CONTINUE
  881. C
  882. C     CALCUL DE B*SIGMA
  883. C
  884.       CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  885. *
  886. *     ON AJOUTE LES TERMES EN FP
  887. *     SIGNE - POUR ETRE COHERENT AVEC RIGI
  888. *
  889.       DO IPR=1,IDECAP
  890.         IPR1=(IPR-1)*LPP
  891.         IPR2=NSTRS-IDECAP+IPR
  892.         r_z = XSTRS(IPR2)*DJAC
  893.         DO J=1,LPP
  894.           JJ=LRB+IPR1+J
  895.           XFORC(JJ)=XFORC(JJ)-XGENE(IPR,IPR1+J)*r_z
  896.         ENDDO
  897.       ENDDO
  898.  
  899.  5185 CONTINUE
  900.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  901.         INTERR(1)=IB
  902.         if (noer.eq.0) then
  903.          CALL ERREUR(195)
  904.          GOTO 9985
  905.         else
  906.          noer=195
  907.          return
  908.         endif
  909.       ENDIF
  910. C
  911. C     ON RANGE XFORC DANS MELVAL
  912. C     D'ABORD LES FORCES PUIS LES DEBITS
  913. C
  914.       IE=0
  915.       MPTVAL=IVAFOR
  916.       JCOMP = NFOR-IDECAP
  917.       DO IGAU=1,NFAC
  918.         DO ICOMP=1,JCOMP
  919.           IE=IE+1
  920.           MELVAL=IVAL(ICOMP)
  921.           VELCHE(IGAU,IB)=XFORC(IE)
  922.         ENDDO
  923.       ENDDO
  924. *
  925. *     debits ( d'abord sommets puis mileux des cotes ad-hoc )
  926. *
  927.       DO 7485 IPR=1,IDECAP
  928.         IPR1 = NFOR-IDECAP+IPR
  929.         MELVAL=IVAL(IPR1)
  930.  
  931.         DO 7285 IGAU=1,NBSOM(IELE)
  932.           IE=IE+1
  933.           IGAV  = IBSOM(NSPOS(IELE)+IGAU-1)
  934. C*        VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  935.           VELCHE(IGAV,IB)=0.D0
  936.  7285   CONTINUE
  937. *
  938.         DO 7385 IGAU=1,NMIL
  939.           IE=IE+1
  940.           IGAV  = NBBB - NMIL +IGAU
  941.           VELCHE(IGAV,IB)=XFORC(IE)
  942.  7385   CONTINUE
  943.  7485 CONTINUE
  944. *
  945.  3185 CONTINUE
  946.  
  947.  9985 CONTINUE
  948.       SEGSUP MWRK1,MWRK3,MWRK5
  949.       GOTO 510
  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. c      RETURN
  959.       END
  960.  
  961.  
  962.  
  963.  

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