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

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