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

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