Télécharger la plaquette Cast3M


fr en

Télécharger bsigm2.eso

Retour à la liste

Numérotation des lignes : 

bsigm2

  1. C BSIGM2    SOURCE    CB215821  24/04/12    21:15:07     11897          
  2.       SUBROUTINE BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,
  3.      &   NBPTEL,MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,
  4.      &   NPINT,NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG)
  5. *----------------------------------------------------------------------
  6. *        _______________________________                              *
  7. *        |                              |                             *
  8. *        |  CALCUL DES FORCES AUX NOEUDS|                             *
  9. *        |______________________________|                             *
  10. *                                                                     *
  11. *      coq3,dkt,coq4,coq8,coq2 ,dst, jot3, joi4, joi2, joi3           *
  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. *        IVASTR   pointeur sur un segment MPTVAL contenant les        *
  22. *                 les melvals de contraints                           *
  23. *        LW       Dimension du tableau de travail de l'element        *
  24. *        NBPGAU   Nombre de points d'integration pour les contraintes *
  25. *        IVACAR   Pointeur sur les chamelems de caracteristiques      *
  26. *        NBPTEL   Nombre de points par element                        *
  27. *        MELE     Numero de l'element fini                            *
  28. *        MFR      Numero de la formulation
  29. *        IPMINT   Pointeur sur un segment MINTE             ACTIF E/S *
  30. *        IPMIN1   Pointeur sur un segment MINTE (aux noeuds)          *
  31. *        NPINT    Nombre de points d'integration dans l'epaisseur
  32. *                 dans le cas des elements de coque integres
  33. *                                                                     *
  34. *   SORTIES :                                                         *
  35. *   ________                                                          *
  36. *                                                                     *
  37. *        IVAFOR   pointeur sur un segment MPTVAL contenant les        *
  38. *                 les melvals de forces                               *
  39. *                                                                     *
  40. *        ICHPO1   pointeur sur le petit chpoint cree à l'usage de     *
  41. *                 la deformation plane generalisee                    *
  42. *---------------------------------------------------------------------*
  43.       IMPLICIT INTEGER(I-N)
  44.       IMPLICIT REAL*8(A-H,O-Z)
  45. *
  46. *
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC CCHAMP
  51.  
  52. -INC SMCHAML
  53. -INC SMCHPOI
  54. -INC SMELEME
  55. -INC SMCOORD
  56. -INC SMMODEL
  57. -INC SMINTE
  58. -INC SMLREEL
  59. C
  60.       SEGMENT WRK1
  61.        REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB)
  62.        REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
  63.       ENDSEGMENT
  64. *
  65.       SEGMENT WRK2
  66.        REAL*8 SHPWRK(6,NBNO), BGENE(NSTRS,LRE)
  67.       ENDSEGMENT
  68. *
  69.       SEGMENT WRK3
  70.        REAL*8 WORK(LW)
  71.       ENDSEGMENT
  72. *
  73.       SEGMENT WRK4
  74.        REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  75.       ENDSEGMENT
  76. *
  77.       SEGMENT WRK5
  78.        REAL*8   BGENE1(3,LRE)
  79.       ENDSEGMENT
  80. *
  81.       SEGMENT MPTVAL
  82.         INTEGER IPOS(NS)    ,NSOF(NS)
  83.         INTEGER      IVAL(NCOSOU)
  84.         CHARACTER*16 TYVAL(NCOSOU)
  85.       ENDSEGMENT
  86. *
  87.       SEGMENT,MVELCH
  88.          REAL*8 VALMAT(NV1)
  89.       ENDSEGMENT
  90.       CHARACTER*8 CMATE
  91. *  pour l'appel a rcdst
  92.       dimension rel(36,36)
  93. *
  94.       MELEME=IPMAIL
  95. C*    SEGACT MELEME
  96.       NBNN=NUM(/1)
  97.       NBELEM=NUM(/2)
  98. *
  99. *   INITIALISATION DES COORDONNES DU POINT AUTOUR DUQUEL SE FAIT
  100. *   LE MOUVEMENT EN DEFORMATION PLANE GENERALISEE
  101. *    ET INITIALISATION DES FORCES AU NOEUD SUPPORT DE LA DEFO
  102. *    PLANE GENERALISEE
  103. CCC   IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN
  104.       IF (IIPDPG.GT.0) THEN
  105. c*        SEGACT MCOORD
  106.         IREF = (IIPDPG-1)*(IDIM+1)
  107.         XDPGE=XCOOR(IREF+1)
  108.         YDPGE=XCOOR(IREF+2)
  109.       ELSE
  110.         XDPGE=0.D0
  111.         YDPGE=0.D0
  112.       ENDIF
  113.       ADPG=0.D0
  114.       BDPG=0.D0
  115.       CDPG=0.D0
  116. *
  117.       NHRM=NIFOUR
  118. *
  119.       MINTE=IPMINT
  120.       IF(MELE.EQ.93)THEN
  121.         NV1=NMATT
  122.         SEGINI MVELCH
  123.       ENDIF
  124. C_______________________________________________________________________
  125. C
  126. C     NUMERO DES ETIQUETTES      :
  127. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  128. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  129. C     5  CONTINUE
  130. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  131. C     44 CONTINUE
  132. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  133. C_______________________________________________________________________
  134. C
  135.       GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  136.      1      99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
  137.      2      41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99,
  138.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  139.      4      99,99,99,99,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE
  140.  
  141.       GOTO(168,169,170,171,172),MELE-167
  142.       IF(MELE.EQ.258) GOTO 258
  143.       GOTO 99
  144.  
  145. C_______________________________________________________________________
  146. C
  147. C     ELEMENT COQ3
  148. C_______________________________________________________________________
  149. C
  150.   27  CONTINUE
  151.       NBBB=NBNN
  152.       LW=151
  153.       SEGINI WRK1,WRK3
  154. C
  155.       DO 3027  IB=1,NBELEM
  156. C
  157. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  158. C
  159.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  160. C
  161. C     MISE A ZERO DES FORCES INTERNES
  162. C
  163.       CALL ZERO(XFORC,1,LRE)
  164. C
  165. C     ON CHERCHE LES CONTRAINTES
  166. C
  167.       MPTVAL=IVASTR
  168.       DO 7027 ICOMP=1,NSTRS
  169.         MELVAL=IVAL(ICOMP)
  170.         IBMN=MIN(IB  ,VELCHE(/2))
  171.         XSTRS(ICOMP)=VELCHE(1,IBMN)
  172.  7027 CONTINUE
  173. C
  174. C     ON CALCULE B*EFFORTS
  175. C
  176.       CALL BSIGCO(XE,XSTRS,XFORC,WORK,WORK,WORK(82),WORK(88),
  177.      * WORK(92),WORK(119),WORK(128),WORK(134),WORK(143),WORK(143),
  178.      * WORK(146),WORK(149))
  179. C
  180. C    RANGEMENT DANS MELVAL
  181. C
  182.       IE=0
  183.       MPTVAL=IVAFOR
  184.       DO 9027 IGAU=1,NBNN
  185.       DO 9027 ICOMP=1,6
  186.         IE=IE+1
  187.         MELVAL=IVAL(ICOMP)
  188.         IBMN=MIN(IB  ,VELCHE(/2))
  189.         VELCHE(IGAU,IBMN)=XFORC(IE)
  190.  9027 CONTINUE
  191. C
  192.  3027 CONTINUE
  193.       SEGSUP WRK1,WRK3
  194.       GOTO 510
  195. C_______________________________________________________________________
  196. C
  197. C     ELEMENT DKT
  198. C_______________________________________________________________________
  199. C
  200.   28  CONTINUE
  201.       NBNO=NBNN
  202.       NBBB=NBNN
  203.       IF(NPINT.NE.0)THEN
  204.          SEGINI WRK1,WRK3,WRK4,WRK5
  205.          NSTRS=6
  206.          SEGINI WRK2
  207.          NSTRS=4
  208.       ELSE
  209.         SEGINI WRK1,WRK2,WRK3,WRK4
  210.       ENDIF
  211. C
  212.       DO 3028  IB=1,NBELEM
  213. C
  214. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  215. C
  216.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  217. C
  218. C
  219. C     MISE A ZERO DES FORCES INTERNES
  220. C
  221.       CALL ZERO(XFORC,1,LRE)
  222. C
  223.       CALL VPAST(XE,BPSS)
  224. C     BPSS    STOCKE LA MATRICOMPE DE PASSAGE
  225.       CALL VCORLC (XE,XEL,BPSS)
  226.       CALL TRPOSE(BPSS)
  227. C
  228. C     ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  229. C                LES EXCENTREMENTS ET ON LES MOYENNE.
  230. C
  231.       MPTVAL=IVACAR
  232. C
  233.       EPAIST=0.D0
  234.       MELVAL=IVAL(1)
  235.       IF (MELVAL.NE.0) THEN
  236.         DO IGAU=1,NBPGAU
  237.           IGMN=MIN(IGAU,VELCHE(/1))
  238.           IBMN=MIN(IB,VELCHE(/2))
  239.           EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  240.         ENDDO
  241.         EPAIST=EPAIST/NBPGAU
  242.       ENDIF
  243. *
  244.       EXCEN=0.D0
  245.       MELVAL=IVAL(2)
  246.       IF (MELVAL.NE.0) THEN
  247.         DO IGAU=1,NBPGAU
  248.           IGMN=MIN(IGAU,VELCHE(/1))
  249.           IBMN=MIN(IB,VELCHE(/2))
  250.           EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  251.         ENDDO
  252.         EXCEN=EXCEN/NBPGAU
  253.       ENDIF
  254. C
  255.       IF(NPINT.EQ.0)THEN
  256. C
  257. C     COQUE GLOBAL
  258. C
  259. C     BOUCLE SUR LES POINTS DE GAUSS
  260. C
  261.       DO 6028  IGAU=1,NBPGAU
  262. *
  263.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  264.      &            MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL,
  265.      &           SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  266.       DJAC=DJAC*POIGAU(IGAU)
  267. *
  268. *  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  269. *
  270.       IF (EXCEN.NE.0.) THEN
  271.       DO 1528 IJL=1,3
  272.       DO 1528 IJC=1,LRE
  273.         BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  274.  1528 CONTINUE
  275.       ENDIF
  276. C
  277. C     ON CHERCHE LES CONTRAINTES
  278. C
  279.       MPTVAL=IVASTR
  280.       DO 7028 ICOMP=1,NSTRS
  281.         MELVAL=IVAL(ICOMP)
  282.         IGMN=MIN(IGAU,VELCHE(/1))
  283.         IBMN=MIN(IB  ,VELCHE(/2))
  284.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  285.  7028 CONTINUE
  286. C
  287. C     ON CALCULE B*EFFORTS
  288. C
  289.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  290.  6028 CONTINUE
  291. C
  292.       ELSE
  293. C
  294. C    COQUE INTEGREE
  295. C
  296.       NBPGA1=NBPGAU/NPINT
  297. C
  298. C     BOUCLE SUR LES POINTS DE GAUSS DE LA SURFACE
  299. C
  300.       DO 6001  IGAU=1,NBPGA1
  301. *
  302.       CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  303.      &            MELE,MFR,NBNO,LRE,IFOUR,6,0,1.D0,XEL,SHPTOT,
  304.      &                     SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  305. *
  306. *  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  307. *
  308.       IF (EXCEN.NE.0.) THEN
  309.       DO 1501 IJL=1,3
  310.       DO 1501 IJC=1,LRE
  311.         BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  312.  1501 CONTINUE
  313.       ENDIF
  314. C
  315. C   BOUCLE SUR LES NAPPES
  316. C
  317.       DO 6002 INAP=1,NPINT
  318.       IGAU1=(INAP-1)*NBPGA1+IGAU
  319. C
  320. C     ON CHERCHE LES CONTRAINTES
  321. C
  322.       MPTVAL=IVASTR
  323.       DO 7001 ICOMP=1,NSTRS
  324.         MELVAL=IVAL(ICOMP)
  325.         IGMN=MIN(IGAU1,VELCHE(/1))
  326.         IBMN=MIN(IB  ,VELCHE(/2))
  327.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  328.  7001 CONTINUE
  329.        XSTRS(3)=XSTRS(4)
  330. C
  331. C      CALCUL DE LA MATRICE B CORRESPONDANT AUX CONTRAINTES 3D
  332. C
  333.       ZZZ=DZEGAU(IGAU1)*(EPAIST/2.D0)
  334.       DO 1502 IJL=1,3
  335.       DO 1502 IJC=1,LRE
  336.         BGENE1(IJL,IJC)=BGENE(IJL,IJC)+ZZZ*BGENE(IJL+3,IJC)
  337.  1502 CONTINUE
  338.        DJAC1=DJAC*POIGAU(IGAU1)*(EPAIST/2.D0)
  339. C
  340. C     ON CALCULE B*EFFORTS
  341. C
  342.       CALL BSIG(BGENE1,XSTRS,3,LRE,DJAC1,XFORC)
  343.  6002 CONTINUE
  344.  6001 CONTINUE
  345.       ENDIF
  346. C
  347. C     TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  348. C
  349.       CALL MATVEC(XFORC,XFOLO,BPSS,6)
  350.       IE=0
  351.       MPTVAL=IVAFOR
  352.       DO 9028 IGAU=1,NBNN
  353.       DO 9028 ICOMP=1,6
  354.         IE=IE+1
  355.         MELVAL=IVAL(ICOMP)
  356.         IBMN=MIN(IB  ,VELCHE(/2))
  357.         VELCHE(IGAU,IBMN)=XFOLO(IE)
  358.  9028 CONTINUE
  359.  3028 CONTINUE
  360.       SEGSUP WRK1,WRK2,WRK3,WRK4
  361.       IF(NPINT.NE.0)SEGSUP WRK5
  362.       GOTO 510
  363.  
  364. C_______________________________________________________________________
  365. C
  366. C    ELEMENTS COQ6 ET COQ8
  367. C_______________________________________________________________________
  368. C
  369.   41  CONTINUE
  370.       NBBB=NBNN
  371.       SEGINI WRK1,WRK3
  372.       MINTE1=IPMIN1
  373.       SEGACT MINTE1
  374.       NBPGA1=MINTE1.SHPTOT(/3)
  375.       NBN1  =MINTE1.SHPTOT(/2)
  376. C
  377. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  378. C
  379.       DO 3041  IB=1,NBELEM
  380. C
  381. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  382. C
  383.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  384. C
  385. C     MISE A ZERO DES FORCES INTERNES
  386. C
  387.       CALL ZERO(XFORC,1,LRE)
  388.  
  389. C     ON CHERCHE LES EPAISSEURS ET LES EXCENTREMENTS,
  390. C     ON LES MOYENNE SUR L'ELEMENT.
  391. C
  392.       MPTVAL=IVACAR
  393.       EPAIST=0.D0
  394.       MELVAL=IVAL(1)
  395.       IF (MELVAL.NE.0) THEN
  396.       DO IGAU=1,NBPTEL
  397.           IGMN=MIN(IGAU,VELCHE(/1))
  398.           IBMN=MIN(IB  ,VELCHE(/2))
  399.           EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  400.       ENDDO
  401.       EPAIST=EPAIST/NBPTEL
  402.       ENDIF
  403.       EXCEN=0.D0
  404.       MELVAL=IVAL(2)
  405.       IF (MELVAL.NE.0) THEN
  406.       DO IGAU=1,NBPTEL
  407.           IGMN=MIN(IGAU,VELCHE(/1))
  408.           IBMN=MIN(IB  ,VELCHE(/2))
  409.           EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  410.       ENDDO
  411.       EXCEN=EXCEN/NBPTEL
  412.       ENDIF
  413.       CALL ZERO(XFORC,1,LRE)
  414. C
  415. C     ON CHERCHE LES CONTRAINTES
  416. C
  417.       IE=1
  418.       MPTVAL=IVASTR
  419.       DO 7041 IGAU=1,NBPGAU
  420.       DO 7041 ICOMP=1,NSTRS
  421.         MELVAL=IVAL(ICOMP)
  422.         IGMN=MIN(IGAU,VELCHE(/1))
  423.         IBMN=MIN(IB  ,VELCHE(/2))
  424.         WORK(IE)=VELCHE(IGMN,IBMN)
  425.         IE=IE+1
  426.  7041 CONTINUE
  427. C
  428. C     ON CALCULE B*SIGMA
  429. C
  430.       CALL CQ8BSE(XE,NBNN,NBPGAU,LRE,EPAIST,EXCEN,DZEGAU,
  431.      *   POIGAU,SHPTOT,MINTE1.SHPTOT,WORK(1),XFORC,IRRT)
  432.  
  433.       IF(IRRT.EQ.0) THEN
  434.         INTERR(1)=IB
  435.         CALL ERREUR(241)
  436.         GOTO 9941
  437.       ELSE IF(IRRT.EQ.-1) THEN
  438.         INTERR(1)=IB
  439.         CALL ERREUR(240)
  440.         GOTO 9941
  441.       ENDIF
  442. C
  443. C    RANGEMENT DANS MELVAL
  444. C
  445.       IE=0
  446.       MPTVAL=IVAFOR
  447.       DO 9041 IGAU=1,NBNN
  448.       DO 9041 ICOMP=1,6
  449.         IE=IE+1
  450.         MELVAL=IVAL(ICOMP)
  451.         IBMN=MIN(IB  ,VELCHE(/2))
  452.         VELCHE(IGAU,IBMN)=XFORC(IE)
  453.  9041 CONTINUE
  454.  3041 CONTINUE
  455.  
  456.  9941 CONTINUE
  457.       SEGSUP WRK1,WRK3
  458.       SEGDES MINTE1
  459.       GOTO 510
  460.  
  461. C_______________________________________________________________________
  462. C
  463. C  ELEMENT COQ2
  464. C_______________________________________________________________________
  465. C
  466.    44 CONTINUE
  467.       DIM3=1.D0
  468.       NBNO=NBNN
  469.       NBBB=NBNN
  470.       SEGINI WRK1,WRK2
  471. C
  472.       DO 3044 IB=1,NBELEM
  473. C
  474. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  475. C
  476.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  477. C
  478. C  MISE A ZERO DES FORCES INTERNES
  479. C
  480.       CALL ZERO(XFORC,1,LRE)
  481. C
  482. C  BOUCLE SUR LES POINTS DE GAUSS
  483. C
  484.       DO 6044 IGAU=1,NBPGAU
  485.         MPTVAL=IVACAR
  486.         MELVAL=IVAL(2)
  487.         IF (MELVAL.NE.0) THEN
  488.           IBMN=MIN(IB  ,VELCHE(/2))
  489.           EXCEN=VELCHE(1,IBMN)
  490.         ELSE
  491.           EXCEN=0.D0
  492.         ENDIF
  493.         IF(IFOUR.EQ.-2) THEN
  494.          MELVAL=IVAL(3)
  495.          IF (MELVAL.NE.0) THEN
  496.           IGMN=MIN(IGAU  ,VELCHE(/1))
  497.           IBMN=MIN(IB  ,VELCHE(/2))
  498.           DIM3=VELCHE(IGMN,IBMN)
  499.          ELSE
  500.           DIM3=1.D0
  501.          ENDIF
  502.         ENDIF
  503. *
  504.       CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  505.      .           EXCEN,DIM3,IRRT,XDPGE,YDPGE)
  506.       IF (IRRT.EQ.1) THEN
  507.          INTERR(1)=IB
  508.          CALL ERREUR(255)
  509.          GOTO 9944
  510.       ELSE IF(IRRT.EQ.2) THEN
  511.          INTERR(1)=IB
  512.          CALL ERREUR(256)
  513.          GOTO 9944
  514.       ENDIF
  515. C
  516. C  ON CHERCHE LES CONTRAINTES -
  517. C
  518.       MPTVAL=IVASTR
  519.       DO 7044 ICOMP=1,NSTRS
  520.         MELVAL=IVAL(ICOMP)
  521.         IGMN=MIN(IGAU,VELCHE(/1))
  522.         IBMN=MIN(IB  ,VELCHE(/2))
  523.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  524.  7044 CONTINUE
  525. C
  526. C  ON CALCULE B*EFFORTS
  527. C
  528.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  529.  6044 CONTINUE
  530. C
  531. C   EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  532. C   ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  533. C PPJ IF (IFOUR.EQ.-3) THEN
  534. ccc   IF (IFOUR.EQ.-3.AND.MFR.NE.35) THEN
  535.       IF (IIPDPG.GT.0) THEN
  536.         ADPG=ADPG+XFORC(NBNN*3+1)
  537.         BDPG=BDPG+XFORC(NBNN*3+2)
  538.         CDPG=CDPG+XFORC(NBNN*3+3)
  539.       ENDIF
  540. C
  541. C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  542. C
  543.       MPTVAL=IVAFOR
  544.       IF(IFOUR.GT.0) THEN
  545.         DO 9044 IGAU=1,2
  546.           IE=(IGAU-1)*4
  547. C
  548.           MELVAL=IVAL(1)
  549.           IGMN=MIN(IGAU,VELCHE(/1))
  550.           IBMN=MIN(IB  ,VELCHE(/2))
  551.           VELCHE(IGMN,IBMN)=  XFORC(IE+1)
  552. C
  553.           MELVAL=IVAL(2)
  554.           IGMN=MIN(IGAU,VELCHE(/1))
  555.           IBMN=MIN(IB  ,VELCHE(/2))
  556.           VELCHE(IGMN,IBMN)=  XFORC(IE+2)
  557. C
  558.           MELVAL=IVAL(3)
  559.           IGMN=MIN(IGAU,VELCHE(/1))
  560.           IBMN=MIN(IB  ,VELCHE(/2))
  561.           VELCHE(IGMN,IBMN)=  XFORC(IE+3)
  562. C
  563.           MELVAL=IVAL(4)
  564.           IGMN=MIN(IGAU,VELCHE(/1))
  565.           IBMN=MIN(IB  ,VELCHE(/2))
  566.           VELCHE(IGMN,IBMN)=  XFORC(IE+4)
  567.  9044   CONTINUE
  568.       ELSE IF(IFOUR.LE.0) THEN
  569.         DO 9144 IGAU=1,2
  570.           IE=(IGAU-1)*3
  571. C
  572.           MELVAL=IVAL(1)
  573.           IGMN=MIN(IGAU,VELCHE(/1))
  574.           IBMN=MIN(IB  ,VELCHE(/2))
  575.           VELCHE(IGMN,IBMN)=  XFORC(IE+1)
  576. C
  577.           MELVAL=IVAL(2)
  578.           IGMN=MIN(IGAU,VELCHE(/1))
  579.           IBMN=MIN(IB  ,VELCHE(/2))
  580.           VELCHE(IGMN,IBMN)=  XFORC(IE+2)
  581. C
  582.           MELVAL=IVAL(3)
  583.           IGMN=MIN(IGAU,VELCHE(/1))
  584.           IBMN=MIN(IB  ,VELCHE(/2))
  585.           VELCHE(IGMN,IBMN)=  XFORC(IE+3)
  586.  9144   CONTINUE
  587.       ENDIF
  588.  3044 CONTINUE
  589. C
  590.  9944 CONTINUE
  591.       SEGSUP WRK1,WRK2
  592.       GOTO 510
  593.  
  594. C_______________________________________________________________________
  595. C
  596. C  ELEMENT COQ4
  597. C_______________________________________________________________________
  598. C
  599.    49 CONTINUE
  600.       NBNO=NBNN
  601.       NBBB=NBNN
  602.       SEGINI WRK1,WRK2,WRK4
  603. C
  604.       DO 3049 IB=1,NBELEM
  605. C
  606. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  607. C
  608.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  609. C
  610. C  MISE A ZERO DES FORCES INTERNES
  611. C
  612.       CALL ZERO(XFORC,1,LRE)
  613. C
  614. C     RIFERIMENTO LOCALE
  615. C
  616.       CALL CQ4LOC(XE,XEL,BPSS,IERT,1)
  617.       IF (IERT .EQ. 3) THEN
  618.          NOPLAN = 1
  619.       ELSE
  620.          NOPLAN = 0
  621.       END IF
  622.       CALL TRPOSE(BPSS)
  623.         MPTVAL=IVACAR
  624.         MELVAL=IVAL(2)
  625.         IF (MELVAL.NE.0) THEN
  626.           IBMN=MIN(IB  ,VELCHE(/2))
  627.           EXCEN=VELCHE(1,IBMN)
  628.         ELSE
  629.           EXCEN=0.D0
  630.         ENDIF
  631. C
  632. C  BOUCLE SUR LES POINTS DE GAUSS
  633. C
  634.       DO 6049 IGAU=1,NBPGAU
  635.       if(cmate.eq.'ISOTROPE') then
  636.       CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,0)
  637.       else
  638.       CALL BCOQ4O(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,0)
  639.       endif
  640.       IF (IERT.NE.0) THEN
  641.         INTERR(1)=IB
  642.         CALL ERREUR (321)
  643.         GOTO 9949
  644.       ENDIF
  645. C
  646. C  ON CHERCHE LES CONTRAINTES -
  647. C
  648.       MPTVAL=IVASTR
  649.       DO 7049 ICOMP=1,NSTRS
  650.         MELVAL=IVAL(ICOMP)
  651.         IGMN=MIN(IGAU,VELCHE(/1))
  652.         IBMN=MIN(IB  ,VELCHE(/2))
  653.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  654.  7049 CONTINUE
  655. C
  656. C  ON CALCULE B*EFFORTS
  657. C
  658.       DJAC=DJAC*POIGAU(IGAU)
  659.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  660.  6049 CONTINUE
  661. C
  662. C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  663. C
  664.       CALL MATVEC(XFORC,XFOLO,BPSS,8)
  665.  
  666.       MPTVAL=IVAFOR
  667.       IE=0
  668.       DO 9049 NODE=1,4
  669.       DO 9049 ICOMP=1,6
  670.         IE=IE+1
  671.         MELVAL=IVAL(ICOMP)
  672.         IBMN=MIN(IB  ,VELCHE(/2))
  673.         VELCHE(NODE,IBMN)=XFOLO(IE)
  674.  9049 CONTINUE
  675.  3049 CONTINUE
  676.  
  677.  9949 CONTINUE
  678.       SEGSUP WRK1,WRK2,WRK4
  679.       GOTO 510
  680. C_______________________________________________________________________
  681. C
  682. C  ELEMENT JOINT JOI2
  683. C_______________________________________________________________________
  684. C
  685.    85 CONTINUE
  686.       NBNO=NBNN
  687.       NBBB=NBNN
  688.       SEGINI WRK1,WRK2,WRK4
  689. C
  690.       DO 3085 IB=1,NBELEM
  691. C
  692. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  693. C
  694.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  695. C
  696. C  MISE A ZERO DES FORCES INTERNES
  697. C
  698.       CALL ZERO(XFORC,1,LRE)
  699. C
  700. C     REPERE LOCAL
  701. C
  702.       CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  703. C
  704. C  BOUCLE SUR LES POINTS DE GAUSS
  705. C
  706.       DO 6085 IGAU=1,NBPGAU
  707.        CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  708.      .                                  BGENE,DJAC,IERT)
  709.        IF (IERT.NE.0) THEN
  710.          INTERR(1)=IB
  711.          CALL ERREUR (162)
  712.          GOTO 9985
  713.        ENDIF
  714. C
  715. C      EN AXISYMETRIE, MULTIPLICATION PAR LE RAYON DE COURBURE
  716. C      (LE RAYON DE COURBURE DOIT ETRE CALCULE AVEC LES COORDONNEES
  717. C      GLOCALES CAR ON FAIT UNE INTEGRATION SUR LA CIRCONFERENCE DE LA
  718. C      STRUCTURE CYLINDRIQUE DANS LE REPERE GLOBAL).
  719. C
  720.        IF (IFOUR.EQ.0) THEN
  721.         NUMSUP=NBNO/2
  722.         RAYON=0.D0
  723.         DO 6285 IRAY=1,NUMSUP
  724.          RAYON=RAYON+SHPTOT(1,IRAY,IGAU)*XE(1,IRAY)
  725.  6285   CONTINUE
  726.         DJAC=DJAC*RAYON
  727.        ENDIF
  728. C
  729. C  ON CHERCHE LES CONTRAINTES -
  730. C
  731.       MPTVAL=IVASTR
  732.       DO 7085 ICOMP=1,NSTRS
  733.         MELVAL=IVAL(ICOMP)
  734.         IGMN=MIN(IGAU,VELCHE(/1))
  735.         IBMN=MIN(IB  ,VELCHE(/2))
  736.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  737.  7085 CONTINUE
  738. C
  739. C  ON CALCULE B*EFFORTS
  740. C
  741.       DJAC=DJAC*POIGAU(IGAU)
  742.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  743.  6085 CONTINUE
  744. C
  745. C   RANGEMENT DANS MELVAL
  746. C
  747.       IE=0
  748.       MPTVAL=IVAFOR
  749. C
  750. C         NODE=4= NOMBRE DE NOEUDS
  751. C         ICOMP=2= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  752. C
  753.       DO 9085 NODE=1,4
  754.       DO 9085 ICOMP=1,2
  755.         IE=IE+1
  756.         MELVAL=IVAL(ICOMP)
  757.         IBMN=MIN(IB  ,VELCHE(/2))
  758.         VELCHE(NODE,IBMN)=XFORC(IE)
  759.  9085 CONTINUE
  760.  3085 CONTINUE
  761.  
  762.  9985 CONTINUE
  763.       SEGSUP WRK1,WRK2,WRK4
  764.       GOTO 510
  765.  
  766. C_______________________________________________________________________
  767. C
  768. C  ELEMENT JOINT JGI2
  769. C_______________________________________________________________________
  770. C
  771.   170 CONTINUE
  772.       NBNO=NBNN
  773.       NBBB=NBNN
  774.       SEGINI WRK1,WRK2,WRK4
  775. C
  776.       DO IB=1,NBELEM
  777. C
  778. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  779. C
  780.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  781. C
  782. C  MISE A ZERO DES FORCES INTERNES
  783. C
  784.          CALL ZERO(XFORC,1,LRE)
  785. C
  786. C     REPERE LOCAL
  787. C
  788.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  789. C
  790. C  BOUCLE SUR LES POINTS DE GAUSS
  791. C
  792.          DO IGAU=1,NBPGAU
  793. C
  794. C        ON CHERCHE L EPAISSEUR DU JOINT
  795. C
  796.             EPAIST=0.D0
  797.             MPTVAL=IVACAR
  798.             MELVAL=IVAL(1)
  799.             IF (MELVAL.NE.0) THEN
  800.               IGMN=MIN(IGAU,VELCHE(/1))
  801.               IBMN=MIN(IB,VELCHE(/2))
  802.               EPAIST=VELCHE(IGMN,IBMN)
  803.             ENDIF
  804. C
  805. CcPPj       CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  806. CcPPj.                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IERT)
  807.             CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  808.      .                 EPAIST,BGENE,DJAC,XDPGE,YDPGE,IERT)
  809.             IF (IERT.NE.0) THEN
  810.               INTERR(1)=IB
  811.               CALL ERREUR (612)
  812.               GOTO 99170
  813.             ENDIF
  814. C????????????????
  815. C      EN AXISYMETRIE, MULTIPLICATION PAR LE RAYON DE COURBURE
  816. C      (LE RAYON DE COURBURE DOIT ETRE CALCULE AVEC LES COORDONNEES
  817. C      GLOCALES CAR ON FAIT UNE INTEGRATION SUR LA CIRCONFERENCE DE LA
  818. C      STRUCTURE CYLINDRIQUE DANS LE REPERE GLOBAL).
  819. C????????????????
  820.             IF (IFOUR.EQ.0) THEN
  821.               NUMSUP=NBNO/2
  822.               RAYON=0.D0
  823.               DO IRAY=1,NUMSUP
  824.                 RAYON=RAYON+SHPTOT(1,IRAY,IGAU)*XE(1,IRAY)
  825.               ENDDO
  826.               DJAC=DJAC*RAYON
  827.             ENDIF
  828. C
  829. C  ON CHERCHE LES CONTRAINTES -
  830. C
  831.             MPTVAL=IVASTR
  832.             DO ICOMP=1,NSTRS
  833.               MELVAL=IVAL(ICOMP)
  834.               IGMN=MIN(IGAU,VELCHE(/1))
  835.               IBMN=MIN(IB  ,VELCHE(/2))
  836.               XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  837.             ENDDO
  838. C
  839. C  ON CALCULE B*EFFORTS
  840. C
  841.            DJAC=DJAC*POIGAU(IGAU)
  842.            CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  843.          ENDDO
  844. C
  845. C   EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  846. C   ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  847. C
  848.          NFOFO=NFORC
  849.          IF (IFOUR.EQ.-3) THEN
  850.            NFOFO=NFORC-3
  851.            ADPG=ADPG+XFORC(NBNN*NFOFO+1)
  852.            BDPG=BDPG+XFORC(NBNN*NFOFO+2)
  853.            CDPG=CDPG+XFORC(NBNN*NFOFO+3)
  854.          ENDIF
  855. C
  856. C   RANGEMENT DANS MELVAL
  857. C
  858.          IE=0
  859.          MPTVAL=IVAFOR
  860. C
  861. C         NODE=4= NOMBRE DE NOEUDS
  862. C         ICOMP=2= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  863. C
  864.          DO NODE=1,NBNN
  865.            DO ICOMP=1,NFOFO
  866.              IE=IE+1
  867.              MELVAL=IVAL(ICOMP)
  868.              IBMN=MIN(IB  ,VELCHE(/2))
  869.              VELCHE(NODE,IBMN)=XFORC(IE)
  870.            ENDDO
  871.          ENDDO
  872.       ENDDO
  873.  
  874. 99170 CONTINUE
  875.       SEGSUP WRK1,WRK2,WRK4
  876.       GOTO 510
  877. C+PPj
  878. C_______________________________________________________________________
  879. C
  880. C  ELEMENT JOINT JCT3 en 2D cisaillement
  881. C_______________________________________________________________________
  882. C
  883.   168 CONTINUE
  884.       NBNO=NBNN
  885.       NBBB=NBNN
  886.       SEGINI WRK1,WRK2,WRK4
  887. C
  888.       DO IB=1,NBELEM
  889. C
  890. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  891. C
  892.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  893. C
  894. C  MISE A ZERO DES FORCES INTERNES
  895. C
  896.         CALL ZERO(XFORC,1,LRE)
  897. C
  898. C     REPERE LOCAL
  899. C
  900.         CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  901. C
  902. C  BOUCLE SUR LES POINTS DE GAUSS
  903. C
  904.         DO IGAU=1,NBPGAU
  905.           CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  906.      .                                         BGENE,DJAC,IERT)
  907.           IF (IERT.NE.0) THEN
  908.             INTERR(1)=IB
  909.             CALL ERREUR (611)
  910.             GOTO 99168
  911.           ENDIF
  912. C
  913. C  ON CHERCHE LES CONTRAINTES -
  914. C
  915.           MPTVAL=IVASTR
  916.           DO ICOMP=1,NSTRS
  917.             MELVAL=IVAL(ICOMP)
  918.             IGMN=MIN(IGAU,VELCHE(/1))
  919.             IBMN=MIN(IB  ,VELCHE(/2))
  920.             XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  921.           ENDDO
  922. C
  923. C  ON CALCULE B*EFFORTS
  924. C
  925.           DJAC=DJAC*POIGAU(IGAU)
  926.           CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  927.         ENDDO
  928. C
  929. C  RANGEMENT DANS MELVAL
  930. C
  931.         IE=0
  932.         MPTVAL=IVAFOR
  933. C
  934.         DO NODE=1,NBNN
  935.           DO ICOMP=1,NFORC
  936.             IE=IE+1
  937.             MELVAL=IVAL(ICOMP)
  938.             IBMN=MIN(IB  ,VELCHE(/2))
  939.             VELCHE(NODE,IBMN)=XFORC(IE)
  940.           ENDDO
  941.         ENDDO
  942.       ENDDO
  943.  
  944. 99168 CONTINUE
  945.       SEGSUP WRK1,WRK2,WRK4
  946.       GOTO 510
  947. C_______________________________________________________________________
  948. C
  949. C  ELEMENT JOINT JGT3 GENERALISE
  950. C_______________________________________________________________________
  951. C
  952.   171 CONTINUE
  953.       NBNO=NBNN
  954.       NBBB=NBNN
  955.       SEGINI WRK1,WRK2,WRK4
  956. C
  957.       DO IB=1,NBELEM
  958. C
  959. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  960. C
  961.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  962. C
  963. C  MISE A ZERO DES FORCES INTERNES
  964. C
  965.         CALL ZERO(XFORC,1,LRE)
  966. C
  967. C     REPERE LOCAL
  968. C
  969.         CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  970. C
  971. C  BOUCLE SUR LES POINTS DE GAUSS
  972. C
  973.         DO IGAU=1,NBPGAU
  974. C
  975. C  ON CHERCHE L'EPAISSEUR DU JOINT
  976. C
  977.           EPAIST=0.D0
  978.           MPTVAL=IVACAR
  979.           MELVAL=IVAL(1)
  980.           IF (MELVAL.NE.0) THEN
  981.             IGMN=MIN(IGAU,VELCHE(/1))
  982.             IBMN=MIN(IB,VELCHE(/2))
  983.             EPAIST=VELCHE(IGMN,IBMN)
  984.           ENDIF
  985. C
  986. C  ON CALCULE B
  987. C
  988. CcPPj     CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  989.           CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  990.      .                                 EPAIST,BGENE,DJAC,IERT)
  991.           IF (IERT.NE.0) THEN
  992.             INTERR(1)=IB
  993.             CALL ERREUR (611)
  994.             GOTO 99171
  995.           ENDIF
  996. C
  997. C  ON CHERCHE LES CONTRAINTES -
  998. C
  999.           MPTVAL=IVASTR
  1000.           DO ICOMP=1,NSTRS
  1001.             MELVAL=IVAL(ICOMP)
  1002.             IGMN=MIN(IGAU,VELCHE(/1))
  1003.             IBMN=MIN(IB  ,VELCHE(/2))
  1004.             XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1005.           ENDDO
  1006. C
  1007. C  ON CALCULE B*EFFORTS
  1008. C
  1009.           DJAC=DJAC*POIGAU(IGAU)
  1010.           CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1011.         ENDDO
  1012. C
  1013. C  RANGEMENT DANS MELVAL
  1014. C
  1015.         IE=0
  1016.         MPTVAL=IVAFOR
  1017. C
  1018.         DO NODE=1,NBNN
  1019.           DO ICOMP=1,NFORC
  1020.             IE=IE+1
  1021.             MELVAL=IVAL(ICOMP)
  1022.             IBMN=MIN(IB  ,VELCHE(/2))
  1023.             VELCHE(NODE,IBMN)=XFORC(IE)
  1024.           ENDDO
  1025.         ENDDO
  1026.       ENDDO
  1027.  
  1028. 99171 CONTINUE
  1029.       SEGSUP WRK1,WRK2,WRK4
  1030.       GOTO 510
  1031. C+PPj
  1032. C_______________________________________________________________________
  1033. C
  1034. C  ELEMENT JOINT JCI4 en 2D cisaillement
  1035. C_______________________________________________________________________
  1036. C
  1037.   169 CONTINUE
  1038.       NBNO=NBNN
  1039.       NBBB=NBNN
  1040.       SEGINI WRK1,WRK2,WRK4
  1041. C
  1042.       DO IB=1,NBELEM
  1043. C
  1044. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1045. C
  1046.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1047. C
  1048. C
  1049. C  MISE A ZERO DES FORCES INTERNES
  1050. C
  1051.         CALL ZERO(XFORC,1,LRE)
  1052. C
  1053. C     REPERE LOCAL
  1054. C
  1055.         CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1056. C
  1057. C  BOUCLE SUR LES POINTS DE GAUSS
  1058. C
  1059.         DO IGAU=1,NBPGAU
  1060.           CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  1061.           IF (IERT.NE.0) THEN
  1062.             INTERR(1)=IB
  1063.             CALL ERREUR (611)
  1064.             GOTO 99169
  1065.           ENDIF
  1066. C
  1067. C  ON CHERCHE LES CONTRAINTES -
  1068. C
  1069.           MPTVAL=IVASTR
  1070.           DO ICOMP=1,NSTRS
  1071.             MELVAL=IVAL(ICOMP)
  1072.             IGMN=MIN(IGAU,VELCHE(/1))
  1073.             IBMN=MIN(IB  ,VELCHE(/2))
  1074.             XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1075.           ENDDO
  1076. C
  1077. C  ON CALCULE B*EFFORTS
  1078. C
  1079.           DJAC=DJAC*POIGAU(IGAU)
  1080.           CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1081.         ENDDO
  1082. C
  1083. C  RANGEMENT DANS MELVAL
  1084. C
  1085.         IE=0
  1086.         MPTVAL=IVAFOR
  1087. C
  1088. C         NODE=8= NOMBRE DE NOEUDS
  1089. C         ICOMP=3= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  1090. C
  1091.         DO NODE=1,NBNN
  1092.           DO ICOMP=1,NFORC
  1093.             IE=IE+1
  1094.             MELVAL=IVAL(ICOMP)
  1095.             IBMN=MIN(IB  ,VELCHE(/2))
  1096.             VELCHE(NODE,IBMN)=XFORC(IE)
  1097.           ENDDO
  1098.         ENDDO
  1099.       ENDDO
  1100.  
  1101. 99169 CONTINUE
  1102.       SEGSUP WRK1,WRK2,WRK4
  1103.       GOTO 510
  1104. C_______________________________________________________________________
  1105. C
  1106. C  ELEMENT JOINT JGI4 GENERALISE
  1107. C_______________________________________________________________________
  1108. C
  1109.   172 CONTINUE
  1110.       NBNO=NBNN
  1111.       NBBB=NBNN
  1112.       SEGINI WRK1,WRK2,WRK4
  1113. C
  1114.       DO IB=1,NBELEM
  1115. C
  1116. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1117. C
  1118.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1119. C
  1120. C  MISE A ZERO DES FORCES INTERNES
  1121. C
  1122.         CALL ZERO(XFORC,1,LRE)
  1123. C
  1124. C     REPERE LOCAL
  1125. C
  1126.         CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1127. C
  1128. C  BOUCLE SUR LES POINTS DE GAUSS
  1129. C
  1130.         DO IGAU=1,NBPGAU
  1131. C
  1132. C  ON CHERCHE L'EPAISSEUR DU JOINT
  1133. C
  1134.           EPAIST=0.D0
  1135.           MPTVAL=IVACAR
  1136.           MELVAL=IVAL(1)
  1137.           IF (MELVAL.NE.0) THEN
  1138.             IGMN=MIN(IGAU,VELCHE(/1))
  1139.             IBMN=MIN(IB,VELCHE(/2))
  1140.             EPAIST=VELCHE(IGMN,IBMN)
  1141.           ENDIF
  1142. C
  1143. C  ON CALCULE B
  1144. C
  1145. CcPPj     CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IERT)
  1146.           CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,
  1147.      .                                                           IERT)
  1148.           IF (IERT.NE.0) THEN
  1149.             INTERR(1)=IB
  1150.             CALL ERREUR (611)
  1151.             GOTO 99172
  1152.           ENDIF
  1153. C
  1154. C  ON CHERCHE LES CONTRAINTES -
  1155. C
  1156.           MPTVAL=IVASTR
  1157.           DO ICOMP=1,NSTRS
  1158.             MELVAL=IVAL(ICOMP)
  1159.             IGMN=MIN(IGAU,VELCHE(/1))
  1160.             IBMN=MIN(IB  ,VELCHE(/2))
  1161.             XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1162.           ENDDO
  1163. C
  1164. C  ON CALCULE B*EFFORTS
  1165. C
  1166.           DJAC=DJAC*POIGAU(IGAU)
  1167.           CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1168.         ENDDO
  1169. C
  1170. C  RANGEMENT DANS MELVAL
  1171. C
  1172.         IE=0
  1173.         MPTVAL=IVAFOR
  1174. C
  1175. C         NODE=8= NOMBRE DE NOEUDS
  1176. C         ICOMP=3= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  1177. C
  1178.         DO NODE=1,NBNN
  1179.           DO ICOMP=1,NFORC
  1180.             IE=IE+1
  1181.             MELVAL=IVAL(ICOMP)
  1182.             IBMN=MIN(IB  ,VELCHE(/2))
  1183.             VELCHE(NODE,IBMN)=XFORC(IE)
  1184.           ENDDO
  1185.         ENDDO
  1186.       ENDDO
  1187.  
  1188. 99172 CONTINUE
  1189.       SEGSUP WRK1,WRK2,WRK4
  1190.       GOTO 510
  1191. C+PPj
  1192.  
  1193. C_______________________________________________________________________
  1194. C
  1195. C     ELEMENT JOINT (JOI3) IMPLEMENTATION SANS TEST DE PLANEITE
  1196. C                                         ET SANS REPERE LOCAL
  1197. C_______________________________________________________________________
  1198. C
  1199.    86 CONTINUE
  1200.       NBNO=NBNN
  1201.       NBBB=NBNN
  1202.       SEGINI WRK1,WRK2,WRK4
  1203. C
  1204.       DO 3086 IB=1,NBELEM
  1205. C
  1206. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1207. C
  1208.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1209. C
  1210. C  MISE A ZERO DES FORCES INTERNES
  1211. C
  1212.       CALL ZERO(XFORC,1,LRE)
  1213. C
  1214. C  BOUCLE SUR LES POINTS DE GAUSS
  1215. C
  1216.       DO 6086 IGAU=1,NBPGAU
  1217. C
  1218.        CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS)
  1219. C
  1220.        CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  1221.      .                                 BGENE,DJAC,IERT)
  1222.        IF (IERT.NE.0) THEN
  1223.          INTERR(1)=IB
  1224.          CALL ERREUR (612)
  1225.          GOTO 9986
  1226.        ENDIF
  1227. C
  1228. C      EN AXISYMETRIE, MULTIPLICATION PAR LE RAYON DE COURBURE
  1229. C      (LE RAYON DE COURBURE DOIT ETRE CALCULE AVEC LES COORDONNEES
  1230. C      GLOCALES CAR ON FAIT UNE INTEGRATION SUR LA CIRCONFERENCE DE LA
  1231. C      STRUCTURE CYLINDRIQUE DANS LE REPERE GLOBAL).
  1232. C
  1233.        IF (IFOUR.EQ.0) THEN
  1234.         NUMSUP=NBNO/2
  1235.         RAYON=0.D0
  1236.         DO 6286 IRAY=1,NUMSUP
  1237.          RAYON=RAYON+SHPTOT(1,IRAY,IGAU)*XE(1,IRAY)
  1238.  6286   CONTINUE
  1239.         DJAC=DJAC*RAYON
  1240.        ENDIF
  1241. C
  1242. C  ON CHERCHE LES CONTRAINTES -
  1243. C
  1244.       MPTVAL=IVASTR
  1245.       DO 7086 ICOMP=1,NSTRS
  1246.         MELVAL=IVAL(ICOMP)
  1247.         IGMN=MIN(IGAU,VELCHE(/1))
  1248.         IBMN=MIN(IB  ,VELCHE(/2))
  1249.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1250.  7086 CONTINUE
  1251. C
  1252. C  ON CALCULE B*EFFORTS
  1253. C
  1254.       DJAC=DJAC*POIGAU(IGAU)
  1255.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1256.  6086 CONTINUE
  1257. C
  1258. C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1259. C
  1260.       IE=0
  1261.       MPTVAL=IVAFOR
  1262. C
  1263. C         NODE=6= NOMBRE DE NOEUDS
  1264. C         ICOMP=2= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  1265. C
  1266.       DO 9086 NODE=1,6
  1267.       DO 9086 ICOMP=1,2
  1268.         IE=IE+1
  1269.         MELVAL=IVAL(ICOMP)
  1270.         IBMN=MIN(IB  ,VELCHE(/2))
  1271.         VELCHE(NODE,IBMN)=XFORC(IE)
  1272.  9086 CONTINUE
  1273.  3086 CONTINUE
  1274.  
  1275.  9986 CONTINUE
  1276.       SEGSUP WRK1,WRK2,WRK4
  1277.       GOTO 510
  1278.  
  1279. C_______________________________________________________________________
  1280. C
  1281. C  ELEMENT JOINT JOT3
  1282. C_______________________________________________________________________
  1283. C
  1284.    87 CONTINUE
  1285.       NBNO=NBNN
  1286.       NBBB=NBNN
  1287.       SEGINI WRK1,WRK2,WRK4
  1288. C
  1289.       DO 3087 IB=1,NBELEM
  1290. C
  1291. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1292. C
  1293.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1294. C
  1295. C  MISE A ZERO DES FORCES INTERNES
  1296. C
  1297.       CALL ZERO(XFORC,1,LRE)
  1298. C
  1299. C     REPERE LOCAL
  1300. C
  1301.       CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1302. C
  1303. C  BOUCLE SUR LES POINTS DE GAUSS
  1304. C
  1305.       DO 6087 IGAU=1,NBPGAU
  1306.       CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1307.      .                                       BGENE,DJAC,IERT)
  1308.       IF (IERT.NE.0) THEN
  1309.         INTERR(1)=IB
  1310.         CALL ERREUR (611)
  1311.         GOTO 9987
  1312.       ENDIF
  1313. C
  1314. C  ON CHERCHE LES CONTRAINTES -
  1315. C
  1316.       MPTVAL=IVASTR
  1317.       DO 7087 ICOMP=1,NSTRS
  1318.         MELVAL=IVAL(ICOMP)
  1319.         IGMN=MIN(IGAU,VELCHE(/1))
  1320.         IBMN=MIN(IB  ,VELCHE(/2))
  1321.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1322.  7087 CONTINUE
  1323. C
  1324. C  ON CALCULE B*EFFORTS
  1325. C
  1326.       DJAC=DJAC*POIGAU(IGAU)
  1327.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1328.  6087 CONTINUE
  1329. C
  1330. C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1331. C
  1332. C     EXPRESSION DE XFORC DANS LE REPERE GLOBAL
  1333. C
  1334. C     TRANSPOSEE DE BPSS = INVERSE DE BPSS ( MATRICE ORTHOGONALE )
  1335. C     DONC : TRPOSE(BPSS) = MATRICE DE PASSAGE DU REPERE LOCAL
  1336. C                           AU REPERE GLOBAL
  1337. C
  1338. CCCCC      CALL TRPOSE(BPSS)
  1339. CCCCC      CALL MATVEC(XFORC,XFOLO,BPSS,8)
  1340.       IE=0
  1341.       MPTVAL=IVAFOR
  1342. C
  1343. C         NODE=6= NOMBRE DE NOEUDS
  1344. C         ICOMP=3= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  1345. C
  1346.       DO 9087 NODE=1,6
  1347.       DO 9087 ICOMP=1,3
  1348.         IE=IE+1
  1349.         MELVAL=IVAL(ICOMP)
  1350.         IBMN=MIN(IB  ,VELCHE(/2))
  1351.         VELCHE(NODE,IBMN)=XFORC(IE)
  1352.  9087 CONTINUE
  1353.  3087 CONTINUE
  1354.  
  1355.  9987 CONTINUE
  1356.       SEGSUP WRK1,WRK2,WRK4
  1357.       GOTO 510
  1358. C_______________________________________________________________________
  1359. C
  1360. C  ELEMENT JOINT JOI4
  1361. C_______________________________________________________________________
  1362. C
  1363.    88 CONTINUE
  1364.       NBNO=NBNN
  1365.       NBBB=NBNN
  1366.       SEGINI WRK1,WRK2,WRK4
  1367. C
  1368.       DO 3088 IB=1,NBELEM
  1369. C
  1370. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1371. C
  1372.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1373. C
  1374. C  MISE A ZERO DES FORCES INTERNES
  1375. C
  1376.       CALL ZERO(XFORC,1,LRE)
  1377. C
  1378. C     REPERE LOCAL
  1379. C
  1380.       CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1381. C
  1382. C  BOUCLE SUR LES POINTS DE GAUSS
  1383. C
  1384.       DO 6088 IGAU=1,NBPGAU
  1385.       CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  1386.       IF (IERT.NE.0) THEN
  1387.         INTERR(1)=IB
  1388.         CALL ERREUR (611)
  1389.         GOTO 9988
  1390.       ENDIF
  1391. C
  1392. C  ON CHERCHE LES CONTRAINTES -
  1393. C
  1394.       MPTVAL=IVASTR
  1395.       DO 7088 ICOMP=1,NSTRS
  1396.         MELVAL=IVAL(ICOMP)
  1397.         IGMN=MIN(IGAU,VELCHE(/1))
  1398.         IBMN=MIN(IB  ,VELCHE(/2))
  1399.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1400.  7088 CONTINUE
  1401. C
  1402. C  ON CALCULE B*EFFORTS
  1403. C
  1404.       DJAC=DJAC*POIGAU(IGAU)
  1405.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1406.  6088 CONTINUE
  1407. C
  1408. C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1409. C
  1410. C     EXPRESSION DE XFORC DANS LE REPERE GLOBAL
  1411. C
  1412. C     TRANSPOSEE DE BPSS = INVERSE DE BPSS ( MATRICE ORTHOGONALE )
  1413. C     DONC : TRPOSE(BPSS) = MATRICE DE PASSAGE DU REPERE LOCAL
  1414. C                           AU REPERE GLOBAL
  1415. C
  1416. CCCCC      CALL TRPOSE(BPSS)
  1417. CCCCC      CALL MATVEC(XFORC,XFOLO,BPSS,8)
  1418.       IE=0
  1419.       MPTVAL=IVAFOR
  1420. C
  1421. C         NODE=8= NOMBRE DE NOEUDS
  1422. C         ICOMP=3= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  1423. C
  1424.       DO 9088 NODE=1,8
  1425.       DO 9088 ICOMP=1,3
  1426.         IE=IE+1
  1427.         MELVAL=IVAL(ICOMP)
  1428.         IBMN=MIN(IB  ,VELCHE(/2))
  1429.         VELCHE(NODE,IBMN)=XFORC(IE)
  1430.  9088 CONTINUE
  1431.  3088 CONTINUE
  1432.  
  1433.  9988 CONTINUE
  1434.       SEGSUP WRK1,WRK2,WRK4
  1435.       GOTO 510
  1436. C_______________________________________________________________________
  1437. C
  1438. C     ELEMENT DST
  1439. C_______________________________________________________________________
  1440. C
  1441.   93  CONTINUE
  1442.       LHOOK=NSTRS
  1443.       NBNO=NBNN
  1444.       NBBB=NBNN
  1445.       SEGINI WRK1,WRK2,WRK3,WRK4
  1446.       IF(CMATE.NE.'ISOTROPE')THEN
  1447.          MPTVAL=IVAMAT
  1448.          IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN
  1449.             MELVAL=IVAL(7)
  1450.          ELSE
  1451.             MELVAL=IVAL(2)
  1452.          ENDIF
  1453.          NBGCOS=VELCHE(/1)
  1454.       ENDIF
  1455. C
  1456.       DO 3093  IB=1,NBELEM
  1457. C
  1458. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1459. C
  1460.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1461. C
  1462. C     MISE A ZERO DES FORCES INTERNES
  1463. C
  1464.       CALL ZERO(XFORC,1,LRE)
  1465. C
  1466.       CALL VPAST(XE,BPSS)
  1467. C     BPSS    STOCKE LA MATRICOMPE DE PASSAGE
  1468.       CALL VCORLC (XE,XEL,BPSS)
  1469.       CALL TRPOSE(BPSS)
  1470. C     ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  1471. C                LES EXCENTREMENTS ET ON LES MOYENNE.
  1472. C
  1473.         MPTVAL=IVACAR
  1474. C
  1475.         EPAIST=0.D0
  1476.         MELVAL=IVAL(1)
  1477.         IF (MELVAL.NE.0) THEN
  1478.         DO IGAU=1,NBPGAU
  1479.            IGMN=MIN(IGAU,VELCHE(/1))
  1480.            IBMN=MIN(IB,VELCHE(/2))
  1481.            EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  1482.         ENDDO
  1483.         EPAIST=EPAIST/NBPGAU
  1484.         ENDIF
  1485. *
  1486.         EXCEN=0.D0
  1487.         MELVAL=IVAL(2)
  1488.         IF (MELVAL.NE.0) THEN
  1489.         DO IGAU=1,NBPGAU
  1490.            IGMN=MIN(IGAU,VELCHE(/1))
  1491.            IBMN=MIN(IB,VELCHE(/2))
  1492.            EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  1493.         ENDDO
  1494.         EXCEN=EXCEN/NBPGAU
  1495.         ENDIF
  1496. C
  1497. C     BOUCLE SUR LES POINTS DE GAUSS
  1498. C
  1499.       DO 6093  IGAU=1,NBPGAU
  1500. *
  1501.       IF(CMATE.NE.'ISOTROPE')THEN
  1502.         IF(IGAU.LE.NBGCOS)THEN
  1503.           IF(IMAT.EQ.2)THEN
  1504.             MPTVAL=IVAMAT
  1505.             MELVAL=IVAL(2)
  1506.             IBMN=MIN(IB  ,VELCHE(/2))
  1507.             IGMN=MIN(IGAU,VELCHE(/1))
  1508.             COSA=VELCHE(IGMN,IBMN)
  1509.             MELVAL=IVAL(3)
  1510.             IBMN=MIN(IB  ,VELCHE(/2))
  1511.             IGMN=MIN(IGAU,VELCHE(/1))
  1512.             SINA=VELCHE(IGMN,IBMN)
  1513.           ENDIF
  1514.         ENDIF
  1515.       ENDIF
  1516. C
  1517. C     ON CHERCHE LA MATRICE DE HOOKE
  1518. C
  1519.       MPTVAL=IVAMAT
  1520.       IF(IMAT.EQ.2) THEN
  1521.           MELVAL=IVAL(1)
  1522.           IBMN=MIN(IB  ,IELCHE(/2))
  1523.           IGMN=MIN(IGAU,IELCHE(/1))
  1524.           MLREEL=IELCHE(IGMN,IBMN)
  1525.           IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.
  1526.      +                    OR.NBGMAT.GT.1)) THEN
  1527.           SEGACT MLREEL
  1528.             CALL DOHOOO(PROG,LHOOK,DDHOMU)
  1529.           SEGDES MLREEL
  1530.             IF(CMATE.EQ.'ORTHOTRO')
  1531.      +           CALL CHGREP1(COSA,SINA,DDHOMU,LHOOK)
  1532.           ENDIF
  1533.       ELSE IF (IMAT.EQ.1) THEN
  1534.           DO 9193 IM=1,NMATT
  1535.             IF (IVAL(IM).NE.0) THEN
  1536.               MELVAL=IVAL(IM)
  1537.               IBMN=MIN(IB  ,VELCHE(/2))
  1538.               IGMN=MIN(IGAU,VELCHE(/1))
  1539.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  1540.             ELSE
  1541.               VALMAT(IM)=0.D0
  1542.             ENDIF
  1543.  9193     CONTINUE
  1544.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1545.      1     CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD)
  1546.         CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  1547.       ENDIF
  1548.       CALL ZERO(BGENE,NSTRS,LRE)
  1549.       IF(CMATE.NE.'ISOTROPE')THEN
  1550.         IF(IGAU.LE.NBGCOS)THEN
  1551.           IF(IMAT.EQ.1)THEN
  1552.             COSA=VALMAT(7)
  1553.             SINA=VALMAT(8)
  1554.           ENDIF
  1555.           DO 1393 INO=1,NBNN
  1556.            XX=COSA*XEL(1,INO)+SINA*XEL(2,INO)
  1557.            YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO)
  1558.            XE(1,INO)=XX
  1559.            XE(2,INO)=YY
  1560.  1393     CONTINUE
  1561.          ENDIF
  1562. C
  1563. C     TERMES DE LA MATRICE DE RIGIDITE RELATIFS
  1564. C      AUX CISAILLEMENTS TRANSVERSES
  1565. C
  1566.         CALL RCDST(XE,NSTRS,LRE,DDHOMU,
  1567.      1                WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1568. C
  1569. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1570. C        DE MEMBRANE ET DE FLEXION
  1571. C
  1572.          CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1573.      1            WORK(1),WORK(10),WORK(19),BGENE,DUM)
  1574. *
  1575.          CALL ROTB(BGENE,NSTRS,COSA,SINA)
  1576. *
  1577.          DO 10 NPOI=1,3
  1578.          SHPWRK(1,NPOI)=SHPTOT(1,NPOI,IGAU)
  1579.          SHPWRK(2,NPOI)=SHPTOT(2,NPOI,IGAU)
  1580.          SHPWRK(3,NPOI)=SHPTOT(3,NPOI,IGAU)
  1581.   10     CONTINUE
  1582.          CALL JACOBI(XEL,SHPWRK,2,3,DJAC)
  1583.       ELSE
  1584. C
  1585. C     TERMES DE LA MATRICE B RELATIFS AUX CISAILLEMENTS TRANSVERSES
  1586. C
  1587.          CALL RCDST(XEL,NSTRS,LRE,DDHOMU,
  1588.      1              WORK(1),WORK(10),WORK(19),REL,BGENE,1)
  1589. C
  1590. C     TERMES DE LA MATRICE B RELATIFS AUX EFFETS
  1591. C        DE MEMBRANE ET DE FLEXION
  1592. C
  1593.         CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1594.      1            WORK(1),WORK(10),WORK(19),BGENE,DJAC)
  1595.       ENDIF
  1596.       DJAC=DJAC*POIGAU(IGAU)
  1597. *
  1598. *  ON MODIFIE LA MATRICE B EN CAS D'EXCENTREMENT
  1599. *
  1600.       DO 1593 IJL=1,3
  1601.       DO 1593 IJC=1,LRE
  1602.         BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC)
  1603.  1593 CONTINUE
  1604. C
  1605. C     ON CHERCHE LES CONTRAINTES
  1606. C
  1607.       MPTVAL=IVASTR
  1608.       DO 7093 ICOMP=1,NSTRS
  1609.         MELVAL=IVAL(ICOMP)
  1610.         IGMN=MIN(IGAU,VELCHE(/1))
  1611.         IBMN=MIN(IB  ,VELCHE(/2))
  1612.         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1613.  7093 CONTINUE
  1614. *
  1615. *      TRANSFORMATION DES CONTRAINTES DU REPERE LOCAL AU REPERE
  1616. *      D'ORTHOTROPIE
  1617. *
  1618.       IF(CMATE.EQ.'ORTHOTRO')
  1619.      1      CALL CHGREP2(COSA,SINA,XSTRS,1,1)
  1620. C
  1621. C     ON CALCULE B*EFFORTS
  1622. C
  1623.       CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1624.  6093 CONTINUE
  1625. C
  1626. C     TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1627. C
  1628.       CALL MATVEC(XFORC,XFOLO,BPSS,6)
  1629.       IE=0
  1630.       MPTVAL=IVAFOR
  1631.       DO 9093 IGAU=1,NBNN
  1632.       DO 9093 ICOMP=1,6
  1633.         IE=IE+1
  1634.         MELVAL=IVAL(ICOMP)
  1635.         IBMN=MIN(IB  ,VELCHE(/2))
  1636.         VELCHE(IGAU,IBMN)=XFOLO(IE)
  1637.  9093 CONTINUE
  1638.  3093 CONTINUE
  1639.  
  1640.  9993 CONTINUE
  1641.       SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH
  1642.       GOTO 510
  1643.  
  1644. C_______________________________________________________________________
  1645. C
  1646. C  ELEMENTS  CIFL   MACRO ELEMENT CISAILLEMENT FLEXION
  1647. C_______________________________________________________________________
  1648. C
  1649.  258  CONTINUE
  1650.       NBNO=NBNN
  1651.       NBBB=NBNN
  1652.       SEGINI WRK1,WRK2,WRK4
  1653. C
  1654.       DO IB=1,NBELEM
  1655. C
  1656. C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1657. C
  1658.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1659. C
  1660. C  MISE A ZERO DES FORCES INTERNES
  1661. C
  1662.          CALL ZERO(XFORC,1,LRE)
  1663. C
  1664. C     PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  1665. C
  1666.          CALL MURLOC(XE,NBNN,NSTRS,LRE,BPSS,XH,BGENE)
  1667. C
  1668. C  ON CHERCHE LES CONTRAINTES -
  1669. C
  1670.          MPTVAL=IVASTR
  1671.          DO ICOMP=1,NSTRS
  1672.            MELVAL=IVAL(ICOMP)
  1673.            IBMN=MIN(IB  ,VELCHE(/2))
  1674.            XSTRS(ICOMP)=VELCHE(1,IBMN)
  1675.          ENDDO
  1676. C
  1677. C  ON CALCULE B*EFFORTS
  1678. C
  1679.          CALL BSIG(BGENE,XSTRS,NSTRS,LRE,1.D0,XFORC)
  1680. C
  1681. C   RANGEMENT DANS MELVAL
  1682. C
  1683.          IE=0
  1684.          MPTVAL=IVAFOR
  1685. C
  1686. C     ON RANGE LES FORCES (FX1,FY1,MZ1,FX2,FY2,MZ2,FM,MM)
  1687. C
  1688.          MELVAL=IVAL(1)
  1689.          VELCHE(1,IB)=XFORC(1)
  1690.          VELCHE(3,IB)=XFORC(4)
  1691.          MELVAL=IVAL(2)
  1692.          VELCHE(1,IB)=XFORC(2)
  1693.          VELCHE(3,IB)=XFORC(5)
  1694.          MELVAL=IVAL(3)
  1695.          VELCHE(1,IB)=XFORC(3)
  1696.          VELCHE(3,IB)=XFORC(6)
  1697.          MELVAL=IVAL(4)
  1698.          VELCHE(2,IB)=XFORC(7)
  1699.          MELVAL=IVAL(5)
  1700.          VELCHE(2,IB)=XFORC(8)
  1701.       ENDDO
  1702.       SEGSUP WRK1,WRK2,WRK4
  1703.       GOTO 510
  1704. C_______________________________________________________________________
  1705. *
  1706.    99 CONTINUE
  1707.       MOTERR(1:4)=NOMTP(MELE)
  1708.       MOTERR(5:12)='BSIGM2'
  1709.       CALL ERREUR(86)
  1710. *
  1711.   510 CONTINUE
  1712.       RETURN
  1713.       END
  1714.  
  1715.  
  1716.  
  1717.  
  1718.  
  1719.  
  1720.  
  1721.  
  1722.  

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