Télécharger la plaquette Cast3M


fr en

Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes : 

rigi2

  1. C RIGI2     SOURCE    SP204843  25/07/03    21:15:07     12308          
  2.       SUBROUTINE RIGI2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3.      &  IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
  4.      &  IPORE,NDDL,IPMATR,IIPDPG,NCAR1,MELPHA,NOER)
  5. *---------------------------------------------------------------------*
  6. *        __________________________                                   *
  7. *        |                        |                                   *
  8. *        |  CALCUL DE LA RIGIDITE |                                   *
  9. *        |________________________|                                   *
  10. *                                                                     *
  11. *        massif, liquide, 'surface libre', poreux et joints poreux,   *
  12. *        incompressible                                               *
  13. *                                                                     *
  14. *---------------------------------------------------------------------*
  15. *                                                                     *
  16. *   ENTREES :                                                         *
  17. *   ________                                                          *
  18. *                                                                     *
  19. *        MATE     Numero du materiau                                  *
  20. *        MELE     Numero de l'element fini                            *
  21. *        IPMAIL   Pointeur sur un segment  MELEME                     *
  22. *        IPMINT   Pointeur sur un segment MINTE                       *
  23. *        NBPGAU   Nombre de point d'integration pour la rigidite      *
  24. *        LRE      Nombre de ddl dans la matrice de rigidite           *
  25. *        NSTRS    Nombre de composante de contraintes/deformations    *
  26. *        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  27. *                 pour une matrice de hooke                           *
  28. *        IVACAR   Pointeur sur un segment MPTVAL de caractéristiques  *
  29. *        CMATE    Nom du materiau                                     *
  30. *        MFR      Numero de la formulation element fini               *
  31. *        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  32. *        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  33. *        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  34. *        NMATT    Nombre de composante de materiau (IMAT=1)           *
  35. *        LHOOK    Dimension de la matrice de Hooke                    *
  36. *        IPORE    Nombre de fonctions de forme                        *
  37. *        NDDL     Nombre de degre de liberte                          *
  38. *                                                                     *
  39. *   SORTIES :                                                         *
  40. *   ________                                                          *
  41. *                                                                     *
  42. *        IPMATR   pointeur sur la rigidite de la sous-zone            *
  43. *                                                                     *
  44. *---------------------------------------------------------------------*
  45.       IMPLICIT INTEGER(I-N)
  46.       IMPLICIT REAL*8(A-H,O-Z)
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC CCHAMP
  51. -INC CCREEL
  52.  
  53. -INC SMCHAML
  54. -INC SMINTE
  55. -INC SMELEME
  56. -INC SMRIGID
  57. -INC SMCOORD
  58. -INC SMLREEL
  59.  
  60. -INC TMPTVAL
  61.  
  62.       SEGMENT WRK1
  63.        REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
  64.        REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
  65.       ENDSEGMENT
  66. *
  67.       SEGMENT WRK2
  68.        REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  69.       ENDSEGMENT
  70. *
  71.       SEGMENT WRK3
  72.        REAL*8 BPSS(3,3),XEL(3,NBBB)
  73.        REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP)
  74.       ENDSEGMENT
  75. *
  76.       SEGMENT WRK5
  77.        REAL*8 XGENE(NSTN,LRN)
  78.       ENDSEGMENT
  79. *
  80.       SEGMENT WRK55
  81.        REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK)
  82.       ENDSEGMENT
  83. *
  84.       SEGMENT WRK555
  85.        REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN)
  86.       ENDSEGMENT
  87. *
  88.       SEGMENT WRK8
  89.        REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  90.        REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  91.        ENDSEGMENT
  92. *
  93.       SEGMENT,MVELCH
  94.          REAL*8 VALMAT(NV1)
  95.       ENDSEGMENT
  96. *
  97.       segment mwrk67
  98.          real*8 valcar(nca1), xatef1(3,3)
  99.       endsegment
  100.  
  101.       DIMENSION A(4,60),BB(3,60),PP(4,4)
  102.       CHARACTER*8 CMATE,celem
  103.       logical drend,BDPGE
  104. *
  105. *       WRITE (*,*) 'Entrée dans RIGI2.'
  106.       MELEME=IPMAIL
  107.       NBNN=NUM(/1)
  108.       NBELEM=NUM(/2)
  109. *
  110.       NV1=NMATT
  111.       SEGINI,MVELCH
  112. *
  113.       XMATRI=IPMATR
  114. c*      NLIGRD=LRE
  115. c*      NLIGRP=LRE
  116.  
  117. C  Introduction du point autour duquel se fait le mouvement
  118. C  de la section en defo plane generalisee
  119. C  IIPDPG = numero du noeud/point support si defini pour le modele
  120.       IF (IIPDPG.GT.0) THEN
  121.         IF (IFOUR.EQ.-3) THEN
  122.           BDPGE=.TRUE.
  123.           IREF=(IIPDPG-1)*(IDIM+1)
  124.           XDPGE=XCOOR(IREF+1)
  125.           YDPGE=XCOOR(IREF+2)
  126.         ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  127.      &           IFOUR.EQ.10 .OR. IFOUR.EQ.11 .OR. IFOUR.EQ.14) THEN
  128.           BDPGE=.TRUE.
  129.           XDPGE=XZero
  130.           YDPGE=XZero
  131.         else
  132.           write(ioimp,*) 'RIGI2 : ERREUR DPGE'
  133.           call erreur(5)
  134.           return
  135.         ENDIF
  136.       ELSE
  137.         BDPGE=.FALSE.
  138.         XDPGE=XZero
  139.         YDPGE=XZero
  140.       ENDIF
  141. *
  142.       NHRM=NIFOUR
  143. *
  144.       MINTE=IPMINT
  145.       IRTD=1
  146.       IDECAP=0
  147. C_______________________________________________________________________
  148. C
  149. C     NUMERO DES ETIQUETTES      :
  150. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  151. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  152. C     5  CONTINUE
  153. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  154. C     44 CONTINUE
  155. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  156. C_______________________________________________________________________
  157. C
  158.       IF(MELE.GE.1.AND.MELE.LE.100) THEN
  159. C            CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  160.       GOTO (   99,  99,  99,   4,  99,   4,  99,   4,  99,   4
  161. C            QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  162.      1      ,  99,  99,  99,   4,   4,   4,   4,  99,  99,  99
  163. C            LIA8 MULT TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP
  164.      2      ,  99,  99,   4,   4,   4,   4,  99,  99,  99,  99
  165. C            FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  166.      3      ,  99,  99,  99,  99,  35,  35,  35,  35,  35,  35
  167. C            COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  168.      4      ,  99,  99,  99,  99,  99,  99,  99,  48,  99,  99
  169. C            COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  170.      5      ,  99,  99,  48,  48,  99,  99,  99,  99,  99,  99
  171. C            CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  172.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,   4,   4
  173. C            ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  174.      7      ,   4,   4,   4,   4,   4,   4,   4,   4,  79,  79
  175. C            CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  176.      8      ,  79,  79,  79,  99,  99,  99,  99,  99,  99,  99
  177. C            LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  178.      9      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99)
  179. c cccccc
  180.      .      ,MELE
  181.       ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  182. C            HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  183.       GOTO (   99,  99,  99,  99,  99,  99,  99,  80,  80,  80
  184. C            POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  185.      1      ,   4,   4,   4,   4,   4,   4,   4,   4,   4,   4
  186. C            PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  187.      2      ,   4,   4,  99,  99,  99,  99,  99,  99,  99,  99
  188. C            QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  189.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  190. C            MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  191.      4      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  192. C            TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  193.      5      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  194. C            BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  195.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  196. C            JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  197.      7      ,  99,  99, 173, 173, 173, 173, 173, 173, 173, 173
  198. C            TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  199.      8      , 173, 173,   4,   4, 185, 185, 185, 185, 185, 185
  200. C            T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  201.      9      ,  99,  99,   4,   4,  99,  99,  99,  99,  99,  99)
  202. c cccccc
  203.      .      ,MELE-100
  204.       ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  205. C            LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  206.       GOTO (   99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  207. C            BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  208.      1      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  209. C            MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  210.      2      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  211. C            MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  212.      3      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  213. C            QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  214.      4      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  215. C            QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  216.      5      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  217. C            CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  218.      6      ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
  219. C            COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  220.      7      ,  99,  99,   4,   4,   4,   4,   4,   4,   4,   4)
  221. c cccccc
  222.      .      ,MELE-200
  223.       ENDIF
  224.       GOTO 99
  225. C_______________________________________________________________________
  226. C
  227. C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES
  228. C_______________________________________________________________________
  229. C
  230.    4  CONTINUE
  231.       DIM3=1.D0
  232. *
  233. *  CAS  ORTHOTROPE ( 2)  ANISOTROPE ( 3) UNIDIRICTIONNEL (4)
  234. *
  235. *  RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
  236. *  L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  237.       IPMIN2 = 0
  238.       IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  239.         NLG=NUMGEO(MELE)
  240.         CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  241.         MINTE2=IPMIN2
  242.         SEGACT MINTE2
  243.         SEGINI WRK8
  244.       ENDIF
  245.  
  246.       NBNO=NBNN
  247.       NBBB=NBNN
  248.       SEGINI WRK1,WRK2
  249.  
  250.         if (melpha.gt.0) melva1 = melpha
  251.  
  252. * Initialisation en cas de matrice d'efficacite
  253.       MWRK67 = 0
  254.       celem = '        '
  255.       IF (IVACAR.GT.0) THEN
  256.         MPTVAL=IVACAR
  257. *        SEGACT,MPTVAL
  258.         IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN
  259.           nca1 = IVAL(/1)
  260.           SEGINI,MWRK67
  261.           celem = 'MASSIF  '
  262.           nstep = 2
  263.           if (ifour.eq.2) nstep = 3
  264.           drend = .false.
  265.           irend = 0
  266.           if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
  267.             drend = .true.
  268.             irend = 1
  269.           endif
  270.           if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
  271.             drend = .false.
  272.             irend = 2
  273.           endif
  274.         ENDIF
  275.       ENDIF
  276.  
  277.       DO 3004  IB=1,NBELEM
  278. C
  279. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  280. C
  281.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  282. C
  283. C     CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
  284. C     ANISOTROPE  ET UNIDIRECTIONNEL
  285. C
  286. C*    IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN
  287.       IF (IPMIN2.NE.0) THEN
  288.         NBSH=MINTE2.SHPTOT(/2)
  289.         CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  290.         if (nbsh.eq.-1) then
  291.          call erreur(525)
  292.          goto 9904
  293.         endif
  294.       ENDIF
  295. C
  296.       CALL ZERO (RINT,LRE,LRE)
  297. C
  298. C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE
  299.       IF (MFR.EQ.31) THEN
  300.         CALL BBCALC(MELE,NBNN,MFR,IDIM,XE,
  301.      &              NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  302.      &              NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK,
  303.      &              BGENE,XDPGE,YDPGE,PP,NOER)
  304.         IF (NOER.NE.0) THEN
  305.           CALL ERREUR(noer)
  306.           RETURN
  307.         ENDIF
  308.       ENDIF
  309. C     segact,wrk1*mod
  310. C
  311. C     BOUCLE SUR LES POINTS DE GAUSS
  312. C
  313.       ISDJC=0
  314.       DO 4004  IGAU=1,NBPGAU
  315. C
  316. C   RECUPERATION DE L'EPAISSEUR
  317. C
  318.       IF (IFOUR.EQ.-2)THEN
  319.         MPTVAL=IVACAR
  320.         IF (IVACAR.NE.0) THEN
  321.          MELVAL=IVAL(1)
  322.          IF (MELVAL.NE.0) THEN
  323.           IGMN=MIN(IGAU,VELCHE(/1))
  324.           IBMN=MIN(IB,VELCHE(/2))
  325.           DIM3=VELCHE(IGMN,IBMN)
  326.          ELSE
  327.           DIM3=1.D0
  328.          ENDIF
  329.         ENDIF
  330.       ENDIF
  331.  
  332. *
  333.       CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  334.      1            MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
  335.      2            SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  336.  
  337.       IF (DJAC.EQ.0.D0) THEN
  338.         INTERR(1)=IB
  339.         CALL ERREUR(259)
  340.         GOTO 9904
  341.       ENDIF
  342.       IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  343.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  344.  
  345. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  346.       IF (MFR.EQ.31) THEN
  347.         CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  348.      &            MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  349.       ENDIF
  350. C
  351.       MPTVAL=IVAMAT
  352.       IF(IMAT.EQ.2) THEN
  353.        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  354.         MELVAL=IVAL(1)
  355.         IBMN=MIN(IB  ,IELCHE(/2))
  356.         IGMN=MIN(IGAU,IELCHE(/1))
  357.         MLREEL=IELCHE(IGMN,IBMN)
  358.         SEGACT,MLREEL
  359.         CALL DOHOOO(PROG,LHOOK,DDHOOK)
  360. C        SEGDES MLREEL
  361.        ENDIF
  362.       ELSE IF (IMAT.EQ.1) THEN
  363.         DO 9004 IM=1,NMATT
  364.           IF (IVAL(IM).NE.0) THEN
  365.             MELVAL=IVAL(IM)
  366.             IBMN=MIN(IB  ,VELCHE(/2))
  367.             IGMN=MIN(IGAU,VELCHE(/1))
  368.             if (ibmn.gt.0.and.igmn.gt.0) then
  369.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  370.             else
  371.               VALMAT(IM)=0.D0
  372.             endif
  373.           ELSE
  374.             VALMAT(IM)=0.D0
  375.           ENDIF
  376.  9004   CONTINUE
  377.         IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
  378.          IF(IGAU.LE.NBGMAT)
  379.      1     CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  380.      2                 ROTH,DDHOOK,LHOOK,1,IRTD)
  381.         ELSE
  382.          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  383.      1     CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  384.         ENDIF
  385.       ENDIF
  386. C
  387. C    CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
  388. C                  /MASSIF ------------ PRODUIT PAR BLOC
  389. C
  390. * initialise
  391.       CALL ZERO (REL,LRE,LRE)
  392. * calcul rigidite elementaire
  393.       IF (BDPGE) THEN
  394.         CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  395.       ELSE
  396.         CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
  397.      1             IGAU,IMAT,0.D0)
  398.       ENDIF
  399.  
  400. * matrice d'efficacite
  401.         IF (MWRK67.GT.0) THEN
  402.           MPTVAL=IVACAR
  403.           DO 9008 IM= 1,IVAL(/1)
  404.             IF (IVAL(IM).GT.0) THEN
  405.               MELVAL=IVAL(IM)
  406.               IF (TYVAL(IM).EQ.'REAL*8') THEN
  407.                 IBMN=MIN(IB  ,VELCHE(/2))
  408.                 IGMN=MIN(IGAU,VELCHE(/1))
  409.                 VALCAR(IM)=VELCHE(IGMN,IBMN)
  410.               ELSE
  411.                 IBMN=MIN(IB  ,IELCHE(/2))
  412.                 IGMN=MIN(IGAU,IELCHE(/1))
  413.                 VALCAR(IM)=IELCHE(IGMN,IBMN)
  414.               ENDIF
  415.             ELSE
  416.               VALCAR(IM)=0.D0
  417.             ENDIF
  418.  9008     CONTINUE
  419.           do i = 1,nstep
  420.             do j = 1, nstep
  421.               xatef1(i,j) = 0.d0
  422.             enddo
  423.           enddo
  424.           if (irend.eq.1) then
  425.             xatef1(1,1) = valcar(ncar1)
  426.             xatef1(2,2) = valcar(ncar1)
  427.             if (nstep.eq.3) xatef1(3,3) = valcar(ncar1)
  428.           else if (irend.eq.2) then
  429.             xatef1(1,1) = valcar(ncar1+7)
  430.             xatef1(2,2) = valcar(ncar1+8)
  431.             if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  432.           endif
  433.           call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
  434.      &               nstep,drend,celem)
  435.         ENDIF
  436.  
  437. * ponderation par la phase
  438.         IF (MELPHA.GT.0) THEN
  439.           IBMN=MIN(IB  ,melva1.VELCHE(/2))
  440.           IGMN=MIN(IGAU,melva1.VELCHE(/1))
  441.           coe1 = melva1.velche(igmn,ibmn)
  442.         ELSE
  443.           coe1 = 1.D0
  444.         ENDIF
  445. *  stocke
  446.        do jj = 1,LRE
  447.          do ii = 1,LRE
  448.            rint(ii,jj) = rint(ii,jj) + rel(ii,jj)*coe1
  449.          enddo
  450.        enddo
  451. *
  452.  4004 CONTINUE
  453. *
  454.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  455.         INTERR(1)=IB
  456.         if (noer.eq.0) CALL ERREUR(195)
  457.          noer=195
  458.         GOTO 9904
  459.       ENDIF
  460. C
  461. C     REMPLISSAGE DE XMATRI
  462. C
  463. c      CALL REMPMT(RINT,LRE,RE)
  464.        DO IBK=1,LRE
  465.          DO IAK=1,LRE
  466.            RE(IAK,IBK,IB)=RINT(IAK,IBK)
  467.          ENDDO
  468.        ENDDO
  469. *      do i = 1,8
  470. *      write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i)
  471. *      enddo
  472. *
  473.  3004 CONTINUE
  474. c
  475.       IF(IRTD.EQ.0) THEN
  476.         MOTERR(1:8)=CMATE
  477.         MOTERR(9:16)=NOMFR(MFR/2+1)
  478.        INTERR(1)=IFOUR
  479.        CALL ERREUR(81)
  480.       ENDIF
  481.  9904 CONTINUE
  482. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN
  483.       IF (IPMIN2.NE.0) THEN
  484.        SEGDES MINTE2
  485.        SEGSUP WRK8
  486.       ENDIF
  487.       SEGSUP WRK1,WRK2
  488.       IF (MWRK67.NE.0) SEGSUP,MWRK67
  489.       GOTO 510
  490. C_______________________________________________________________________
  491. C
  492. C     SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES
  493. C_______________________________________________________________________
  494. C
  495.   35  CONTINUE
  496.       NBNO=NBNN
  497.       NBBB=NBNN
  498.       NSTRS=NDDL
  499.       SEGINI WRK1,WRK2
  500. c
  501.       DO 3035  IB=1,NBELEM
  502. C
  503. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  504. C
  505.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  506.       CALL ZERO (REL,LRE,LRE)
  507. C
  508. C     BOUCLE SUR LES POINTS DE GAUSS
  509. C
  510.       ISDJC=0
  511.       DO 4035  IGAU=1,NBPGAU
  512.  
  513.         MPTVAL=IVAMAT
  514.         DO IM=1,5
  515.              IF (IVAL(IM).NE.0) THEN
  516.                MELVAL=IVAL(IM)
  517.                IGMN=MIN(IGAU,VELCHE(/1))
  518.                IBMN=MIN(IB,VELCHE(/2))
  519.                VALMAT(IM)=VELCHE(IGMN,IBMN)
  520.              ELSE
  521.                VALMAT(IM)=0.D0
  522.              ENDIF
  523.         ENDDO
  524. C
  525. C     CALCUL DES COEFFICIENTS DE NORMALISATION
  526. C
  527.       RHO   =VALMAT(1)
  528.       C     =VALMAT(2)
  529.       RHOREF=VALMAT(3)
  530.       CREF  =VALMAT(4)
  531.       RLCAR =VALMAT(5)
  532. C
  533.       COEFPR=(RHOREF*CREF*CREF)/RLCAR
  534.       VKL   =(COEFPR*COEFPR)/(RHO*C*C)
  535.  
  536.       CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  537.      1                  SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  538.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  539.  
  540.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  541.       CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL)
  542.  4035 CONTINUE
  543. *
  544.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  545.         INTERR(1)=IB
  546.         CALL ERREUR(195)
  547.          noer=195
  548.         GOTO 9935
  549.       ENDIF
  550. C
  551. C     REMPLISSAGE DE XMATRI
  552. C
  553.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  554.  3035 CONTINUE
  555. *
  556.  9935 CONTINUE
  557.       SEGSUP WRK1,WRK2
  558.       GOTO 510
  559. C_______________________________________________________________________
  560. C
  561. C     SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE
  562. C_______________________________________________________________________
  563. C
  564.   48  CONTINUE
  565.       NBNO=NBNN
  566.       NBBB=NBNN
  567.       NSTRS=NDDL
  568.       SEGINI WRK1,WRK2
  569. c
  570.       DO 3048  IB=1,NBELEM
  571. C
  572. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  573. C
  574.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  575.       CALL ZERO (REL,LRE,LRE)
  576. C
  577.       MPTVAL=IVAMAT
  578.       DO 9048 IM=1,6
  579.         IF (IVAL(IM).NE.0) THEN
  580.           MELVAL=IVAL(IM)
  581.           IBMN=MIN(IB  ,VELCHE(/2))
  582.           VALMAT(IM)=VELCHE(1,IBMN)
  583.         ELSE
  584.           VALMAT(IM)=0.D0
  585.         ENDIF
  586.  9048 CONTINUE
  587. C
  588.       RHO   =VALMAT(1)
  589.       G     =VALMAT(6)
  590.       VKS   =RHO*G
  591. C
  592. C     BOUCLE SUR LES POINTS DE GAUSS
  593. C
  594.       ISDJC=0
  595.       DO 4048  IGAU=1,NBPGAU
  596.       CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  597.      1                  SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  598.       IF(DJAC.LT.0.0) ISDJC=ISDJC+1
  599.  
  600.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  601.       CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL)
  602.  4048 CONTINUE
  603.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  604.         INTERR(1)=IB
  605.         CALL ERREUR(195)
  606.          noer=195
  607.         GOTO 9948
  608.       ENDIF
  609. C
  610. C     REMPLISSAGE DE XMATRI
  611. C
  612.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  613.  3048 CONTINUE
  614. C
  615.  9948 CONTINUE
  616.       SEGSUP WRK1,WRK2
  617.       GOTO 510
  618. C_______________________________________________________________________
  619. C
  620. C     MILIEUX POREUX
  621. C_______________________________________________________________________
  622. C
  623.   79  CONTINUE
  624. C
  625. C* Cas non pevus actuellement
  626.       IF (IMAT.EQ.1) THEN
  627.         IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99
  628.       ELSE
  629.         GOTO 99
  630.       ENDIF
  631. C
  632. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  633. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  634. C    ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  635. C
  636.       DIM3=1.D0
  637.       NCOT=0
  638.       NBNO=IPORE
  639.       NBBB=NBNN
  640.       NSTN=1
  641. ****************  AM 08/01/01
  642. ***** NSTMU=2
  643. ***** IF(IFOUR.GE.0) NSTMU=3
  644.       NSTMU=3
  645.       LRN = NBNO-NBBB
  646.       LRB=LRE-NBNN
  647.  
  648.       IELE=NUMGEO(MELE)
  649.       IF(IELE.EQ.6 ) NCOT=3
  650.       IF(IELE.EQ.10) NCOT=4
  651.       IF(IELE.EQ.15) NCOT=12
  652.       IF(IELE.EQ.17) NCOT=9
  653.       IF(IELE.EQ.24) NCOT=6
  654.       IF(NCOT.EQ.0) THEN
  655.         CALL ERREUR(5)
  656.         GOTO  510
  657.       ENDIF
  658. *
  659. *     CAS NON ISOTROPES
  660. *     RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  661. *     AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  662. *
  663.       IPMIN2 = 0
  664.       IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN
  665.         CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  666.         MINTE2=IPMIN2
  667.         SEGACT MINTE2
  668.         SEGINI WRK8
  669.         NSTMU=LHOOK
  670.       ENDIF
  671. *
  672.       SEGINI WRK1,WRK2,WRK5,WRK55
  673. *
  674.       DO 3079  IB=1,NBELEM
  675. *
  676. *     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  677. *
  678.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  679. *
  680. *     CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
  681. *
  682. C*    IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  683. C*   .                         .AND.IMAT.EQ.1)THEN
  684.       IF (IPMIN2.NE.0) THEN
  685.         NBSH=MINTE2.SHPTOT(/2)
  686.         CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  687.         if (nbsh.eq.-1) then
  688.          call erreur(525)
  689.          goto 9979
  690.         endif
  691.       ENDIF
  692. *
  693.       CALL ZERO (REL,LRE,LRE)
  694. *
  695. *     TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
  696. *
  697.       FREF = 1.D6
  698.       CALL BNPOR2(YGENE,NCOT,IELE)
  699.       IF(IERR.NE.0) GOTO 9979
  700. *
  701. *      DO 27895 IOI=1,NCOT
  702. *      WRITE(6,28927) IOI
  703. *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  704. *      WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN)
  705. *28928 FORMAT(8(1X,1PE10.3))
  706. *27895 CONTINUE
  707. C
  708. C     BOUCLE SUR LES POINTS DE GAUSS
  709. C
  710.       ISDJC=0
  711.       DO 4079  IGAU=1,NBPGAU
  712. C
  713. C   RECUPERATION DE L'EPAISSEUR
  714. C
  715.       IF (IFOUR.EQ.-2)THEN
  716.         MPTVAL=IVACAR
  717.         IF (IVACAR.NE.0) THEN
  718.          MELVAL=IVAL(1)
  719.          IF (MELVAL.NE.0) THEN
  720.           IGMN=MIN(IGAU,VELCHE(/1))
  721.           IBMN=MIN(IB,VELCHE(/2))
  722.           DIM3=VELCHE(IGMN,IBMN)
  723.          ELSE
  724.           DIM3=1.D0
  725.          ENDIF
  726.         ENDIF
  727.       ENDIF
  728. C
  729.  
  730. c     write(6,*) 'rigi2 WRK1,lhook,nstrs=',WRK1,lhook,nstrs
  731.       CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  732.      .            DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  733.       IF (DJAC.EQ.0.D0) THEN
  734.         INTERR(1)=IB
  735.         CALL ERREUR(259)
  736.         GOTO 9979
  737.       ENDIF
  738.       IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  739.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  740. C
  741. *      IF(IGAU.EQ.1) THEN
  742. *      DO 27892 IOI=1,LHOOK
  743. *      WRITE(6,28920) IOI
  744. *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  745. *      WRITE(6,28921) (BGENE(IOI,J),J=1,LRE)
  746. *28921 FORMAT(8(1X,1PE10.3))
  747. *27892 CONTINUE
  748. *       DO 27893 IOI=1,NSTN
  749. *       WRITE(6,28922) IOI
  750. *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  751. *       WRITE(6,28923) (XGENE(IOI,J),J=1,LRN)
  752. *28923 FORMAT(8(1X,1PE10.3))
  753. *27893 CONTINUE
  754. *      ENDIF
  755.  
  756.       MPTVAL=IVAMAT
  757. C*D   IF(IMAT.EQ.2) THEN
  758. C*D     GO TO 99
  759. C*D   ELSE IF (IMAT.EQ.1) THEN
  760. *
  761.         DO 9079 IM=1,NMATT
  762.           IF (IVAL(IM).NE.0) THEN
  763.             MELVAL=IVAL(IM)
  764.             IBMN=MIN(IB  ,VELCHE(/2))
  765.             IGMN=MIN(IGAU,VELCHE(/1))
  766.             VALMAT(IM)=VELCHE(IGMN,IBMN)
  767.           ELSE
  768.             VALMAT(IM)=0.D0
  769.           ENDIF
  770.  9079   CONTINUE
  771. *
  772.         IF(MATE.EQ.1) THEN
  773.          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  774.      .   CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  775.          DO 4879 I=1,NSTMU
  776.            COBMA(I) =VALMAT(3)
  777.  4879    CONTINUE
  778.          XMOB       =VALMAT(4)
  779. *
  780.         ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  781.         IF(IGAU.LE.NBGMAT)
  782.      .   CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  783.      .               ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  784. C*D     ELSE
  785. C*D       GO TO 99
  786.         ENDIF
  787. *
  788. C*D   ENDIF
  789. *
  790.       CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  791.      .           IGAU,IMAT,0.D0)
  792.       EREF  =1.D0
  793.       DJACER=DJAC*EREF
  794.       DO I=1,LRB
  795.         DO J=1,LRN
  796.           JJ=J+LRB
  797.           r_z = 0.D0
  798.           DO K=1,NSTMU
  799.             r_z = r_z + COBMA(K)*BGENE(K,I)
  800.           ENDDO
  801.           r_z = r_z * DJACER * XGENE(1,J)
  802.           REL(JJ,I)=REL(JJ,I) - r_z
  803.         ENDDO
  804.        ENDDO
  805. *
  806.       IF(XMOB.EQ.0.D0) THEN
  807.         UNSURM=0.D0
  808.       ELSE
  809.         UNSURM=1.D0 / XMOB
  810.       ENDIF
  811.       COMJAC=UNSURM*DJAC*EREF*EREF
  812.       DO I=1,LRN
  813.         II=I+LRB
  814.         r_z = COMJAC*XGENE(1,I)
  815.         DO J=1,I
  816.           JJ=J+LRB
  817.           REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)
  818.         ENDDO
  819.       ENDDO
  820. C
  821.       COMJAC=UNSURM*DJAC*FREF
  822.       DO I=1,NBNN
  823.         II=I+LRB
  824.         DO J=1,I
  825.           JJ=J+LRB
  826.           r_z = 0.D0
  827.           DO K=1,NCOT
  828.             r_z = r_z + YGENE(K,I)*YGENE(K,J)
  829.           ENDDO
  830.           REL(II,JJ)=REL(II,JJ) + (COMJAC*r_z)
  831.         ENDDO
  832.       ENDDO
  833. *
  834.  4079 CONTINUE
  835.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  836.         INTERR(1)=IB
  837.         CALL ERREUR(195)
  838.          noer=195
  839.         GOTO 9979
  840.       ENDIF
  841. C
  842. C     REMPLISSAGE DE XMATRI
  843. C
  844.       CALL REMPMT(REL,LRE,RE(1,1,ib))
  845. *
  846.  3079 CONTINUE
  847. c
  848.       IF(IRTD.EQ.0) THEN
  849.         MOTERR(1:8)=CMATE
  850.         MOTERR(9:16)=NOMFR(MFR/2+1)
  851.        INTERR(1)=IFOUR
  852.        CALL ERREUR(81)
  853.       ENDIF
  854.  9979 CONTINUE
  855.       SEGSUP WRK1,WRK2,WRK5,WRK55
  856. C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN
  857.       IF (IPMIN2.NE.0) THEN
  858.        SEGDES MINTE2
  859.        SEGSUP WRK8
  860.       ENDIF
  861.       GOTO 510
  862. C_______________________________________________________________________
  863. C
  864. C     MILIEUX POREUX - SUITE
  865. C_______________________________________________________________________
  866. C
  867.  173  CONTINUE
  868. C
  869. C     CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  870.       IF (IMAT.EQ.1) THEN
  871.         IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  872.           CALL ERREUR(251)
  873.           GO TO 510
  874.         ENDIF
  875.       ELSE
  876. C*    ELSE IF (IMAT.EQ.2) THEN
  877.         GO TO 99
  878.       ENDIF
  879. C
  880. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  881. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  882. C    ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  883. C
  884.       IF(MFR.EQ.57) IDECAP=2
  885.       IF(MFR.EQ.59) IDECAP=3
  886. *
  887.       DIM3=1.D0
  888.       NCOT=0
  889.       NBNO=IPORE
  890.       NBBB=NBNN
  891.       NSTN=IDECAP
  892. *
  893. ****************  AM 08/01/01
  894. ***** NSTMU=2
  895. ***** IF(IFOUR.GE.0) NSTMU=3
  896. *
  897.       NSTMU=3
  898.       LPP=NBNO-NBBB
  899.       LRN = IDECAP*LPP
  900. ****  LRB=LRE-LRN
  901.       LRB=LRE-(IDECAP*NBBB)
  902.       IELE=NUMGEO(MELE)
  903. *
  904.       IF(IELE.EQ.6 ) NCOT=3
  905.       IF(IELE.EQ.10) NCOT=4
  906.       IF(IELE.EQ.15) NCOT=12
  907.       IF(IELE.EQ.17) NCOT=9
  908.       IF(IELE.EQ.24) NCOT=6
  909.       IF(NCOT.EQ.0) THEN
  910.         CALL ERREUR(5)
  911.         GO TO  510
  912.       ENDIF
  913. *
  914.       SEGINI WRK1,WRK2,WRK5,WRK55,WRK555
  915.  
  916.       DO 3173  IB=1,NBELEM
  917. *
  918. *     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  919. *
  920.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  921. *
  922.       CALL ZERO (REL,LRE,LRE)
  923. *
  924. *     TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
  925. *
  926.       FREF = 1.D6
  927.       CALL BNPOR2(YGENE,NCOT,IELE)
  928.       IF(IERR.NE.0) GO TO 9973
  929.  
  930. *      DO 17895 IOI=1,NCOT
  931. *      WRITE(6,78927) IOI
  932. *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  933. *      WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN)
  934. *78928 FORMAT(8(1X,1PE10.3))
  935. *17895 CONTINUE
  936. C
  937. C     BOUCLE SUR LES POINTS DE GAUSS
  938. C
  939.       ISDJC=0
  940.       DO 4173  IGAU=1,NBPGAU
  941. C
  942. C   RECUPERATION DE L'EPAISSEUR
  943. C
  944.       IF (IFOUR.EQ.-2)THEN
  945.         MPTVAL=IVACAR
  946.         IF (IVACAR.NE.0) THEN
  947.          MELVAL=IVAL(1)
  948.          IF (MELVAL.NE.0) THEN
  949.           IGMN=MIN(IGAU,VELCHE(/1))
  950.           IBMN=MIN(IB,VELCHE(/2))
  951.           DIM3=VELCHE(IGMN,IBMN)
  952.          ELSE
  953.           DIM3=1.D0
  954.          ENDIF
  955.         ENDIF
  956.       ENDIF
  957. C
  958.       NSTB=LHOOK
  959.       CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  960.      .     DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  961.       IF(DJAC.EQ.0.D0) THEN
  962.         INTERR(1)=IB
  963.         CALL ERREUR(259)
  964.         GOTO 9973
  965.       ENDIF
  966.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  967.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  968. C
  969. *      IF(IGAU.EQ.1) THEN
  970. *      DO 17892 IOI=1,LHOOK
  971. *      WRITE(6,78920) IOI
  972. *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  973. *      WRITE(6,78921) (BGENE(IOI,J),J=1,LRE)
  974. *78921 FORMAT(8(1X,1PE10.3))
  975. *17892 CONTINUE
  976. *      DO 17893 IOI=1,NSTN
  977. *      WRITE(6,78922) IOI
  978. *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  979. *       WRITE(6,78923) (XGENE(IOI,J),J=1,LRN)
  980. *78923 FORMAT(8(1X,1PE10.3))
  981. *17893 CONTINUE
  982. *       ENDIF
  983.  
  984.       MPTVAL=IVAMAT
  985. C*D   IF(IMAT.EQ.2) THEN
  986. C*D     GO TO 99
  987. C*D   ELSE IF (IMAT.EQ.1) THEN
  988. *
  989.         DO 9173 IM=1,NMATT
  990.           IF (IVAL(IM).NE.0) THEN
  991.             MELVAL=IVAL(IM)
  992.             IBMN=MIN(IB  ,VELCHE(/2))
  993.             IGMN=MIN(IGAU,VELCHE(/1))
  994.             VALMAT(IM)=VELCHE(IGMN,IBMN)
  995.           ELSE
  996.             VALMAT(IM)=0.D0
  997.           ENDIF
  998.  9173   CONTINUE
  999. *
  1000. C*D     IF(MATE.EQ.1) THEN
  1001.          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1002.      .   CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  1003. *
  1004. C*D     ELSE
  1005. C*D       GO TO 99
  1006. C*D     ENDIF
  1007. C*D   ENDIF
  1008. *
  1009.       CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1010.       EREF  =1.D0
  1011. *
  1012.       IF(MFR.EQ.57) THEN
  1013.             COBB(1)  = VALMAT(3)
  1014.             COBB(2)  = VALMAT(4)
  1015.             CPBB(1)  = VALMAT(5)
  1016.             CPBB(2)  = VALMAT(6)
  1017.             KKBB(1,1)= VALMAT(7)
  1018.             KKBB(1,2)= VALMAT(8)
  1019.             KKBB(2,1)= VALMAT(9)
  1020.             KKBB(2,2)= VALMAT(10)
  1021. *
  1022.       ELSE IF(MFR.EQ.59) THEN
  1023.             COBB(1)  = VALMAT(3)
  1024.             COBB(2)  = VALMAT(4)
  1025.             COBB(3)  = VALMAT(5)
  1026.             CPBB(1)  = VALMAT(6)
  1027.             CPBB(2)  = VALMAT(7)
  1028.             CPBB(3)  = VALMAT(8)
  1029.             KKBB(1,1)= VALMAT(9)
  1030.             KKBB(1,2)= VALMAT(10)
  1031.             KKBB(1,3)= VALMAT(11)
  1032.             KKBB(2,1)= VALMAT(12)
  1033.             KKBB(2,2)= VALMAT(13)
  1034.             KKBB(2,3)= VALMAT(14)
  1035.             KKBB(3,1)= VALMAT(15)
  1036.             KKBB(3,2)= VALMAT(16)
  1037.             KKBB(3,3)= VALMAT(17)
  1038.        ENDIF
  1039. *
  1040.         DJACER=DJAC*EREF
  1041.  
  1042.         DO IPR=1,IDECAP
  1043.           LRBDEC=LRB + (IPR-1)*NBBB
  1044.           LPPDEC= (IPR-1)*LPP
  1045.           COMJAC=COBB(IPR)*DJACER
  1046.           DO I=1,LRB
  1047.             r_z = 0.D0
  1048.             DO K=1,NSTMU
  1049.               r_z = r_z + BGENE(K,I)
  1050.             ENDDO
  1051.             r_z = r_z * COMJAC
  1052.             DO J=1,LPP
  1053.               JJ=J+LRBDEC
  1054.               JX=J+LPPDEC
  1055.               REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX)
  1056.             ENDDO
  1057.           ENDDO
  1058.         ENDDO
  1059. *
  1060.         DO IPR=1,IDECAP
  1061.           LRBDEC=LRB + (IPR-1)*NBBB
  1062.           LPPDEC= (IPR-1)*LPP
  1063.           COMJAC=CPBB(IPR)*DJACER
  1064.           DO I=1,LRB
  1065.             r_z = 0.D0
  1066.             DO K=1,NSTMU
  1067.               r_z = r_z + BGENE(K,I)
  1068.             ENDDO
  1069.             r_z = COMJAC*r_z
  1070.             DO J=1,LPP
  1071.               JJ=J+LRBDEC
  1072.               JX=J+LPPDEC
  1073. *             ici - pour bsig
  1074.               REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX)
  1075.             ENDDO
  1076.           ENDDO
  1077.         ENDDO
  1078. *
  1079.         COMJAC=DJAC*EREF*EREF
  1080.         CALL ZERO(XREL,LRN,LRN)
  1081.         CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1082.  
  1083.         DO IPR=1,IDECAP
  1084.           IRBDEC=LRB + (IPR-1)*NBBB
  1085.           IPPDEC= (IPR-1)*LPP
  1086.         DO JPR=1,IDECAP
  1087.           JRBDEC=LRB + (JPR-1)*NBBB
  1088.           JPPDEC= (JPR-1)*LPP
  1089.           DO I=1,LPP
  1090.           II=I+IRBDEC
  1091.           IX=I+IPPDEC
  1092.           DO J=1,LPP
  1093.           JJ=J+JRBDEC
  1094.           JX=J+JPPDEC
  1095.  
  1096. *          IF(IGAU.EQ.1) THEN
  1097. *          PRINT *,'I =',I,' IX=',IX,' II=',II
  1098. *          PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1099. *          ENDIF
  1100.  
  1101.           REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1102.           ENDDO
  1103.           ENDDO
  1104.         ENDDO
  1105.         ENDDO
  1106. C
  1107.         DO IPR=1,IDECAP
  1108.           COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1109.           LRBDEC=LRB + (IPR-1)*NBBB
  1110.           DO I=1,NBNN
  1111.           II=I+LRBDEC
  1112.           DO J=1,NBNN
  1113.             JJ=J+LRBDEC
  1114.             r_z = 0.D0
  1115.             DO K=1,NCOT
  1116.               r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1117.             ENDDO
  1118.             REL(II,JJ)=REL(II,JJ) + (COMJAC * r_z)
  1119.           ENDDO
  1120.           ENDDO
  1121.         ENDDO
  1122. *
  1123.  4173 CONTINUE
  1124.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1125.         INTERR(1)=IB
  1126.         CALL ERREUR(195)
  1127.          noer=195
  1128.         GOTO 9973
  1129.        ENDIF
  1130. C
  1131. C     REMPLISSAGE DE XMATRI
  1132. C
  1133.       CALL REMPMS(REL,LRE,RE(1,1,ib))
  1134.  3173 CONTINUE
  1135. c
  1136.       IF(IRTD.EQ.0) THEN
  1137.         MOTERR(1:8)=CMATE
  1138.         MOTERR(9:16)=NOMFR(MFR/2+1)
  1139.        INTERR(1)=IFOUR
  1140.        CALL ERREUR(81)
  1141.       ENDIF
  1142.  9973 CONTINUE
  1143.       SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555
  1144.       GOTO 510
  1145. C_______________________________________________________________________
  1146. C
  1147. C     JOINTS EN FORMULATION MILIEUX POREUX
  1148. C_______________________________________________________________________
  1149. C
  1150.   80  CONTINUE
  1151. C
  1152. * CAS NON PREVUS
  1153.       IF (IMAT.EQ.1) THEN
  1154.         IF (MATE.NE.1) GOTO 99
  1155.       ELSE IF (IMAT.EQ.2) THEN
  1156.         GOTO 99
  1157.       ENDIF
  1158. C
  1159. C   POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  1160. C                      NBNO = NOMBRE DE FONCTIONS DE FORME
  1161. C   ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1162. C
  1163.       NCOT=0
  1164.       NBNO=IPORE
  1165.       NBBB=NBNN
  1166.       NSTN=1
  1167.       NSTMU=2
  1168.       IF(IFOUR.EQ.2) NSTMU=3
  1169.       LRN=(NBNO-NBBB)*3/2
  1170.       LPP=LRN
  1171.       LRB=LRE-NBNN
  1172.       IELE=NUMGEO(MELE)
  1173.       IF(IELE.EQ.29) NCOT=2
  1174.       IF(IELE.EQ.30) NCOT=6
  1175.       IF(IELE.EQ.31) NCOT=8
  1176.       IF(NCOT.EQ.0) THEN
  1177.         CALL ERREUR(5)
  1178.         GO TO  510
  1179.       ENDIF
  1180. *
  1181.       SEGINI WRK1,WRK2,WRK3,WRK5,WRK55
  1182. *
  1183.       DO 3080  IB=1,NBELEM
  1184. *
  1185. *   ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1186. *
  1187.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1188. *
  1189. *   CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1190. *
  1191.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1192. *
  1193.       CALL ZERO (REL,LRE,LRE)
  1194. *
  1195.       CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  1196. *
  1197. *   TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
  1198. *
  1199.       FREF = 1.D6
  1200.       CALL BNPOR2(YGENE,NCOT,IELE)
  1201.       IF (IERR.NE.0) GOTO 9980
  1202. *
  1203. *   BOUCLE SUR LES POINTS DE GAUSS
  1204. *
  1205.       ISDJC=0
  1206.       DO 4080  IGAU=1,NBPGAU
  1207. *
  1208.       CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1209.      .            SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  1210.       IF (DJAC.EQ.0.D0) THEN
  1211.         INTERR(1)=IB
  1212.         CALL ERREUR(259)
  1213.         GOTO 9980
  1214.       ENDIF
  1215.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1216.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  1217. *
  1218.       MPTVAL=IVAMAT
  1219. C*D   IF(IMAT.EQ.2) THEN
  1220. C*D     GO TO 99
  1221. C*D   ELSE IF (IMAT.EQ.1) THEN
  1222. *
  1223.         DO 9080 IM=1,NMATT
  1224.           IF (IVAL(IM).NE.0) THEN
  1225.             MELVAL=IVAL(IM)
  1226.             IBMN=MIN(IB  ,VELCHE(/2))
  1227.             IGMN=MIN(IGAU,VELCHE(/1))
  1228.             VALMAT(IM)=VELCHE(IGMN,IBMN)
  1229.           ELSE
  1230.             VALMAT(IM)=0.D0
  1231.           ENDIF
  1232.  9080   CONTINUE
  1233. *
  1234. C*D     IF(MATE.EQ.1) THEN
  1235.          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1236.      .   CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1237.  
  1238. C*D     ELSE
  1239. C*D       GO TO 99
  1240. C*D     ENDIF
  1241. C*D   ENDIF
  1242. *
  1243.       CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  1244.      .           IGAU,IMAT,0.D0)
  1245.       EREF  =1.D0
  1246. *
  1247.           COBMA(NSTMU)=VALMAT(3)
  1248.           XMOB=VALMAT(4)
  1249. *
  1250.       IF(XMOB.EQ.0.D0) THEN
  1251.         UNSURM=0.D0
  1252.       ELSE
  1253.         UNSURM=1.D0 / XMOB
  1254.       ENDIF
  1255. *
  1256.       DJACER=DJAC*EREF*COBMA(NSTMU)
  1257.       DO I=1,LRB
  1258.         r_z = DJACER*BGENE(NSTMU,I)
  1259.         DO J=1,LRN
  1260.           JJ=J+LRB
  1261.           REL(JJ,I)=REL(JJ,I)-r_z*XGENE(1,J)*XNTT(J)
  1262.         ENDDO
  1263.       ENDDO
  1264. *
  1265.       COMJAC=UNSURM*DJAC*EREF*EREF
  1266.       DO I=1,LRN
  1267.         II=I+LRB
  1268.         r_z = COMJAC*XGENE(1,I)*XNTT(I)
  1269.         DO J=1,I
  1270.           JJ=J+LRB
  1271.           REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J)
  1272.         ENDDO
  1273.       ENDDO
  1274. *
  1275.       COMJAC=UNSURM*DJAC*FREF
  1276.       DO I=1,NBNN
  1277.         II=I+LRB
  1278.         DO J=1,I
  1279.           JJ=J+LRB
  1280.           r_z = 0.D0
  1281.           DO K=1,NCOT
  1282.             r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1283.           ENDDO
  1284.           REL(II,JJ)=REL(II,JJ)+COMJAC*r_z
  1285.         ENDDO
  1286.       ENDDO
  1287. *
  1288.  4080 CONTINUE
  1289.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1290.         INTERR(1)=IB
  1291.         CALL ERREUR(195)
  1292.          noer=195
  1293.         GOTO 9980
  1294.       ENDIF
  1295. *
  1296. *   REMPLISSAGE DE XMATRI
  1297. *
  1298.       CALL REMPMT(REL,LRE,RE(1,1,IB))
  1299.  3080 CONTINUE
  1300.  
  1301.       IF(IRTD.EQ.0) THEN
  1302.         MOTERR(1:8)=CMATE
  1303.         MOTERR(9:16)=NOMFR(MFR/2+1)
  1304.        INTERR(1)=IFOUR
  1305.        CALL ERREUR(81)
  1306.       ENDIF
  1307.  9980 CONTINUE
  1308.       SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55
  1309.       GOTO 510
  1310. *
  1311. C_______________________________________________________________________
  1312. C
  1313. C     JOINTS EN FORMULATION MILIEUX POREUX  - SUITE
  1314. C_______________________________________________________________________
  1315. C
  1316.  185  CONTINUE
  1317.  
  1318. C
  1319. * CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  1320.       IF (IMAT.EQ.1) THEN
  1321.         IF (MATE.NE.1) GOTO 99
  1322.       ELSE
  1323.         GOTO 99
  1324.       ENDIF
  1325. C
  1326. C   POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  1327. C                      NBNO = NOMBRE DE FONCTIONS DE FORME
  1328. C   ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1329. C
  1330.       IF(MFR.EQ.57) IDECAP=2
  1331.       IF(MFR.EQ.59) IDECAP=3
  1332. *
  1333.       NCOT=0
  1334.       NBNO=IPORE
  1335.       NBBB=NBNN
  1336.       NSTN=IDECAP
  1337.       NSTMU=2
  1338.       IF(IFOUR.EQ.2) NSTMU=3
  1339.       LPP=(NBNO-NBBB)*3/2
  1340.       LRN=IDECAP*LPP
  1341.       LRB=LRE-IDECAP*NBNN
  1342.       IELE=NUMGEO(MELE)
  1343.       IF(IELE.EQ.29) NCOT=2
  1344.       IF(IELE.EQ.30) NCOT=6
  1345.       IF(IELE.EQ.31) NCOT=8
  1346.       IF(NCOT.EQ.0) THEN
  1347.         CALL ERREUR(5)
  1348.         GO TO  510
  1349.       ENDIF
  1350. *
  1351.       SEGINI WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1352. *
  1353.       DO 3185  IB=1,NBELEM
  1354. *
  1355. *   ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1356. *
  1357.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1358. *
  1359. *   CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1360. *
  1361.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1362. *
  1363.       CALL ZERO (REL,LRE,LRE)
  1364. *
  1365.       CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1366. *
  1367. *   TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
  1368. *
  1369.       FREF = 1.D6
  1370.       CALL BNPOR2(YGENE,NCOT,IELE)
  1371.       IF (IERR.NE.0) GOTO 9985
  1372. *
  1373. *   BOUCLE SUR LES POINTS DE GAUSS
  1374. *
  1375.       ISDJC=0
  1376.       DO 4185  IGAU=1,NBPGAU
  1377. *
  1378.       NSTB=LHOOK
  1379.       CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1380.      .      SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1381.       IF (DJAC.EQ.0.D0) THEN
  1382.         INTERR(1)=IB
  1383.         CALL ERREUR(259)
  1384.         GOTO 9985
  1385.       ENDIF
  1386.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1387.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  1388. *
  1389.       MPTVAL=IVAMAT
  1390. C*D   IF(IMAT.EQ.2) THEN
  1391. C*D     GO TO 99
  1392. C*D   ELSE IF (IMAT.EQ.1) THEN
  1393. *
  1394.         DO 9185 IM=1,NMATT
  1395.           IF (IVAL(IM).NE.0) THEN
  1396.             MELVAL=IVAL(IM)
  1397.             IBMN=MIN(IB  ,VELCHE(/2))
  1398.             IGMN=MIN(IGAU,VELCHE(/1))
  1399.             VALMAT(IM)=VELCHE(IGMN,IBMN)
  1400.           ELSE
  1401.             VALMAT(IM)=0.D0
  1402.           ENDIF
  1403.  9185   CONTINUE
  1404. *
  1405. C*D     IF(MATE.EQ.1) THEN
  1406.          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1407.      .   CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1408.  
  1409. C*D     ELSE
  1410. C*D       GO TO 99
  1411. C*D     ENDIF
  1412. C*D   ENDIF
  1413. *
  1414.       CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1415.  
  1416.       EREF  =1.D0
  1417. *
  1418.       IF(MFR.EQ.57) THEN
  1419.             COBB(1)  = VALMAT(3)
  1420.             COBB(2)  = VALMAT(4)
  1421.             CPBB(1)  = VALMAT(5)
  1422.             CPBB(2)  = VALMAT(6)
  1423.             KKBB(1,1)= VALMAT(7)
  1424.             KKBB(1,2)= VALMAT(8)
  1425.             KKBB(2,1)= VALMAT(9)
  1426.             KKBB(2,2)= VALMAT(10)
  1427. *
  1428.       ELSE IF(MFR.EQ.59) THEN
  1429.             COBB(1)  = VALMAT(3)
  1430.             COBB(2)  = VALMAT(4)
  1431.             COBB(3)  = VALMAT(5)
  1432.             CPBB(1)  = VALMAT(6)
  1433.             CPBB(2)  = VALMAT(7)
  1434.             CPBB(3)  = VALMAT(8)
  1435.             KKBB(1,1)= VALMAT(9)
  1436.             KKBB(1,2)= VALMAT(10)
  1437.             KKBB(1,3)= VALMAT(11)
  1438.             KKBB(2,1)= VALMAT(12)
  1439.             KKBB(2,2)= VALMAT(13)
  1440.             KKBB(2,3)= VALMAT(14)
  1441.             KKBB(3,1)= VALMAT(15)
  1442.             KKBB(3,2)= VALMAT(16)
  1443.             KKBB(3,3)= VALMAT(17)
  1444.        ENDIF
  1445. *
  1446.         DO IPR=1,IDECAP
  1447.           LPPDEC= (IPR-1)*LPP
  1448.           DO J=1,LPP
  1449.             JX=J+LPPDEC
  1450.             XGENE(IPR,JX)= XGENE(IPR,JX)*XNTT(J)
  1451.           ENDDO
  1452.         ENDDO
  1453. *
  1454.       DJACER=DJAC*EREF
  1455.  
  1456.         DO IPR=1,IDECAP
  1457.           LRBDEC=LRB + (IPR-1)*NBBB
  1458.           LPPDEC= (IPR-1)*LPP
  1459.           COMJAC=COBB(IPR)*DJACER
  1460.           DO I=1,LRB
  1461.             r_z = COMJAC*BGENE(NSTMU,I)
  1462.             DO J=1,LPP
  1463.               JJ=J+LRBDEC
  1464.               JX=J+LPPDEC
  1465.               REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX)
  1466.             ENDDO
  1467.           ENDDO
  1468.         ENDDO
  1469. *
  1470.  
  1471.         DO IPR=1,IDECAP
  1472.           LRBDEC=LRB + (IPR-1)*NBBB
  1473.           LPPDEC= (IPR-1)*LPP
  1474.           COMJAC=CPBB(IPR)*DJACER
  1475.           DO I=1,LRB
  1476.             r_z = COMJAC*BGENE(NSTMU,I)
  1477.             DO J=1,LPP
  1478.               JJ=J+LRBDEC
  1479.               JX=J+LPPDEC
  1480.               REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX)
  1481.             ENDDO
  1482.           ENDDO
  1483.         ENDDO
  1484. *
  1485.         COMJAC=DJAC*EREF*EREF
  1486.         CALL ZERO(XREL,LRN,LRN)
  1487.         CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1488.  
  1489.         DO IPR=1,IDECAP
  1490.           IRBDEC=LRB + (IPR-1)*NBBB
  1491.           IPPDEC= (IPR-1)*LPP
  1492.         DO JPR=1,IDECAP
  1493.           JRBDEC=LRB + (JPR-1)*NBBB
  1494.           JPPDEC= (JPR-1)*LPP
  1495.           DO I=1,LPP
  1496.           II=I+IRBDEC
  1497.           IX=I+IPPDEC
  1498.           DO J=1,LPP
  1499.           JJ=J+JRBDEC
  1500.           JX=J+JPPDEC
  1501.  
  1502. *          IF(IGAU.EQ.1) THEN
  1503. *          PRINT *,'I =',I,' IX=',IX,' II=',II
  1504. *          PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1505. *          ENDIF
  1506.  
  1507.           REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1508.           ENDDO
  1509.           ENDDO
  1510.         ENDDO
  1511.         ENDDO
  1512. *
  1513.         DO IPR=1,IDECAP
  1514.           COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1515.           LRBDEC=LRB + (IPR-1)*NBBB
  1516.           DO I=1,NBNN
  1517.           II=I+LRBDEC
  1518.           DO J=1,NBNN
  1519.             JJ=J+LRBDEC
  1520.             r_z = 0.D0
  1521.             DO K=1,NCOT
  1522.               r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1523.             ENDDO
  1524.             REL(II,JJ)=REL(II,JJ)+COMJAC*r_z
  1525.           ENDDO
  1526.           ENDDO
  1527.         ENDDO
  1528. *
  1529.  4185 CONTINUE
  1530.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1531.         INTERR(1)=IB
  1532.         CALL ERREUR(195)
  1533.          noer=195
  1534.         GOTO 9980
  1535.       ENDIF
  1536. *
  1537. *   REMPLISSAGE DE XMATRI
  1538. *
  1539.       CALL REMPMS(REL,LRE,RE(1,1,IB))
  1540.  3185 CONTINUE
  1541.  
  1542.       IF(IRTD.EQ.0) THEN
  1543.         MOTERR(1:8)=CMATE
  1544.         MOTERR(9:16)=NOMFR(MFR/2+1)
  1545.        INTERR(1)=IFOUR
  1546.        CALL ERREUR(81)
  1547.       ENDIF
  1548.  9985 CONTINUE
  1549.       SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1550.       GOTO 510
  1551. *
  1552. * ERREUR : CAS NON PREVU
  1553. *
  1554.    99 CONTINUE
  1555.       MOTERR(1:4)=NOMTP(MELE)
  1556.       MOTERR(5:12)='RIGI2   '
  1557.       CALL ERREUR(86)
  1558. *
  1559.  510  CONTINUE
  1560. *      WRITE (*,*) 'Sortie de RIGI2.'
  1561. *     SEGDES,XMATRI
  1562.       SEGSUP,MVELCH
  1563.  
  1564. c      RETURN
  1565.       END
  1566.  
  1567.  
  1568.  
  1569.  

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