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

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